OpenVMS Source Code Demos
TCPIP$TCP_CLIENT_QIO_2014A
1000 %title "tcpip$tcp_client_qio_2014a.bas"
%ident "100.1"
declare string constant k_program = "tcpip$tcp_client_qio_2014a"
!========================================================================================================================
! title : tcpip$tcp_client_qio_2014a_100.bas
! author : Neil Rieck ( https://neilrieck.net )
! : (c) copyright 1999,2014 Neil Rieck
! : Waterloo, Ontario, Canada.
! created : 2014-07-31
! references : HP TCP/IP Services for OpenVMS
! Sockets API and System Services Programming (manual: BA548-90002)
! notes : 1. stack programming on VMS and OpenVMS can be done by "Sockets API" (easier) or
! "VMS System Services" (harder; a lot like building an Interociter)
! 2. A and B client demos employ sys$qiow (synchronous) via VMS System Services
! 3. The C client demo employs sys$qio (asynchronous) to provide even more control
! OS : OpenVMS (Alpha or Itanium) or VMS on VAX
! Stack : TCP/IP Services V5.0 or higher (but should work with any stack after a few mods)
! compile : $ bas tcpip$tcp_client_qio_2014a_100.bas
! link : $ link tcpip$tcp_client_qio_2014a_100
! history :
! ver who when what
! --- --- ------ --------------------------------------------------------------------------------------------------------
! 100 NSR 140801 1. this is a BASIC version of tcpip$tcp_client_qio_100.c (without gethostbyname)
!========================================================================================================================
option type=explicit ! formal coding
on error goto common_trap ! old school trapping for this demo
!
external long function htonl(long) ! host to network long
external long function htons(word) ! host to network short
external long function qtol(quad) ! quad to long
!
%include "starlet" %from %library "sys$library:basic$starlet" ! system services
%include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$
%include "$iodef" %from %library "sys$library:basic$starlet" ! io$
%include "$efndef" %from %library "sys$library:basic$starlet" ! efn$
%include "lib$routines" %from %library "sys$library:basic$starlet" ! lib$
%include "$libdef" %from %library "sys$library:basic$starlet" ! eg. lib$_normal
%include "$iledef" %from %library "sys$library:basic$starlet" ! ile3$ (Item List Entry 3 structures)
!~~~ %include "$iosbdef" %from %library "sys$library:basic$starlet" x iosb$ (iosb structures)
!
! I need the following iosb to get around a limitation found in the BASIC version of starlet
! (the library definition of sys$qio requires a quad datatype for iosb)
!
! question : How did I know?
! answer : Hacking
! reference: https://neilrieck.net/docs/openvms_notes_hacking_starlet.html
!
record my_iosb_rec !
variant !
case ! vanilla
group one !
word iosb$w_status !
word iosb$w_bcnt !
long iosb$l_dev_depend !
end group !
case ! used in sys$getqui
group two !
long iosb$l_getxxi_status !
long iosb$l_reserved !
end group !
case ! used to satisfy the compiler
group three !
basic$quadword iosb$quad ! unsigned quad word (system calls)
end group !
end variant !
end record !
%include "sys$library:TCPIP$INETDEF.BAS" ! need this for various inet constants etc.
!
record my_sockchar_rec ! socket characteristics (record definition)
word sc_prot ! protocol
byte sc_type ! type
byte sc_af ! address family
end record !
!
record my_itmlst2_rec ! item-list 2 descriptor
word il2_length ! length
word il2_type !
long il2_address !
end record !
!
! named constants
!
declare long constant TCPBUFSIZ = 8192 ! buffer size (no larger than 32767)
declare long constant USRBUFSIZ = 512 ! user input buffer size
declare word constant SERV_PORTNUM = 80 ! server port number (80=http)
!
! declare variables
!
map(recv)string buffer_r = TCPBUFSIZ !
map(xmit)string buffer_w = TCPBUFSIZ !
!
declare my_iosb_rec iosb ! i/o status block
declare my_sockchar_rec conn_sockchar ! connection socket characteristics buffer
declare SOCKADDRIN serv_addr ! server socket address inet structure
declare my_itmlst2_rec serv_itemlst !
declare word conn_channel !
declare quad junk64 !
declare long ip_address !
declare long rc !
declare long bytes_w !
declare long readcount !
declare long bytes_r !
declare long bytes_r_total !
declare string msg$ !
declare string inet_device !
!
!=======================================================================
! main
!=======================================================================
2000 main:
print !
print "-i-program: "+ k_program !
print "-i-this program will connect to a website on port "+ str$(SERV_PORTNUM)
sleep 1 !
!
! initialize variables
!
inet_device = "TCPIP$DEVICE:" !
!
conn_sockchar::sc_prot = TCPIP$C_TCP ! init (local) connection socket
conn_sockchar::sc_type = TCPIP$C_STREAM !
conn_sockchar::sc_af = TCPIP$C_AF_INET !
!
declare word sck_parm(2)
sck_parm(0) = TCPIP$C_TCP
sck_parm(1) = INET_PROTYP$C_STREAM
!
serv_addr::SIN$W_FAMILY = TCPIP$C_AF_INET ! init (remote) connection socket
serv_addr::SIN$W_PORT = htons(SERV_PORTNUM) !
!
! for this demo we will use a hard-coded address of 142.180.221.226
! (will perform a gethostbyname in a future demo)
!
3000 junk64 = 142 * 16777216 + ! 2^24 &
180 * 65536 + ! 2^16 &
221 * 256 + ! 2^8 &
226 ! 2^0
ip_address = qtol (junk64) !
serv_addr::SIN$L_ADDR = htonl (ip_address) ! eg. 142.180.221.226
!
serv_itemlst::il2_length = SIN$K_LENGTH ! need size of serv_addr (SOCKADDRIN)
serv_itemlst::il2_type = TCPIP$C_SOCK_NAME !
serv_itemlst::il2_address = loc(serv_addr) ! need addr of serv_addr
!
! create socket (part 1/2)
!
4000 print "-i-creating socket (assign)" !
rc = sys$assign(inet_device, conn_channel,,) !
if (rc and 7%) <> 1% then !
print "-e-error:";rc;"while assigning channel to TCPIP device" !
end if !
!
! create socket (part 2/2)
!
4010 print "-i-creating socket (qio)"
rc = sys$qiow( EFN$C_ENF, ! event flag &
conn_channel, ! i/o channel &
IO$_SETMODE, ! i/o function code &
iosb::iosb$quad, ! i/o status block &
, ! ast service routine &
, ! ast parameter &
conn_sockchar, ! p1 - socket characteristics &
, ! p2 &
, ! p3 &
, ! p4 &
, ! p5 &
! p6 &
) !
if (rc and 7%) = 1% then ! if the system call queued properly
rc = iosb::iosb$w_status ! then we want to check the final result
end if !
if (rc and 7%) <> 1% then !
print "-e-error:";rc;"while creating socket" !
end if !
!
! connect to server
!
4020 print "-i-connecting to host"
rc = sys$qiow( EFN$C_ENF, ! event flag &
conn_channel, ! i/o channel &
IO$_ACCESS, ! i/o function code &
iosb::iosb$quad, ! i/o status block &
, ! ast service routine &
, ! ast parameter &
, ! p1 &
, ! p2 &
loc(serv_itemlst), ! p3 - remote socket info &
, ! p4 &
, ! p5 &
! p6 &
) !
if (rc and 7%) = 1% then ! if the system call queued properly
rc = iosb::iosb$w_status ! then we want to check the final result
end if !
if (rc and 7%) <> 1% then !
print "-e-error:";rc;"while connecting to server" !
end if !
!
! send a message to retrieve the default web page
!
msg$ = "GET / HTTP/1.0" + cr + lf + cr + lf ! a blank line marks the end of an HTTP block
bytes_w = len(msg$) ! determine the data length
buffer_w = msg$ ! xref data to buffer for qio
!
4030 print "-i-sending data"
rc = sys$qiow( EFN$C_ENF, ! event flag &
conn_channel, ! i/o channel &
IO$_WRITEVBLK, ! i/o function code &
iosb::iosb$quad, ! i/o status block &
, ! ast service routine &
, ! ast parameter &
buffer_w, ! p1 buffer address &
bytes_w, ! p2 buffer length (to send) &
, ! p3 &
, ! p4 &
, ! p5 &
! p6 &
) !
if (rc and 7%) = 1% then ! if the system call queued properly
rc = iosb::iosb$w_status ! then we want to check the final result
end if !
if (rc and 7%) <> 1% then !
print "-e-error:";rc;"while sending to server" !
end if !
!
! read the response
!
4040 print "-i-receiving data"
readcount = 0 ! init loop counter
bytes_r_total = 0 !
!
read_loop:
bytes_r = 0 ! init
readcount = readcount + 1
print "-i-receiving count:";readcount
print " -------------------"
rc = sys$qiow( EFN$C_ENF, ! event flag &
conn_channel, ! i/o channel &
IO$_READVBLK, ! i/o function code &
iosb::iosb$quad, ! i/o status block &
, ! ast service routine &
, ! ast parameter &
buffer_r, ! p1 buffer address &
TCPBUFSIZ, ! p2 buffer length (to send) &
, ! p3 &
, ! p4 &
, ! p5 &
! p6 &
) !
if (rc and 7%) = 1% then ! if the system call queued properly
rc = iosb::iosb$w_status ! then we want to check the final result
end if !
if (rc and 7%) <> 1% then !
select rc !
case 8428 ! this fatal error is normal for the web
print "-w-status:";rc;"network partner disconnected logical link"
case else !
print "-e-error:";rc;"while reading from server" !
end select !
else !
bytes_r = iosb::iosb$w_bcnt ! get the actual number of bytes xfer'd
print left$(buffer_r,bytes_r) ! output that amount
bytes_r_total = bytes_r_total + bytes_r ! also add to total
if (bytes_r > 0) and &
(readcount < 100) then ! if not too crazy
goto read_loop ! yeah, I know, bad form (but this is just a demo)
end if !
end if !
print "-i-total bytes received:";bytes_r_total
!
! shutdown
!
print "-i-shutting down the socket"
rc = sys$qiow( EFN$C_ENF, ! event flag &
conn_channel, ! i/o channel &
IO$_DEACCESS or IO$M_SHUTDOWN, ! i/o function code &
iosb::iosb$quad, ! i/o status block &
, ! ast service routine &
, ! ast parameter &
, ! p1 &
, ! p2 &
, ! p3 &
, ! p4 &
TCPIP$C_DSC_ALL, ! p5 &
! p6 &
) !
if (rc and 7%) = 1% then ! if the system call queued properly
rc = iosb::iosb$w_status ! then we want to check the final result
end if !
if (rc and 7%) <> 1% then !
print "-e-error:";rc;"during socket shutdown" !
end if !
!
! close the socket
!
print "-i-closing the socket"
rc = sys$qiow( EFN$C_ENF, ! event flag &
conn_channel, ! i/o channel &
IO$_DEACCESS , ! i/o function code &
iosb::iosb$quad, ! i/o status block &
, ! ast service routine &
, ! ast parameter &
, ! p1 &
, ! p2 &
, ! p3 &
, ! p4 &
, ! p5 &
! p6 &
) !
if (rc and 7%) = 1% then ! if the system call queued properly
rc = iosb::iosb$w_status ! then we want to check the final result
end if !
if (rc and 7%) <> 1% then !
print "-e-error:";rc;"during socket shutdown" !
end if !
!
! deassign the socket
!
rc = sys$dassgn(conn_channel) !
if (rc and 7%) = 1% then !
print "-e-error:";rc;"during deassign" !
end if !
!
goto fini ! that's all she wrote...
!
! old-school common trap (normally you would only use inline "when error / use / end when" blocks
!
common_trap:
print
print "common error trap" !
print "-i-line ";erl !
print "-i-error ";err !
print "-i-text ";ert$(err) !
resume fini ! fix the stack
!
fini:
print "-i-adios..." !
32000 end !
!
!########################################################################################################################
! external functions
!########################################################################################################################
!
!=======================================================================
! host to network short
! OpenVMS is little endian but the network is big endian
!=======================================================================
32010 function word htons(word inbound) !
option type=explicit !
!
map(htons0) word sw0_word0
map(htons0) byte sw0_byte0 , &
byte sw0_byte1
!
map(htons1) word sw1_word0
map(htons1) byte sw1_byte0 , &
byte sw1_byte1
!
sw0_word0 = inbound !
sw1_byte0 = sw0_byte1 !
sw1_byte1 = sw0_byte0 !
htons = sw1_word0 ! presto
end function !
!
!=======================================================================
! host to network long
! OpenVMS is little endian but the network is big endian
!=======================================================================
32020 function long htonl(long inbound) !
option type=explicit !
!
map(htonl0) long sw0_long0
map(htonl0) word sw0_word0 , &
word sw0_word1
map(htonl0) byte sw0_byte0 , &
byte sw0_byte1 , &
byte sw0_byte2 , &
byte sw0_byte3
!
map(htonl1) long sw1_long0
map(htonl1) word sw1_word0 , &
word sw1_word1
map(htonl1) byte sw1_byte0 , &
byte sw1_byte1 , &
byte sw1_byte2 , &
byte sw1_byte3
!
sw0_long0 = inbound
sw1_byte0 = sw0_byte3
sw1_byte1 = sw0_byte2
sw1_byte2 = sw0_byte1
sw1_byte3 = sw0_byte0
htonl = sw1_long0 ! presto
end function !
!
!=======================================================================
! quad to long
! OpenVMS BASIC has no unsigned integers but we sometimes need to
! do 32-bit unsigned math. The lazy way is to do 64-bit math then
! truncate back to 32-bits (okay if the value is not too large)
!=======================================================================
32030 function long qtol(quad inbound) !
option type=explicit !
!
map(qtol) quad sw0_quad0
map(qtol) long sw0_long0 , &
long sw0_long1
!
sw0_quad0 = inbound !
qtol = sw0_long0 ! presto
if sw0_long1 <> 0 then ! this should never happen
print "-w-oops, information was lost during QUAD->LONG conversion)" !
end if !
end function !
!