OpenVMS Source Code Demos
TCPIP$TCP_CLIENT_QIO_2014D
1000 %title "tcpip$tcp_client_qio_2014d_xxx.bas"
%ident "105.1"
!========================================================================================================================
! title : tcpip$tcp_client_qio_2014d
! 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. The D client demo moves repetitive code to 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_2014d_103.bas
! link : $ link tcpip$tcp_client_qio_2014d_103
! history :
! ver who when what
! --- --- ------ --------------------------------------------------------------------------------------------------------
! 102 NSR 140814 0. started with TCPIP$TCP_CLIENT_QIO_2014C_102.BAS (inline code)
! 1. this version moves repetitive code to external functions (a template for future programs)
! NSR 140815 2. the SAGA continues...
! 103 NSR 140815 1. moved lots of common declaration to an external include
! 104 NSR 140816 1. renovated nsr_gethostbyname then renamed it nsr_dns_ghbn_bin
! 2. created second nsr_dns_ghbn_str
! 105 NSR 140817 1. collapsed nsr_dns_ghbn_bin and nsr_dns_ghbn_str into one function (what was I thinking?)
!========================================================================================================================
option type=explicit ! formal coding
set no prompt !
on error goto common_trap ! old school trapping for this demo
!
! 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)
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
external long function nsr_tcp_prep(long, any )
external long function nsr_tcp_open(long, any, long, word, string )
external long function nsr_tcp_send(long, any, any, long, string )
external long function nsr_tcp_recv(long, any, any, long, long, string )
external long function nsr_tcp_clos(long, any )
external long function nsr_tcp_free(long, any )
external long function nsr_dns_prep(long, any )
external long function nsr_dns_ghbn(long, string by desc, long, string by desc, long dim() by ref)
!
! declare variables
!
map(recv)string buffer_r = TCPBUFSIZ !
map(xmit)string buffer_w = TCPBUFSIZ !
!
declare quad junk64 !
declare string msg$ , &
dest$ , &
ip_address$ , &
path$ , &
long octet(3) , ! 0-3 &
ip_address , &
word tcp_port , &
long rc , &
bytes_w , &
readcount , &
bytes_r , &
bytes_r_total , &
http% , &
junk% , &
junk1 , &
junk2 , &
dest_kind , &
i% , &
debug , &
ncv_rec ncv ! network connection variables
!
!=======================================================================
! main
!=======================================================================
2000 main:
print
print "-i-this program will connect to a website on port "+ str$(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)
!
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%) = integer(seg$(dest$,junk1+1,junk2-1)) !
junk1 = junk2 ! reference pt moves along
next i% !
gosub octets_to_quad
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
debug = 1 !
!
! this is a type-1 dns lookup just to show how it is done (returns a string)
! note: we would still need to parse it for dots then build a 32-bit number
!
rc = nsr_dns_ghbn(debug, dest$, 0%, ip_address$,) ! mode 0 = return a string
if ((rc and 7%) <> 1) then !
print "-e-dns lookup-1 failed with status:";rc !
else !
print "-i-ip addr: ";ip_address$;" <<<---***" !
end if !
!
! this is a type-2 dns lookup (returns binary)
!
rc = nsr_dns_ghbn(debug, dest$, 1%,, octet()) ! mode 1 = return four octets
if ((rc and 7%) <> 1) then !
print "-e-dns lookup-2 failed with status:";rc !
goto get_dest !
end if !
gosub octets_to_quad
if junk64 = 0 then !
print "-e-error:";err;"during data conversion" !
goto get_dest !
end if !
end if !
sleep 1 !
!-----------------------------------------------------------------------
!
! create socket
!
debug = 1 !
rc = nsr_tcp_prep(debug, ncv ) ! allocate flags, allocate channel, etc.
goto rc_exit if (rc and 7%) <> 1 !
!
! connect
!
ip_address = qtol (junk64) !
tcp_port = SERV_PORTNUM !
rc = nsr_tcp_open(debug, ncv, ip_address, tcp_port,"0 00:00:10") ! connect with 10 second time limit
goto rc_exit if (rc and 7%) <> 1 !
!
!-----------------------------------------------------------------------
! 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.0 request:"
msg$ = "GET "+ path$ +" HTTP/1.0" + 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 = nsr_tcp_send(debug, ncv, buffer_w, bytes_w, "0 00:00:10") ! xmit with 10 second time limit
goto rc_exit if (rc and 7%) <> 1 !
!
!-----------------------------------------------------------------------
! 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 = nsr_tcp_recv(debug,ncv,buffer_r,TCPBUFSIZ,bytes_r,"0 00:00:00.9") ! receive with 900 mS time limit
if ((rc and 7%) <> 1) then !
select rc !
case SS$_THIRDPARTY ! (8316) -f- (third party stack libraries)
print "-w-status:";rc;"network partner disconnected logical link" if debug > 0
case SS$_LINKDISCON ! (8428) -f- (native libraries)
print "-w-status:";rc;"network partner disconnected logical link" if debug > 0
case SS$_VCCLOSED ! (8612) -w-
print "-w-status:";rc;"network partner closed" if debug > 0
case SS$_TIMEOUT ! ( 556) -f
print "-w-status:";rc;"operation timeout" if debug > 0
case else !
print "-e-error:";rc;"while reading from server" !
end select !
else !
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 we received something &
(readcount < 150) then ! and we're not too crazy
goto read_loop ! then read some more
end if !
end if !
!
! but we still may have received something so test bytes_r
!
print "-i-total bytes received:";bytes_r_total
!
rc = nsr_tcp_clos(debug, ncv ) ! close the tcp connection
goto rc_exit if (rc and 7%) <> 1 !
!
rc = nsr_tcp_free(debug, ncv ) ! release all allocated resources
goto rc_exit if (rc and 7%) <> 1 !
!
goto fini ! that's all she wrote...
!-----------------------------------------------------------------------
! octets to quad
!-----------------------------------------------------------------------
4050 octets_to_quad:
%let %convert_method=1
%if %convert_method=0 %then
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 !
%else
4051 declare stuffer32_rec stuffer32
4052 stuffer32::long_offset00 = octet(3)
4053 stuffer32::long_offset08 = octet(2)
4054 stuffer32::long_offset16 = octet(1)
4055 stuffer32::long_offset24 = octet(0)
4056 junk64 = stuffer32::long_offset00
%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-
rc_exit: !
!~~~ junk% = nsr_tcp_release
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(swapS0) word sw0_word0
map(swapS0) byte sw0_byte0 , &
byte sw0_byte1
!
map(swapS1) word sw1_word0
map(swapS1) 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(swapL0) long sw0_long0
map(swapL0) word sw0_word0 , &
word sw0_word1
map(swapL0) byte sw0_byte0 , &
byte sw0_byte1 , &
byte sw0_byte2 , &
byte sw0_byte3
!
map(swapL1) long sw1_long0
map(swapL1) word sw1_word0 , &
word sw1_word1
map(swapL1) 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(swapQ0) quad sw0_quad0
map(swapQ0) 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 Q->L 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 !
!
!=======================================================================
! 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)
!=======================================================================
32050 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
!
!=======================================================================
! nsr_tcp_prep()
!
! 1) allocate two event flags then store them in the passed ncv
! 2) allocate a channel then use it to connect to the stack
! 3) use $qio to set socket characteristics
!=======================================================================
32060 function long nsr_tcp_prep( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
declare long rc !
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i->>> enter function: nsr_tcp_prep()" if debug > 0 !
!
! allocate event flags (if not already allocated)
!
if ncv::tcp_ef = 0 then ! if not yet allocated
print "-i-allocating EF for tcp" if debug > 0 !
rc = lib$get_EF( ncv::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 ncv::tmr_ef = 0 then ! if not yet allocated
print "-i-allocating EF for timer" if debug > 0 !
rc = lib$get_EF( ncv::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 !
!
! create socket (part 1/2)
!
print "-i-creating socket (assign)" if debug > 0 !
rc = sys$assign("TCPIP$DEVICE:", ncv::vms_channel,,) !
if ((rc and 7%) <> 1) then !
print "-e-error:";rc;"while assigning channel to TCPIP device" !
goto rc_exit !
end if !
!
! create socket (part 2/2)
!
ncv::cscb::sc$w_prot = TCPIP$C_TCP ! init (local) connection socket
ncv::cscb::sc$b_type = TCPIP$C_STREAM !
ncv::cscb::sc$b_af = TCPIP$C_AF_INET !
!
print "-i-creating socket (qiow)" if debug > 0 ! synchronous (no point changing to async)
rc = sys$qiow( &
EFN$C_ENF, ! event flag &
ncv::vms_channel, ! i/o channel &
IO$_SETMODE, ! i/o function code &
ncv::iosb::iosb$bqw_quad,,, ! i/o status block &
ncv::cscb,,,,,) ! p1 - socket characteristics
if ((rc and 7%) = 1) then ! if the system call queued properly
rc = ncv::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 !
!
rc_exit: !
nsr_tcp_prep = rc !
print "-i-<<< exit function: nsr_tcp_prep() with status:";rc if debug > 0
end function !
!
!=======================================================================
! nsr_tcp_open (eg. connect to the desired destination)
!=======================================================================
32070 function long nsr_tcp_open( long debug , &
ncv_rec ncv , &
long ip_address , &
word tcp_port , &
string time_limit$)
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
declare long rc , &
junk% , &
basic$QuadWord DeltaQuad
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i->>> enter function: nsr_tcp_open()" if debug > 0 !
!
!
rc = sys$bintim(time_limit$, 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:";ncv::tmr_ef if debug > 0
rc = sys$setimr(ncv::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
!
ncv::ip_address = ip_address ! --+-- probably not required or necessary
ncv::tcp_port = tcp_port ! --+
!
ncv::serv_addr::SIN$W_FAMILY = TCPIP$C_AF_INET ! data fill remote connection socket
ncv::serv_addr::SIN$W_PORT = htons(tcp_port) !
ncv::serv_addr::SIN$L_ADDR = htonl (ip_address) ! eg. 142.180.221.226
!
ncv::serv_itemlst::il2$w_length = SIN$K_LENGTH ! need size of serv_addr (SOCKADDRIN)
ncv::serv_itemlst::il2$w_type = TCPIP$C_SOCK_NAME !
ncv::serv_itemlst::il2$l_address = loc(ncv::serv_addr) ! need addr of serv_addr
!
print "-i-connecting to server via qio associated with ef:";ncv::tcp_ef if debug > 0
rc = sys$qio( ! async (no wait) &
ncv::tcp_ef, ! event flag &
ncv::vms_channel, ! i/o channel &
IO$_ACCESS, ! i/o function code &
ncv::iosb::iosb$bqw_quad,,,,, ! i/o status block &
loc(ncv::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
!
ncv::mask = get_ef_bit_vector(ncv::tcp_ef) ! insert vector 1 into mask
ncv::mask = ncv::mask or get_ef_bit_vector(ncv::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" if debug > 0
rc = sys$wflor( ncv::tcp_ef, ncv::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(ncv::tcp_ef, junk%) ! test TCP event flag
select rc !
case SS$_WASCLR !
ncv::tcp_ef_state = 0 !
case SS$_WASSET !
print "-i-tcp ef was set" if debug > 0 !
ncv::tcp_ef_state = 1 !
case else !
print "-e-sys$readef-tcp rc: "+ str$(rc) !
end select !
!
rc = sys$readEF(ncv::tmr_ef, junk%) ! test TIMER event flag
select rc !
case SS$_WASCLR !
ncv::tmr_ef_state = 0 !
case SS$_WASSET !
print "-w-timer ef was set (oops)" if debug > 0 !
ncv::tmr_ef_state = 1 !
case else !
print "-e-sys$readef-timer rc: "+ str$(rc) !
end select !
!
if (ncv::tcp_ef_state = 1) then ! tcp fired so cancel timer
junk% = sys$cantim(,) !
end if !
!
if (ncv::tmr_ef_state = 1) then ! timer fired so cancel i/o
print "-e-did not connect in time" if debug > 0 !
junk% = sys$cancel(ncv::vms_channel) !
rc = 2 ! vms-e-
goto rc_exit !
end if !
!
! At this point the qio has completed. so test operational status (iosb)
!
rc = ncv::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" if debug > 0 !
end if !
!
rc_exit: !
nsr_tcp_open = rc !
print "-i-<<< exit function: nsr_tcp_open() with status:";rc if debug > 0
end function !
!=======================================================================
! nsr_tcp_send
!=======================================================================
32080 function long nsr_tcp_send( long debug , &
ncv_rec ncv , &
string buffer_w , &
long bytes_w , &
string time_limit$)
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
declare long rc , &
junk% , &
basic$QuadWord DeltaQuad
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i->>> enter function: nsr_tcp_send()" if debug > 0 !
!
rc = sys$bintim(time_limit$, 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:";ncv::tmr_ef if debug > 0
rc = sys$setimr(ncv::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-queuing i/o write associated with ef:";ncv::tcp_ef if debug > 0
rc = sys$qio( &
ncv::tcp_ef, ! event flag &
ncv::vms_channel, ! i/o channel &
IO$_WRITEVBLK, ! i/o function code &
ncv::iosb::iosb$bqw_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 !
!
! 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
!
ncv::mask = get_ef_bit_vector(ncv::tcp_ef) ! insert vector 1 into mask
ncv::mask = ncv::mask or get_ef_bit_vector(ncv::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" if debug > 0
rc = sys$wflor( ncv::tcp_ef, ncv::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(ncv::tcp_ef, junk%) ! test TCP event flag
select rc !
case SS$_WASCLR !
ncv::tcp_ef_state = 0 !
case SS$_WASSET !
print "-i-tcp ef was set" if debug > 0 !
ncv::tcp_ef_state = 1 !
case else !
print "-e-sys$readef-tcp rc: "+ str$(rc) !
end select !
!
rc = sys$readEF(ncv::tmr_ef, junk%) ! test TIMER event flag
select rc !
case SS$_WASCLR !
ncv::tmr_ef_state = 0 !
case SS$_WASSET !
print "-w-timer ef was set (oops)" if debug > 0 !
ncv::tmr_ef_state = 1 !
case else !
print "-e-sys$readef-timer rc: "+ str$(rc) !
end select !
!
if (ncv::tcp_ef_state = 1) then ! tcp fired so cancel timer
junk% = sys$cantim(,) !
end if !
!
if (ncv::tmr_ef_state = 1) then ! timer fired so cancel i/o
print "-e-did not connect in time" if debug > 0 !
junk% = sys$cancel(ncv::vms_channel) !
rc = 2 ! vms-e-
goto rc_exit !
end if !
!
! At this point the qio has completed. so test operational status (iosb)
!
rc = ncv::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 !
!
rc_exit: !
nsr_tcp_send = rc !
print "-i-<<< exit function: nsr_tcp_send() with status:";rc if debug > 0
end function !
!=======================================================================
! nsr_tcp_recv
!=======================================================================
32090 function long nsr_tcp_recv( long debug , &
ncv_rec ncv , &
string buffer_r , &
long max_recv_size , &
long bytes_r , &
string time_limit$)
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
declare long rc , &
junk% , &
basic$QuadWord DeltaQuad
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i->>> enter function: nsr_tcp_recv()" if debug > 0 !
bytes_r = 0 ! init
!
rc = sys$bintim(time_limit$, 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:";ncv::tmr_ef if debug > 0
rc = sys$setimr(ncv::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-queuing i/o read associated with ef:";ncv::tcp_ef if debug > 0
rc = sys$qio( &
ncv::tcp_ef, ! event flag &
ncv::vms_channel, ! i/o channel &
IO$_READVBLK, ! i/o function code &
ncv::iosb::iosb$bqw_quad,,, ! i/o status block &
buffer_r, ! p1 buffer address &
max_recv_size,,,,) ! p2 buffer length (max space)
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 !
!
! 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
!
ncv::mask = get_ef_bit_vector(ncv::tcp_ef) ! insert vector 1 into mask
ncv::mask = ncv::mask or get_ef_bit_vector(ncv::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" if debug > 0
rc = sys$wflor( ncv::tcp_ef, ncv::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(ncv::tcp_ef, junk%) ! test TCP event flag
select rc !
case SS$_WASCLR !
ncv::tcp_ef_state = 0 !
case SS$_WASSET !
print "-i-tcp ef was set" if debug > 0 !
ncv::tcp_ef_state = 1 !
case else !
print "-e-sys$readef-tcp rc: "+ str$(rc) !
end select !
!
rc = sys$readEF(ncv::tmr_ef, junk%) ! test TIMER event flag
select rc !
case SS$_WASCLR !
ncv::tmr_ef_state = 0 !
case SS$_WASSET !
print "-w-timer ef was set (oops)" if debug > 0 !
ncv::tmr_ef_state = 1 !
case else !
print "-e-sys$readef-timer rc: "+ str$(rc) !
end select !
!
if (ncv::tcp_ef_state = 1) then ! tcp fired so cancel timer
junk% = sys$cantim(,) !
end if !
!
if (ncv::tmr_ef_state = 1) then ! timer fired so cancel i/o
print "-e-did not connect in time" if debug > 0 !
junk% = sys$cancel(ncv::vms_channel) !
rc = 2 ! vms-e-
goto rc_exit !
end if !
!
! At this point the qio has completed so test operational status (iosb)
!
rc = ncv::iosb::iosb$w_status ! test the operational status
if ((rc and 7%) = 1) then !
print "-i-received:";ncv::iosb::iosb$w_bcnt;"characters" !
bytes_r = ncv::iosb::iosb$w_bcnt !
else ! oops
bytes_r = 0 ! first off, signal crud data in buffer
select rc !
case SS$_THIRDPARTY ! (8316) -f- (third party stack libraries)
print "-w-status:";rc;"network partner disconnected logical link"
case SS$_LINKDISCON ! (8428) -f- (native libraries)
print "-w-status:";rc;"network partner disconnected logical link"
case SS$_VCCLOSED ! (8612) -w-
print "-w-status:";rc;"network partner closed" !
case SS$_TIMEOUT ! ( 556) -f
print "-w-status:";rc;"timeout" !
case else !
print "-e-error:";rc;"while reading from server" !
end select !
end if !
!
rc_exit: !
nsr_tcp_recv = rc !
print "-i-<<< exit function: nsr_tcp_recv() with status:";rc if debug > 0
end function !
!=======================================================================
! nsr_tcp_clos()
!=======================================================================
32100 function long nsr_tcp_clos( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
declare long rc !
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i->>> enter function: nsr_tcp_clos()" if debug > 0 !
!
! socket shutdown (really means "drop internet connection")
!
print "-i-shutting down the socket (connection close)" ! no point changing to async
rc = sys$qiow( &
EFN$C_ENF, ! event flag &
ncv::vms_channel, ! i/o channel &
IO$_DEACCESS or IO$M_SHUTDOWN, ! i/o function code &
ncv::iosb::iosb$bqw_quad,,,,,, ! i/o status block &
TCPIP$C_DSC_ALL,,) ! p5
if ((rc and 7%) <> 1) then !
print "-e-error:";rc;"during socket shutdown(1)" !
else !
rc = ncv::iosb::iosb$w_status ! check the operational result
if ((rc and 7%) <> 1) then !
print "-w-error:";rc;"during socket shutdown(2)" !
end if !
end if !
!
rc_exit: !
nsr_tcp_clos = rc !
print "-i-<<< exit function: nsr_tcp_clos() with status:";rc if debug > 0
end function !
!=======================================================================
! nsr_tcp_free()
!=======================================================================
32110 function long nsr_tcp_free( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
declare long rc, junk% !
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i->>> enter function: nsr_tcp_free()" if debug > 0 !
!
%let %paranoid=0 ! disabled
%if %paranoid=1 %then !
!
! close the socket (this is a paranoid close so write to junk%)
!
print "-i-closing the socket" ! no point changing to async
junk% = sys$qiow( &
EFN$C_ENF, ! event flag &
ncv::vms_channel, ! i/o channel &
IO$_DEACCESS, ! i/o function code &
ncv::iosb::iosb$bqw_quad, ! i/o status block &
,,,,,,,) !
if ((junk% and 7%) <> 1) then !
print "-e-error:";junk%;"during socket shutdown(1)" !
else !
junk% = ncv::iosb::iosb$w_status ! check the operational result
if ((junk% and 7%) <> 1) then !
print "-w-error:";junk%;"during socket shutdown(2)" !
end if !
end if !
%end %if !
!
! deassign the socket
!
rc = sys$dassgn(ncv::vms_channel) !
if ((rc and 7%) <> 1) then !
print "-e-error:";rc;"during deassign" !
end if !
!
! release allocated event flags
!
if ncv::tcp_ef <> 0 then ! if allocated
junk% = lib$free_EF( ncv::tcp_ef ) ! deallocate an event flag
ncv::tcp_ef = 0 ! mark it released
end if !
!
if ncv::tmr_ef <> 0 then ! if allocated
junk% = lib$free_EF( ncv::tmr_ef ) ! deallocate an event flag
ncv::tmr_ef = 0 ! mark it released
end if !
!
rc_exit: !
nsr_tcp_free = rc !
print "-i-<<< exit function: nsr_tcp_free() with status:";rc if debug > 0
end function !
!
!=======================================================================
! nsr_dns_prep()
!
! 1) allocate two event flags then store them in the passed ncv
! 2) allocate a channel then use it to connect to the stack
!=======================================================================
32120 function long nsr_dns_prep( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
declare long rc !
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i->>> enter function: nsr_dns_prep()" if debug > 0 !
!
! allocate event flags (if not already allocated)
!
if ncv::tcp_ef = 0 then ! if not yet allocated
print "-i-allocating EF for tcp" if debug > 0 !
rc = lib$get_EF( ncv::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 ncv::tmr_ef = 0 then ! if not yet allocated
print "-i-allocating EF for timer" if debug > 0 !
rc = lib$get_EF( ncv::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 !
!
! open channel to stack (we don't go to the net, the resolver does)
!
print "-i-opening channel to the stack (assign)" if debug > 0 !
rc = sys$assign("TCPIP$DEVICE:", ncv::vms_channel,,) !
if ((rc and 7%) <> 1) then !
print "-e-error:";rc;"while assigning channel to TCPIP device" !
goto rc_exit !
end if !
!
rc_exit: !
nsr_dns_prep = rc !
print "-i-<<< exit function: nsr_dns_prep() with status:";rc if debug > 0
end function !
!=======================================================================
! <<< nsr 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
! entry : dns_name$ : desired fully qualified domain name
! output_mode : 0 = string, 1 = array of longs
! exit : octets array : filled with 4 entries
!=======================================================================
32130 function long nsr_dns_ghbn(long debug, string dns_name$, long output_mode, string ip_address$, long octets() by ref)
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014D_105.INC" !
!
external long function nsr_dns_prep(long, any )
external long function nsr_tcp_clos(long, any )
external long function nsr_tcp_free(long, any )
!
! <<< variable declarations >>>
!
declare long rc , ! return code &
junk% , ! &
ptr% , ! &
i% , ! &
j% , ! &
timeout_count% , ! &
basic$QuadWord DeltaQuad , ! &
word bytecnt , ! &
long command , ! INET command &
HostEntDef myHostEnt , ! see: sys$library:tcpip$inetdef.bas &
NetEntDef myNetEnt , ! see: sys$library:tcpip$inetdef.bas &
string buffer$ , ! &
junk$ , ! &
ncv_rec ncv ! nsr connection variables
!-----------------------------------------------------------------------
! function main
!-----------------------------------------------------------------------
main: !
print "-i->>> enter function: nsr_dns_ghbn()" if debug > 0 !
!
rc = nsr_dns_prep(debug, ncv) ! get event flags; connect to stack
if ((rc and 7%) <> 1) then !
print "-e-nsr_dns_prep rc: ";str$(rc) !
goto rc_exit !
end if !
!
command = inetacp_func$c_gethostbyname ! function: gethostbyname
if output_mode <> 0 then ! if array of longs
command = command or (inetacp$c_trans * 256%) ! sub-func: binary address
end if !
!
! we need a "long descriptor" to use io$_acpcontrol to call sys$qio
! (I wonder which bozo 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 a long integer
!
! pre-extend the buffer to accomodate the expected data
! note: IPv6 is coming soon so start thinking about it now)
!
if output_mode = 0 then ! string
!
! 142.180.221.226 (32-bits in octal)
!
!~~~ buffer$ = space$((4*3)+3) x space for 15 characters (IPv4)
!
! abcd:abcd:abcd:abcd:abcd:abcd:abcd:abcd (128-bits in hex)
!
buffer$ = space$((8*4)+7) ! space for 39 characters (IPv6)
!
else ! array of longs
!~~~ buffer$ = space$( 32/ 8) x space for 4 octal bytes (IPv4)
buffer$ = space$(128/ 8) ! space for 16 hex bytes (IPv6)
end if !
!
!-----------------------------------------------------------------------
! perform a 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:";ncv::tmr_ef if debug > 0 !
rc = sys$setimr(ncv::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
!
! note: here, we are not going out on the internet. We are calling io$_acpcontrol to request a
! connection to the BIND resolver (which may go to the internet after checking the local HOST file
! and recent caches)
!
print "-i-queuing dns lookup associated with ef:";ncv::tcp_ef if debug > 0
rc = sys$qio( ! sync (wait) &
ncv::tcp_ef , ! Event flag &
ncv::vms_channel , ! Channel number &
io$_acpcontrol , ! I/O function &
ncv::iosb::iosb$bqw_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 !
!
ncv::mask = get_ef_bit_vector(ncv::tcp_ef) ! insert vector 1 into mask
ncv::mask = ncv::mask or get_ef_bit_vector(ncv::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" if debug > 0
rc = sys$wflor( ncv::tcp_ef, ncv::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(ncv::tcp_ef, junk%) ! test TCP event flag
select rc !
case SS$_WASCLR !
ncv::tcp_ef_state = 0 !
junk% = sys$cancel(ncv::vms_channel) !
print "-e-sys$cancel junk%: "+ str$(junk%) if ((junk% and 1%) <> 1)
case SS$_WASSET !
print "-i-tcp ef was set (good)" if debug > 0 !
ncv::tcp_ef_state = 1 !
case else !
print "-e-sys$readef-tcp rc: "+ str$(rc) !
end select !
!
rc = sys$readEF(ncv::tmr_ef, junk%) ! test TIMER event flag
select rc !
case SS$_WASCLR !
ncv::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)" if debug > 0
ncv::tmr_ef_state = 1 !
case else !
print "-e-sys$readef-timer rc: "+ str$(rc) !
end select !
!
if (ncv::tcp_ef_state = 1) then ! tcp fired so cancel timer
junk% = sys$cantim(,) !
end if !
!
if (ncv::tmr_ef_state = 1) then ! timer fired so cancel i/o
print "-e-DNS lookup timed out" !
junk% = sys$cancel(ncv::vms_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"
!
rc = ncv::iosb::iosb$w_status !
!~~~ print "-i-iosb-iosb$w_status:"; str$(rc)
if ((rc and 7%) = 1) then !
if bytecnt = 0 then !
print "-w-no DNS data returned" !
rc = 2 ! vms-error
else !
if output_mode = 0 then ! string
ip_address$ = left$(buffer$,bytecnt) !
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 !
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%
!
shutdown: !
cleanup: !
junk% = nsr_tcp_free(debug,ncv) !
if ((junk% and 1%) <> 1) then !
print "-e-nsr_tcp_free rc:";rc !
end if !
!
! rc must be set up before this point
!
rc_exit: !
nsr_dns_ghbn = rc ! rc is returned to caller
print "-i-<<< exit nsr_dns_ghbn() with status:";rc if debug > 0 !
end function !
!=======================================================================