OpenVMS Source Code Demos
TCPIP$TCP_CLIENT_QIO_2014C
1000 %title "tcpip$tcp_client_qio_2014c_xxx.bas"
%ident "102.1"
declare string constant k_program = "tcpip$tcp_client_qio_2014c"
!========================================================================================================================
! title : tcpip$tcp_client_qio_2014c
! author : Neil Rieck ( https://neilrieck.net )
! : (c) copyright 1999,2014 Neil Rieck
! : Waterloo, Ontario, Canada.
! created : 2014-08-04
! 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
! 4. Lots of in-line code in this demo. Normally it would be moved to subroutines or external functions.
! 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_2014c_102.bas
! link : $ link tcpip$tcp_client_qio_2014c_102
! history :
! ver who when what
! --- --- ------ --------------------------------------------------------------------------------------------------------
! 100 NSR 140804 0. started with TCPIP$TCP_CLIENT_QIO_2014B_100.BAS (synchronous)
! 1. function "my_gethostbyname" now contains asynchronous i/o (changed qiow to qio then added timers)
! 101 NSR 140805 0. started with TCPIP$TCP_CLIENT_QIO_2014C_101.BAS
! 1. most of the main body now contains asynchronous i/o (changed qiow to qio then added timers)
! 102 NSR 140814 1. annotation and code cleanup
!========================================================================================================================
option type=explicit ! formal coding
set no prompt !
on error goto common_trap ! old school trapping for this demo
!
! home brewed code
!
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
external long function parse_dest(string,string) !
external long function my_gethostbyname(string by desc, long dim() by ref, long)
external long function get_ef_bit_vector(long) ! required for used with SYS$WFLOR
!
! system references
!
%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 long mask !
declare quad junk64 !
declare basic$QuadWord DeltaQuad ! for sys$bintim
declare string msg$ !
declare string inet_device !
declare string dest$ !
declare string path$ !
declare string octet$(3) !
declare long octet(3) , &
ip_address , &
rc , &
bytes_w , &
readcount , &
bytes_r , &
bytes_r_total , &
http% , &
junk% , &
junk1 , &
junk2 , &
dest_kind , &
i% , &
tcp_ef , ! tcpip event flag &
tcp_ef_state , ! tcpip event flag state &
tmr_ef , ! timer event flag &
tmr_ef_state ! timer event flag state
!
!=======================================================================
! main
!=======================================================================
2000 main:
print
print "-i-program: "+ k_program
print "-i-this program will connect to a website on port "+ str$(SERV_PORTNUM)
!
! 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 !
!
serv_addr::SIN$W_FAMILY = TCPIP$C_AF_INET ! init (remote) connection socket
serv_addr::SIN$W_PORT = htons(SERV_PORTNUM) !
!
get_dest:
print "-i-Menu:"
print " 1 = 142.180.221.226"
print " 2 = kawc96.on.bell.ca"
print " Q = quit (default)"
print " or anything else (eg. www3.sympatico.ca )"
print " (eg. neilrieck.net/)"
print
print "-?-destination? "; !
input dest$ !
dest$ = edit$(dest$,2) ! no white space
select dest$ !
case "1" !
dest$ = "142.180.221.226" !
case "2" !
dest$ = "kawc96.on.bell.ca" !
case else !
goto fini if len(dest$)<=1 ! "Q","q"
end select !
!
3000 dest_kind = parse_dest(dest$, path$) ! all three params will be modified
!
if dest_kind = 0 then !
print "-e-error, your input data is not useable" !
goto get_dest !
end if !
!-----------------------------------------------------------------------
if dest_kind = 1 then ! we "know" this is an IPv4 address
print "-i-you entered an IPv4 address" !
http% = 0 ! send HTTP/1.0 request
junk1 = 0 ! init for parse
for i% = 0 to 3 ! sc
junk2 = pos(dest$, ".", junk1+1) !
junk2 = len(dest$)+1 if junk2 = 0 !
octet$(i%) = seg$(dest$,junk1+1,junk2-1) !
junk1 = junk2 ! reference pt moves along
next i% !
when error in !
junk64 = integer(octet$(0)) * 16777216 + ! 2^24 &
integer(octet$(1)) * 65536 + ! 2^16 &
integer(octet$(2)) * 256 + ! 2^8 &
integer(octet$(3)) ! 2^0
use !
junk64 = 0 !
end when !
if junk64 = 0 then !
print "-e-error:";err;"during data conversion" !
goto get_dest !
end if !
end if !
!-----------------------------------------------------------------------
if dest_kind = 2 then ! we think this might be a dns name
print "-i-you entered a dns name" !
http% = 1 ! send HTTP/1.1 request
rc = my_gethostbyname(dest$, octet(), 1) ! magic happens here :-)
if ((rc and 7%) <> 1) then !
print "-e-dns lookup failed with status:";rc !
goto get_dest !
end if !
when error in !
junk64 = octet(0) * 16777216 + ! 2^24 &
octet(1) * 65536 + ! 2^16 &
octet(2) * 256 + ! 2^8 &
octet(3) ! 2^0
use !
junk64 = 0 !
end when !
if junk64 = 0 then !
print "-e-error:";err;"during data conversion" !
goto get_dest !
end if !
end if !
!-----------------------------------------------------------------------
! prepare to connect
!
! allocate some event flags
! create a socket (open a connetion to the network device)
! open a connection to the network device)
!-----------------------------------------------------------------------
gosub allocate_event_flags
!
! init some network stuff
!
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 (qiow)" ! synchronous (no point changing to async)
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 &
conn_sockchar,,,,,) ! p1 - socket characteristics
if ((rc and 7%) = 1) then ! if the system call queued properly
rc = iosb::iosb$w_status ! then check the operational result
end if !
if ((rc and 7%) <> 1) then !
print "-e-error:";rc;"while creating socket" !
goto rc_exit !
end if !
!-----------------------------------------------------------------------
! connect to server (async)
!
! arm 10-second timer
! que async request
! wait for one of the flags
! test
!-----------------------------------------------------------------------
4020 declare string constant k_delay010 = "0 00:00:10" ! prep for a 10 second timeout
rc = sys$bintim(k_delay010, DeltaQuad ) ! compute delta time
print "-e-sys$bintim rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
print "-i-arming timer associated with ef:";tmr_ef
rc = sys$setimr(tmr_ef, DeltaQuad by ref,,,) ! use delta to schedule a wake up
print "-e-sys$setimr rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
print "-i-connecting to server via qio associated with ef:";tcp_ef ! async (no wait)
rc = sys$qio( tcp_ef, ! event flag &
conn_channel, ! i/o channel &
IO$_ACCESS, ! i/o function code &
iosb::iosb$quad,,,,, ! i/o status block &
loc(serv_itemlst),,,) ! p3 - remote socket info
if ((rc and 7%) <> 1) then ! if system call failed (never happens)
print "-e-status:";rc;"while queuing server connect" !
junk% = sys$cantim(,) ! cancel timers and bail
goto rc_exit !
end if !
!
! note: for the SYS$WFLOR call to work, both event flags must be in the same event flag cluster.
! The first parameter is only used to determine which event flag cluster to test.
! The second parameter (mask) contains bits representing event flags within that cluster
!
mask = get_ef_bit_vector(tcp_ef) ! insert vector 1 into mask
mask = mask or get_ef_bit_vector(tmr_ef) ! insert vector 2 into mask
!
! wait for a response from one of the two event flags
!
print "-i-waiting for one of two event flags" !
rc = sys$wflor( tcp_ef, mask) ! wait for a response from one of two flags
print "-e-sys$wflor rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
! which event flag is set? TCP or TIMER?
!
rc = sys$readEF(tcp_ef, junk%) ! test TCP event flag
select rc !
case SS$_WASCLR !
tcp_ef_state = 0 !
case SS$_WASSET !
print "-i-tcp ef was set" !
tcp_ef_state = 1 !
case else !
print "-e-sys$readef-tcp rc: "+ str$(rc) !
end select !
!
rc = sys$readEF(tmr_ef, junk%) ! test TIMER event flag
select rc !
case SS$_WASCLR !
tmr_ef_state = 0 !
case SS$_WASSET !
print "-w-timer ef was set (oops)" !
tmr_ef_state = 1 !
case else !
print "-e-sys$readef-timer rc: "+ str$(rc) !
end select !
!
if (tcp_ef_state = 1) then ! tcp fired so cancel timer
junk% = sys$cantim(,) !
end if !
!
if (tmr_ef_state = 1) then ! timer fired so cancel i/o
print "-e-did not connect in time" !
junk% = sys$cancel(conn_channel) !
rc = 2 ! vms-e-
goto rc_exit !
end if !
!
! At this point the qio has completed. so test operational status (iosb)
!
rc = iosb::iosb$w_status ! test the operational status
if ((rc and 7%) <> 1) then !
print "-e-error:";rc;"while connecting to server" !
goto rc_exit !
else !
print "-i-connection established" !
end if !
!-----------------------------------------------------------------------
! send a message to retrieve the default web page
!
! eg. examples: 1 GET / HTTP/1.0
!
! 2 GET /n.rieck HTTP/1.0
!
! 3 GET /n.rieck HTTP/1.1
! host: www3.sympatico.ca
!
! caveat: websevers sitting behind load balancers, or webservers in the cloud,
! usually will not accept requests employing HTTP/1.0
!-----------------------------------------------------------------------
path$ = "/" if path$ = "" !
if http% = 0 then !
print "-i-sending this HTTP 1.0 request:"
msg$ = "GET "+ path$ +" HTTP/1.0" + cr + lf + &
cr + lf ! blank line marks end of HTTP block
else !
print "-i-sending this HTTP 1.1 request:"
msg$ = "GET "+ path$ +" HTTP/1.1" + cr + lf + &
"host: "+ dest$ + cr + lf + &
cr + lf ! blank line marks end of HTTP block
end if !
print msg$
bytes_w = len(msg$) ! determine the data length
buffer_w = msg$ ! xref data to buffer for qio
!
rc = sys$bintim(k_delay010, DeltaQuad ) ! compute delta time
print "-e-sys$bintim rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
print "-i-arming timer associated with ef:";tmr_ef
rc = sys$setimr(tmr_ef, DeltaQuad by ref,,,) ! use delta to schedule a wake up
print "-e-sys$setimr rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
print "-i-sending to server via qio associated with ef:";tcp_ef ! async (no wait)
4030 rc = sys$qio( tcp_ef, ! event flag &
conn_channel, ! i/o channel &
IO$_WRITEVBLK, ! i/o function code &
iosb::iosb$quad,,, ! i/o status block &
buffer_w, ! p1 buffer address &
bytes_w,,,,) ! p2 buffer length (to send)
if ((rc and 7%) <> 1) then ! if system call failed (never happens)
print "-e-status:";rc;"while queuing writing to server"
junk% = sys$cantim(,) ! cancel timers and bail
goto rc_exit !
end if !
!
mask = get_ef_bit_vector(tcp_ef) ! insert vector 1 into mask
mask = mask or get_ef_bit_vector(tmr_ef) ! insert vector 2 into mask
!
! wait for a response from one of the two event flags
!
print "-i-waiting for one of two event flags" !
rc = sys$wflor( tcp_ef, mask) ! wait for a response from one of two flags
print "-e-sys$wflor rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
! which event flag is set? TCP or TIMER?
!
rc = sys$readEF(tcp_ef, junk%) ! test TCP event flag
select rc !
case SS$_WASCLR !
tcp_ef_state = 0 !
case SS$_WASSET !
print "-i-tcp ef was set"
tcp_ef_state = 1 !
case else !
print "-e-sys$readef-tcp rc: "+ str$(rc) !
end select !
!
rc = sys$readEF(tmr_ef, junk%) ! test TIMER event flag
select rc !
case SS$_WASCLR !
tmr_ef_state = 0 !
case SS$_WASSET !
print "-w-timer ef was set (oops)" !
tmr_ef_state = 1 !
case else !
print "-e-sys$readef-timer rc: "+ str$(rc) !
end select !
!
if (tcp_ef_state = 1) then ! tcp fired so cancel timer
junk% = sys$cantim(,) !
end if !
!
if (tmr_ef_state = 1) then ! timer fired so cancel i/o
print "-e-did not connect in time" !
junk% = sys$cancel(conn_channel) !
rc = 2 ! vms-e-
goto rc_exit !
end if !
!
! At this point the qio has completed so test the operational status (iosb)
!
rc = iosb::iosb$w_status ! test the operational status
if ((rc and 7%) <> 1) then !
print "-e-error:";rc;"while sending to server" !
goto rc_exit !
else !
print "-i-message sent" !
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$bintim(k_delay010, DeltaQuad ) ! compute delta time
print "-e-sys$bintim rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
print "-i-arming timer associated with ef:";tmr_ef !
rc = sys$setimr(tmr_ef, DeltaQuad by ref,,,) ! use delta to schedule a wake up
print "-e-sys$setimr rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
print "-i-connecting to server via qio associated with ef:";tcp_ef ! async (no wait)
rc = sys$qio( tcp_ef, ! event flag &
conn_channel, ! i/o channel &
IO$_READVBLK, ! i/o function code &
iosb::iosb$quad,,, ! i/o status block &
buffer_r, ! p1 buffer address &
TCPBUFSIZ,,,,) ! p2 buffer length (recv buffer size)
if ((rc and 7%) <> 1) then ! if system call failed (never happens)
junk% = sys$cantim(,) ! cancel timers and bail
goto rc_exit !
end if !
!
mask = get_ef_bit_vector(tcp_ef) ! insert vector 1 into mask
mask = mask or get_ef_bit_vector(tmr_ef) ! insert vector 2 into mask
!
! wait for a response from one of the two event flags
!
print "-i-waiting for one of two event flags" !
rc = sys$wflor( tcp_ef, mask) ! wait for a response from one of two flags
print "-e-sys$wflor rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
! which event flag is set? TCP or TIMER?
!
rc = sys$readEF(tcp_ef, junk%) ! test TCP event flag
select rc !
case SS$_WASCLR !
tcp_ef_state = 0 !
case SS$_WASSET !
print "-i-tcp ef was set" !
tcp_ef_state = 1 !
case else !
print "-e-sys$readef-tcp rc: "+ str$(rc) !
end select !
!
rc = sys$readEF(tmr_ef, junk%) ! test TIMER event flag
select rc !
case SS$_WASCLR !
tmr_ef_state = 0 !
case SS$_WASSET !
print "-w-timer ef was set (oops)" !
tmr_ef_state = 1 !
case else !
print "-e-sys$readef-timer rc: "+ str$(rc) !
end select !
!
if (tcp_ef_state = 1) then ! tcp fired so cancel timer
junk% = sys$cantim(,) !
end if !
!
if (tmr_ef_state = 1) then ! timer fired so cancel i/o
print "-e-did not read anything in time" !
junk% = sys$cancel(conn_channel) !
rc = 2 ! vms-e-
goto rc_exit !
end if !
!
! At this point the qio has completed.
! Now we test the status word assiociated with the iosb
!
rc = iosb::iosb$w_status ! test the operational status
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
if 1=0 then ! if we want more information after each $qio
print
print "----------------------"
print "xfer count:";bytes_r
print "----------------------"
sleep 1
end if
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 ! if data was present &
(readcount < 150) then ! and we're 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" ! no point changing to async
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 &
TCPIP$C_DSC_ALL,,) ! p5
if ((rc and 7%) = 1) then ! if system call queued properly
rc = iosb::iosb$w_status ! then check the operational 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" ! no point changing to async
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 &
,,,,,,,) !
if ((rc and 7%) = 1) then ! if system call queued properly
rc = iosb::iosb$w_status ! then check the operational 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...
!
! <<< allocate event flags >>>
!
allocate_event_flags:
if tcp_ef = 0 then ! if not yet allocated
rc = lib$get_EF( tcp_ef ) ! allocate ef for tcp
if ((rc and 7%) <> 1) then !
print "lib$get_EF-1 rc: ";str$(rc) !
goto rc_exit !
end if !
end if !
!
if tmr_ef = 0 then ! if not yet allocated
rc = lib$get_EF( tmr_ef ) ! allocate ef for timer
if ((rc and 7%) <> 1) then !
print "lib$get_EF-2 rc: ";str$(rc) !
goto rc_exit !
end if !
end if !
return !
!
! 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) !
rc = 2 ! VMS-e-
resume rc_exit ! fix the stack
!
fini:
rc = 1 ! VMS-s-
goto fini_common !
!
rc_exit: !
print "-i-in abnormal exit area" !
!
fini_common:
print "-i-adios..." !
32000 end program rc ! <<<--- return exit code to DCL
!
!########################################################################################################################
! 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
! trucate 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 !
!
!=======================================================================
! <<< parse_dest >>>
!
! examples:
! 1 input: "142.180.221.226" ??
! return: 1 "142.180.221.226" ""
! 2 input: "www3.sympatico.ca" ??
! return: 2 "www3.sympatico.ca" ""
! 3 input: "142.180.221.226/n.rieck/" ??
! return: 1 "142.180.221.226" "/n.rieck/"
! 4 input: "neilrieck.net/" ??
! return: 2 "www3.sympatico.ca" "/n.rieck/"
! 5 input: "abcd" ??
! return: 0 "" ""
! 6 input: "http://www3.sympatico.ca" ??
! return: 0 "" ""
! +------ 0 = unusable address
! +------ 1 = IP address
! +------ 2 = dns name
!=======================================================================
32040 function long parse_dest(string dest$, string path$) !
option type=explicit !
declare long dots ,&
nums ,&
alph ,&
othe ,&
slash_pos ,&
i% ,&
result
!-----------------------------------------------------------------------
main:
result = 0 ! assume the worst (unusable)
!
slash_pos = pos(dest$, "/", 1) ! any slashes here?
if slash_pos > 0 then ! yes
path$ = right$(dest$,slash_pos) ! do this first
dest$ = left$( dest$,slash_pos - 1) !
else ! no
path$ = "" !
end if !
!
for i% = 1 to len(dest$) ! prescan the destination
select mid$(dest$, i%, 1) !
case "." !
dots = dots + 1 !
case "0" to "9" !
nums = nums + 1 !
case "a" to "z" !
alph = alph + 1 !
case else !
othe = othe + 1 !
end select !
next i% !
!
goto data_unusable if othe > 0 ! we can't use this data
!
! eg. "142.180.221.226"
!
if dots=3 and nums>=4 and alph=0 then ! hey, might be IP4
result = 1 !
goto function_exit !
end if !
!
! eg. "bell.ca" or "www3.sympatico.ca"
!
if dots>0 and alph>=3 then ! hey, might be a dns
result = 2 !
goto function_exit !
end if !
!
data_unusable:
dest$ = "" !
path$ = "" !
result = 0 !
!
! result must be set before this point
!
function_exit: !
parse_dest = result !
end function !
!
!=======================================================================
! <<< my get host by name (in VMS-BASIC) >>>
!
! author : Neil Rieck
! created: 2014-08-04
! notes : derived from my demo: GET_HOST_BY_NAME_QIO.BAS
!=======================================================================
32050 function long my_gethostbyname(string dns_name$, long octets() by ref, long debug)
option type=explicit ! cuz tricks are for kids
print "-i- >>> function: my_gethostbyname()" if debug > 0 !
!
! <<< external declarations >>>
!
%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 "lib$routines" %from %library "sys$library:basic$starlet" ! lib$
%include "$dscdef" %from %library "sys$library:basic$starlet" ! descriptor stuff
!~~~ %include "sys$library:ucx$inetdef.bas" x ucx defs (for tcpip < v5.0)
%include "sys$library:tcpip$inetdef.bas" ! tcpip defs (for tcpip >= v5.0)
!~~~ %include "$iosbdef" %from %library "sys$library:basic$starlet" x iosb$ (iosb structures)
!
! I need this iosb to get around a limitation in the BASIC version of starlet
!
! question : How did I know?
! answer : Hacking
! reference: https://neilrieck.net/docs/openvms_notes_hacking_starlet.html
!
! my I/O Status Block (record)
!
record myIosbRec !
variant !
case !
group one ! 32-bit structure
!
! Manual: "Compaq TCP/IP Services for OpenVMS"
! Chapter "Sockets API and System Services Programming"
! Example 2-25: BIND Lookup (System Services)
!
word iosb$w_status ! 16-bit status
word iosb$w_bcnt ! 16-bit byte count
long iosb$l_dev_depend ! 32-bit device dependent data
end group one !
case !
group two !
basic$quadword iosb$quad ! unsigned quad word (system calls)
end group two !
end variant !
end record myIosbRec !
!
! <<< home brewed functions >>>
!
external long function get_ef_bit_vector(long) ! required for used with SYS$WFLOR
!
! <<< variable declarations >>>
!
declare long rc , ! return code &
junk% , ! &
ptr% , ! &
i% , ! &
j% , ! &
timeout_count% , ! &
tcp_ef , ! tcp event flag &
tcp_ef_state , ! tcp event flag state &
tmr_ef , ! timer event flag &
tmr_ef_state , ! timer event flag state &
mask , ! &
word dns_channel , ! INET channel &
bytecnt , ! &
long command , ! INET command &
basic$QuadWord DeltaQuad , ! for sys$bintim &
myIosbRec iosb , ! &
HostEntDef myHostEnt , ! see: sys$library:tcpip$inetdef.bas &
NetEntDef myNetEnt , ! see: sys$library:tcpip$inetdef.bas &
string buffer$ , ! &
junk$ !
!-----------------------------------------------------------------------
! function main
!-----------------------------------------------------------------------
main: !
!
! <<< allocate some event flags for later use >>>
!
if tcp_ef = 0 then ! if not yet allocated
rc = lib$get_EF( tcp_ef ) ! allocate ef for tcp
if ((rc and 7%) <> 1) then !
print "-e-lib$get_EF-1 rc: ";str$(rc) !
goto rc_exit !
end if !
end if !
!
if tmr_ef = 0 then ! if not yet allocated
rc = lib$get_EF( tmr_ef ) ! allocate ef for timer
if ((rc and 7%) <> 1) then !
print "-e-lib$get_EF-2 rc: ";str$(rc) !
goto rc_exit !
end if !
end if !
!
! <<< prep >>>
!
declare string inet_dev ! dynamic string descriptor (good)
inet_dev = "TCPIP$DEVICE:" !
!
! Assign a channel to the TCPIP device
!
rc = sys$assign(inet_dev, dns_channel,,,) ! assign a channel
if ((rc and 7%) <> 1) then !
print "-e-Failed to assign channel to TCPIP device." !
goto rc_exit !
end if !
!
! we need a "long descriptor" to use io$_acpcontrol in a call to sys$qio
! (I wonder which idiot decided to use a descriptor to pass a long integer?)
!
declare dscdef1 cmd_descriptor !
cmd_descriptor::DSC$W_MAXSTRLEN = 4 ! 4 bytes = long
cmd_descriptor::DSC$B_DTYPE = DSC$K_DTYPE_DSC ! general descriptor
cmd_descriptor::DSC$B_CLASS = DSC$K_CLASS_S ! static
cmd_descriptor::DSC$A_POINTER = loc(command) ! yup, address of an integer
!
command = inetacp_func$c_gethostbyname + ! function: gethostbyname &
(inetacp$c_trans * 256) ! sub-func: (binary address)
!~~~ buffer$ = space$( 4) x space for 4 binary bytes (IPv4)
buffer$ = space$(16) ! space for 16 binary bytes (IPv6)
!
!-----------------------------------------------------------------------
! do an actual dns lookup asynchonously (guarenteed no-hang)
!
! 1. arm a 10-second timer
! 2. enque the tcp operation
! 3. wait for what whichever flag is rasied first
!-----------------------------------------------------------------------
declare string constant k_delay010 = "0 00:00:10" ! prep for a 10 second timeout
rc = sys$bintim(k_delay010, DeltaQuad ) ! compute delta time
print "-e-sys$bintim rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
print "-i-arming timer associated with ef:";tmr_ef
rc = sys$setimr(tmr_ef, DeltaQuad by ref,,,) ! use delta to schedule a wake up
print "-e-sys$setimr rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
print "-i-requesting dns lookup via qio associated with ef:";tcp_ef
rc = sys$qio( tcp_ef , ! Event flag &
dns_channel , ! Channel number &
io$_acpcontrol , ! I/O function &
iosb::iosb$quad ,,, ! I/O status block &
cmd_descriptor , ! P1 needs to be a descriptor &
loc(dns_name$ ) , ! P2 &
loc(bytecnt ) , ! P3 &
loc(buffer$ ) ,,) ! P4
!
! once working properly, this little stub will never fire (but keep it around for future program changes)
!
if ((rc and 7%) <> 1) then ! if system call failed
print "-e-status:";rc;"during qio in dns lookup" !
junk% = sys$cantim(,) !
goto shutdown !
end if !
!
mask = get_ef_bit_vector(tcp_ef) ! insert vector 1 into mask
mask = mask or get_ef_bit_vector(tmr_ef) ! insert vector 2 into mask
!
! wait for a response from one of the two event flags
!
print "-i-waiting for one of two event flags" !
rc = sys$wflor( tcp_ef, mask) ! wait for a response from one of two flags
print "-e-sys$wflor rc: "+ str$(rc) if ((rc and 1%) <> 1) ! oops, didn't work
!
! which event flag is set? TCP or TIMER?
!
rc = sys$readEF(tcp_ef, junk%) ! test TCP event flag
select rc !
case SS$_WASCLR !
tcp_ef_state = 0 !
junk% = sys$cancel(dns_channel) !
print "-e-sys$cancel junk%: "+ str$(junk%) if ((junk% and 1%) <> 1)
case SS$_WASSET !
print "-i-tcp ef was set"
tcp_ef_state = 1 !
case else !
print "-e-sys$readef-tcp rc: "+ str$(rc) !
end select !
!
rc = sys$readEF(tmr_ef, junk%) ! test TIMER event flag
select rc !
case SS$_WASCLR !
tmr_ef_state = 0 !
junk% = sys$cantim(,) !
print "-e-sys$cantim junk%: "+ str$(junk%) if ((junk% and 1%) <> 1)
case SS$_WASSET !
print "-w-timer ef was set (oops)"
tmr_ef_state = 1 !
case else !
print "-e-sys$readef-timer rc: "+ str$(rc) !
end select !
!
if (tcp_ef_state = 1) then ! tcp fired so cancel timer
junk% = sys$cantim(,) !
end if !
!
if (tmr_ef_state = 1) then ! timer fired so cancel i/o
print "-e-DNS lookup timed out" !
junk% = sys$cancel(dns_channel) !
rc = 2 ! vms-e-
goto shutdown !
end if !
!
! At this point the qio has completed so test the operational status (iosb)
! Note: the iosb is not the same as what we normally see in VMS
! eg. status=2160 (EOF) could mean either one of:
! "not enough buffer space to store result"
! "dns lookup failed"
!
!~~~ print "-i-iosb-iosb$w_status:"; str$(iosb::iosb$w_status)
rc = iosb::iosb$w_status !
if ((rc and 7%) = 1) then !
if bytecnt = 0 then !
print "-w-no data returned" !
rc = 2 ! vms-error
else !
for i% = 1 to bytecnt ! remember: we are "little endian"
!~~~ print "-i-octet"+str$(i%)+": "; asc(mid$(buffer$,i%,1)) !
octets(i%-1) = asc(mid$(buffer$,i%,1)) ! xfer binary bytes
next i% !
end if !
else !
print "-e-rc:";rc !
print "-e-Failed to do the DNS lookup" !
end if !
!
! do not change rc after this point; use junk%
!
!-----------------------------------------------------------------------
! Shut down the socket (optional)
!-----------------------------------------------------------------------
shutdown: ! no point changing to async
junk% = sys$qiow( tcp_ef , ! &
dns_channel , ! &
(IO$_DEACCESS or IO$M_SHUTDOWN) , ! &
iosb::iosb$quad ,,,,,, ! &
TCPIP$C_DSC_ALL, ! P4 Discard all packets &
,) !
if ((junk% and 1%) <> 1) then !
print "-e-Failed to shut down the socket" !
end if !
!
! Close the sockets ( no point changing to async )
!
junk% = sys$qiow( tcp_ef , ! &
dns_channel , ! &
IO$_DEACCESS , ! &
iosb::iosb$quad , ! &
,,,,,,,) !
if ((junk% and 1%) <> 1) then !
print "-e-Failed to close the socket." !
end if !
!
! Deassign the TCPIP device channels
!
junk% = sys$dassgn(dns_channel) !
if ((junk% and 1%) <> 1) then !
print "-e-Failed to deassign the channel" !
end if !
!
goto rc_exit
!-----------------------------------------------------------------------
! cleanup (release event flags)
! caveat: rc must be preserved so use junk%
!-----------------------------------------------------------------------
cleanup:
if tcp_ef <> 0 then ! if allocated
junk% = lib$free_EF( tcp_ef ) ! deallocate an event flag
tcp_ef = 0 !
end if !
!
if tmr_ef <> 0 then ! if allocated
junk% = lib$free_EF( tmr_ef ) ! deallocate an event flag
tmr_ef = 0 !
end if !
return !
!
! rc must be set up before this point
!
rc_exit: !
gosub cleanup ! release event flags used here
my_gethostbyname = rc ! rc is returned to caller
print "-i- <<< exit my_gethostbyname() with status:";rc if debug > 0
end function !
!=======================================================================
! get timer bit vector
! (see OpenVMS system systevices documentation for "sys$wflor")
!
! notes: cluster event flags
! 0 00- 31 (local cluster)
! 1 32- 63 (local cluster)
! 2 64- 95 (common cluster)
! 3 96-127 (common cluster)
!=======================================================================
32060 function long get_ef_bit_vector(long event_flag) !
option type = explicit !
declare long temp !
!
select event_flag !
case <= 31 !
temp = event_flag !
case <= 63 !
temp = event_flag - 32 !
case <= 95 !
temp = event_flag - 64 !
case else !
temp = event_flag - 96 !
end select !
!
select temp ! avoiding an integer overflow
case 31 ! need to set bit #31
! 33222222222211111111110000000000
! 10987654321098765432109876543210
get_ef_bit_vector = B"10000000000000000000000000000000"L ! so return this
case else !
get_ef_bit_vector = (2% ^ temp) ! else return this
end select !
!
end function ! get_ef_bit_vector
!------------------------------------------------------------------------------------------------------------------------