OpenVMS Source Code Demos
wcsm_tcp_functions_109
!========================================================================================================================
! title : [.fun]WCSM_TCP_FUNCTIONS_109.fun
! author : Neil Rieck
! created : 2014-08-04
! notes : 1) BASIC will not allow you to %include a file containing line numbers so...
! : 2) this file should be broken up into separte files (one per function) or...
! : 3) this whole file can be compiled without line numbers then linked to the source
! history :
! ver who when what
! --- --- ------ --------------------------------------------------------------------------------------------------------
! 108 NSR 140905 1. original file (derived from the bottom of: TCPIP$TCP_CLIENT_QIO_2014F_107.BAS)
! 109 NSR 140930 1. started work on an alternate dns routine called nsr_dns_ghnt
! 2. now include [.inc]WCSM_TCP_SUPPORT_109.INC
! NSR 150109 3. bug fix in nsr_dns_ghbn (forgot to invoke qtol) bf_109.3
! NSR 150710 4. now include [.inc]wcsm_tcp_nvt_definitions_108.INC (109 is missing during Itanium conversion)
! NSR 150923 5. socket shutdown after dns lookup was optional with TCPware but appears to be superfluous with
! "TCPIP Services" (in fact, it always exits with error 20); I'll keep paranoid enabled until I
! can test with MultiNet but you will only see the error message if debug is enabled bf_109.5
!========================================================================================================================
!
! external functions for our BASIC programs
!
!=======================================================================================
! <<< nsr_adr_prep >>>
!
! dest$ path$ kind function
! 1 input: "142.180.221.226"
! exit: "142.180.221.226" "" 1 (numeric) ip address
! 2 input: "www3.sympatico.ca"
! exit: "www3.sympatico.ca" "" 2 (dns) ip address
! 3 input: "142.180.221.226/n.rieck/"
! exit: "142.180.221.226" "/n.rieck/" 1 (numeric) ip address
! 4 input: "www3.sympatico.ca/n.rieck/"
! exit: "www3.sympatico.ca" "/n.rieck/" 2 (dns) ip address
! 5 input: "junk"
! exit: "junk" "" 0 (crud) 0
! 6 input: "www.nonexistant.com"
! exit: "www.nonexistant.com" "" 0 (crud) 0
! notes:
! 1) input kind limits http (numeric=http/1.0; dns=http/1.1)
! 2) path is only used with port 80 (http) but not port 23 (telnet)
! 3) should only attempt to connect if the address <> 0
! 4) do not change dest$ unless you are removing a path
!=======================================================================================
function long nsr_adr_prep(long debug, string dest$, string path$, long kind)
option type=explicit !
!
%include "[.inc]WCSM_TCP_SUPPORT_109.INC" !
!
external long function nsr_dns_ghbn(long, string, long, string, long dim() by ref, string)
external quad function octets_to_quad(long dim() by ref) !
external long function qtol(quad) !
!
declare quad junk64 , &
long dots , &
nums , &
alph , &
othe , &
slash_pos , &
i% , &
rc , &
junk1 , &
junk2 , &
addr , &
long octet(3) , ! 0-3 &
string ip_address$ ! only used in type-1 dns lookup
!-----------------------------------------------------------------------
main:
kind = 0 ! init(s)
addr = 0 !
!
slash_pos = pos(dest$, "/", 1) ! any slashes here?
if slash_pos > 0 then ! yes
path$ = right$(dest$,slash_pos) ! do this before changing dest$
dest$ = left$( dest$,slash_pos - 1) ! repair dest$
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
kind = 1 ! input=NUMERIC
junk1 = 0 ! init for octet scan
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)) !
select octet(i%) !
case 0 to 255 !
case else !
print "-e-error, the value of octet:";i%;"is";octet(i%);"which is not in the range of 0-255"
goto data_unusable !
end select !
junk1 = junk2 ! reference pt. moves along
next i% !
junk64 = octets_to_quad(octet()) !
if junk64 = 0 then !
print "-e-error during octets-to-quad conversion" !
goto data_unusable !
end if !
addr = qtol(junk64) !
if addr = 0 then !
print "-e-error during quad-to-long conversion" !
end if !
goto function_exit !
end if !
!
! eg. "bell.ca" or "www3.sympatico.ca"
!
if dots>0 and alph>=2 then ! hey, might be a dns
kind = 2 ! INPUT=dns
!
! this is a type-1 dns lookup (returns string)
!
!~~~ rc = nsr_dns_ghbn(debug,dest$,0%,ip_address$,,"0 0:0:05.0") x mode 0 = return string
!
! this is a type-2 dns lookup (returns binary)
!
rc = nsr_dns_ghbn(debug,dest$,1%,,octet(),"0 0:0:05.0") ! mode 1 = return four octets
if ((rc and 7%) <> 1) then !
print "-e-dns lookup-2 failed with status:";rc !
goto data_unusable !
end if !
junk64 = octets_to_quad( octet() ) !
if junk64 = 0 then !
print "-e-error:";err;"during data conversion" !
goto data_unusable !
end if !
addr = qtol(junk64) ! bf_109.3
if addr = 0 then !
print "-e-error during quad-to-long conversion" !
end if !
goto function_exit !
end if !
!
data_unusable:
kind = 0 !
addr = 0 !
!
function_exit: !
nsr_adr_prep = addr !
end function !
!
!=======================================================================
! 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
!=======================================================================
function long nsr_tcp_prep(long debug,ncv_rec ncv by ref )
option type=explicit ! formal declarations required
!
%include "[.inc]WCSM_TCP_SUPPORT_109.INC" !
!
declare long rc !
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i-enter function: nsr_tcp_prep() >>>>>" if debug > 0 !
!
ncv::nvt_cycle = 0 ! init
ncv::nvt_total_msgs_received = 0 !
ncv::nvt_total_bytes_sent = 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 !
else !
print "-i-channel:";ncv::vms_channel if debug > 0 !
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)
!=======================================================================
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 "[.inc]WCSM_TCP_SUPPORT_109.INC" !
!
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 get_ef_bit_vector(long) ! required for used with SYS$WFLOR
!
declare long rc , &
junk% , &
basic$QuadWord DeltaQuad
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i-enter function: nsr_tcp_open() >>>>>" if debug > 0 !
!
ncv::nvt_cycle = 0 ! init (perhaps this is a reopen?)
ncv::nvt_total_msgs_received = 0 !
ncv::nvt_total_bytes_sent = 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 open in time" if debug > 0 !
print "-e-did not open in time" !
junk% = sys$cancel(ncv::vms_channel) !
rc = SS$_TIMEOUT ! 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
!=======================================================================
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 "[.inc]WCSM_TCP_SUPPORT_109.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
print "-i-will send: ";left$(buffer_w,bytes_w) if debug > 1
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 send 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" if debug > 0 !
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
!=======================================================================
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 "[.inc]WCSM_TCP_SUPPORT_109.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 recv in time" if debug > 0 !
junk% = sys$cancel(ncv::vms_channel) !
!~~~ rc = SS$_TIMEOUT x vms-e-
rc = 1 ! vms-s-
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" if debug > 0
bytes_r = ncv::iosb::iosb$w_bcnt !
print "-i-recv data: ";left$(buffer_r,bytes_r) if debug > 1
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()
!=======================================================================
function long nsr_tcp_clos( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "[.inc]WCSM_TCP_SUPPORT_109.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)" if debug > 0 ! 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()
!
! this is also used to do a blind reset so errors are flagged as warnings
! always returns 1
!=======================================================================
function long nsr_tcp_free( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "[.inc]WCSM_TCP_SUPPORT_109.INC" !
!
declare long rc, junk% !
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i-enter function: nsr_tcp_free() >>>>>" if debug > 0 !
!
%let %paranoid=1 ! enabled
%if %paranoid=1 %then !
!
! close the socket (this is a paranoid close so write to junk%)
!
print "-i-closing the socket (paranoid)" if debug > 0 ! 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 "-w-error:";junk%;"during paranoid socket shutdown(1)" if debug > 0 ! bf_109.5
else !
junk% = ncv::iosb::iosb$w_status ! check the operational result
if ((junk% and 7%) <> 1) then !
print "-w-error:";junk%;"during paranoid socket shutdown(2)" if debug > 0 ! bf_109.5
end if !
end if !
%end %if !
!
! deassign the socket
!
rc = sys$dassgn(ncv::vms_channel) !
if ((rc and 7%) <> 1) then !
print "-w-error:";rc;"during paranoid deassign" !
ncv::vms_channel = 0 !
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 x
nsr_tcp_free = 1 ! always exit with VMS-S
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
!=======================================================================
function long nsr_dns_prep( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "[.inc]WCSM_TCP_SUPPORT_109.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
!=======================================================================
function long nsr_dns_ghbn( long debug, &
string dns_name$, &
long output_mode, &
string ip_address$, &
long octets() by ref, &
string time_limit$ )
option type=explicit ! formal declarations required
!
%include "[.inc]WCSM_TCP_SUPPORT_109.INC" !
!
external long function nsr_dns_prep(long, ncv_rec )
external long function nsr_tcp_clos(long, ncv_rec )
external long function nsr_tcp_free(long, ncv_rec )
!
! <<< 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
!-----------------------------------------------------------------------
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
!
! 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 entries in the BIND cache)
!
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 function: nsr_dns_ghbn() with status:";rc;"<<<<<" if debug > 0
end function !
!
!=======================================================================
! nsr_nvt_scan
!=======================================================================
! notes (one):
! 1) telent sessions begin with a NVT handshake (see: rfc-854 to rfc-859)
! 2) test for NVT chracter IAC (Interpet As Command)
! 3) the next character will be one of WILL WONT DO DONT (or SB)
! 4) if receiving WILL (offering) then reply with DO (yes) or DONT (no)
! 5) if receiving DO (requesting) then reply with WILL (yes) or WONT (no)
! 6) you must agree to support DO TERM_TYPE to connect to Solaris
! 7) then next msg might be: IAC SB TT x01 IAC SE (where: x01 = SEND)
! 8) you reply with somthing like: IAC SB TT x00 VT100 IAC SE (where: x00 = IS)
! 9) a quick scan of the RFCs indicates "WONT must be acked with DONT" and "DONT must be acked with WONT"
! but check out this a weird condition after connecting to Solaris-8 on port 23:
! a) solaris sends DO whatever
! b) we reply with WONT whatever
! c) solaris acks with DONT whatever (note that OpenVMS stacks don't do this)
! d) should we re-respond with WONT whatever ? (beginning a potential handshake storm?)
! We could write some elaborate code to deal with this -OR- assume that the RFCs are wrong about acking WONT + DONT
!
function long nsr_nvt_scan( long debug , ! common use &
ncv_rec ncv , ! common use &
string buffer_w , ! used if we send &
long bytes_w , ! '' &
string time_limit$ , ! '' &
string buffer_r , ! used for scan &
long bytes_r , ! '' &
long nvt_msgs ! use for exit &
)
option type=explicit ! formal declarations required
!
%include "[.inc]WCSM_TCP_SUPPORT_109.INC" !
%include "[.inc]wcsm_tcp_nvt_definitions_108.INC" ! IAC, WILL, WONT, DO, DONT
%let %ack_wont_dont = 0 ! disabled. (see note-9 above) bf_106.4
!
external long function nsr_tcp_send(long, ncv_rec, string, long, string )
!
declare long rc , &
junk% , &
i , &
j , &
string q , &
r , &
s , &
buf$ , &
out$ , &
basic$QuadWord DeltaQuad !
!-----------------------------------------------------------------------
! main (of function)
!-----------------------------------------------------------------------
print "-i-enter function: nsr_nvt_scan() >>>>>" if debug > 0 !
nvt_msgs = 0 ! always zap this
!
if ncv::tcp_port <> 23 then ! if not telnet
print "-w-nvt scan only allowed on port 23" if debug > 0 !
rc = 1 ! VMS-s-
goto rc_exit ! then exit now
end if !
!
if bytes_r = 0 then ! if no data
rc = 1 ! VMS-s- (just quietly exit)
goto rc_exit !
end if !
!-----------------------------------------------------------------------
!
! scan the buffer_r looking for NVT sequeneces (see: rfc-854)
! 1) IAC IAC becomes one IAC (copy it to buf$)
! 2) IAC WILL ECHO process NVT (do not copy to buf$)
! 3) IAC SB .. .. .. IAC SE process NVT (do not copy to buf$)
! 4) all else copy to buf$
!
for i = 1 to bytes_r ! scan
q = mid$(buffer_r,i,1) ! extract
select asc(q) ! convert to ascii
case kIAC ! I/nterpret A/s C/ommand
r = mid$(buffer_r, i+1, 1) ! verb (eg. DO)
s = mid$(buffer_r, i+2, 1) ! noun (eg. TERM_TYPE)
select asc(r) !
case kWILL ! server offers to ...
print "-i-NVT recv: WILL";asc(s) if debug > 0 !
i = i + 2 ! advance pointer by two
select asc(s) !
case kSGA ! server wants to supress go-ahead
out$ = out$ + chr$(kIAC) + chr$(kDO ) + s ! ack his offer with DO
! will_do_sga = 1 x for future book-keeping
case kECHO !
out$ = out$ + chr$(kIAC) + chr$(kDO ) + s ! ack his offer with DO
case else !
out$ = out$ + chr$(kIAC) + chr$(kDONT) + s ! do let him do anything else
end select !
nvt_msgs = nvt_msgs + 1 ! show us processing a message
case kDO ! server requests ...
print "-i-NVT recv: DO";asc(s) if debug > 0 !
i = i + 2 !
select asc(s) !
case kSGA !
out$ = out$ + chr$(kIAC) + chr$(kWILL) + s !
! do_will_sga = 1 x for future book-keeping
case kTERM_TYPE !
out$ = out$ + chr$(kIAC) + chr$(kWILL) + s !
case else !
out$ = out$ + chr$(kIAC) + chr$(kWONT) + s !
end select !
nvt_msgs = nvt_msgs + 1 !
case kWONT !
print "-i-NVT recv: WONT";asc(s) if debug > 0 !
i = i + 2 !
%if %ack_wont_dont = 0 %then !
print "-i-NVT skip: not sending DONT";asc(s) if debug > 0
%else
out$ = out$ + chr$(kIAC) + chr$(kDONT) + s ! ack WONT with DONT
%end %if
nvt_msgs = nvt_msgs + 1 !
case kDONT !
print "-i-NVT recv: DONT";asc(s) if debug > 0 !
i = i + 2 !
%if %ack_wont_dont = 0 %then !
print "-i-NVT skip: not sending DONT";asc(s) if debug > 0
%else
out$ = out$ + chr$(kIAC) + chr$(kWONT) + s ! ack the DONT with WONT
%end %if
nvt_msgs = nvt_msgs + 1 !
case kSB ! yep, SUB command
print "-i-NVT recv: SbCmd";asc(s) !
junk% = pos(buffer_r,chr$(kSE),i) ! locate end-of-sequence
if (junk% = 0 ) or ! if not found &
(junk% > bytes_r) then ! or junk in buffer
print "-e-oops, could not find NVT-IAC-SE" !
buf$ = buf$ + q ! just copy
else !
select asc(s) !
case kTERM_TYPE !
out$ = out$ + chr$(kIAC) + chr$(kSB) + &
chr$(kTERM_TYPE) + &
chr$(kIS) + "VT100" + &
chr$(kIAC) + chr$(kSE) !
i = junk% ! bigger jump
case else !
print "-w-not responding to unsupported verb:";asc(s)
buf$ = buf$ + q !
end select !
end if !
nvt_msgs = nvt_msgs + 1 !
case kIAC ! two IACs means one escapes the next
print "-i-NVT recv: two IAC" if debug > 0 ! (should be very rare)
buf$ = buf$ + q ! so tack one onto the temp buffer
i = i + 1 ! advance pointer by one
nvt_msgs = nvt_msgs + 1 !
case kGA ! GA is only used in half-duplex (plus,
print "-i-NVT recv: GA (discarded)" if debug > 0 ! we should have supressed it)
i = i + 1 ! advance pointer by one
nvt_msgs = nvt_msgs + 1 !
case kNOP ! No operation
print "-i-NVT recv: NOP (discarded)" if debug > 0 !
i = i + 1 ! advance pointer by one
nvt_msgs = nvt_msgs + 1 !
case else !
print "-i-NVT-recv-??";asc(r);" ";asc(s) ! this should never happen
end select !
case else !
buf$ = buf$ + q ! just copy
end select !
next i !
!
! perform a little bookeeping
!
if nvt_msgs > 0 then !
ncv::nvt_cycle = ncv::nvt_cycle + 1 !
ncv::nvt_total_msgs_received = ncv::nvt_total_msgs_received + nvt_msgs
ncv::nvt_total_bytes_sent = ncv::nvt_total_bytes_sent + len(out$) !
end if !
!
if out$ <> "" then ! if we have somthing to send
buffer_w = out$ !
bytes_w = len(out$) !
if debug > 0 then
print "-i-sending";bytes_w;"byte nvt handshake"
print "-i-nvt data out: ";
for i = 1 to len(out$) ! scan outbound string
q = mid$(out$,i,1)
select asc(q)
case kIAC
print "IAC ";
case kWILL
print "WILL ";
case kWONT
print "WONT ";
case kDO
print "DO ";
case kDONT
print "DONT ";
case kSB
print "SB ";
case kSE
print "SE ";
case else
print str$(asc(q));" ";
end select
next i
print ! EOL
end if
rc = nsr_tcp_send(debug, ncv, buffer_w, bytes_w, "0 0:0:05.0") ! xmit with 5 second time limit
if (rc and 7%) <> 1 then !
print "-e-NVT send error:";rc !
end if !
end if !
!
buffer_r = buf$ ! update the read buffer
bytes_r = len(buf$) ! update the count
rc = 1 !
!
rc_exit: !
nsr_nvt_scan = rc !
print "-i-exit function: nsr_nvt_scan() with status:";rc;"<<<<<" if debug > 0
end function !
!=======================================================================
! host to network short (every stack has one of these)
! OpenVMS is little endian but the network is big endian
!=======================================================================
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 (every stack has one of these)
! OpenVMS is little endian but the network is big endian
!=======================================================================
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)
!=======================================================================
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)" !
print " quad "; sw0_quad0
print " long0 "; sw0_long0
print " long1 "; sw0_long1
end if !
end function !
!=======================================================================
! octets to quad
! caveat: we do this because this BASIC has no unsigned integers
!=======================================================================
function quad octets_to_quad(long octet() by ref) !
option type=explicit !
declare quad junk64 !
!
junk64 = 0 ! init
!
when error in !
%let %convert_method=1 ! stuffing is more efficient than math
%if %convert_method=0 %then !
junk64 = octet(0)) * 16777216 + ! 2^24 &
octet(1)) * 65536 + ! 2^16 &
octet(2)) * 256 + ! 2^8 &
octet(3)) ! 2^0
%else
%include "[.inc]WCSM_TCP_SUPPORT_109.INC" !
declare stuffer32_rec stuffer32 !
stuffer32::long_offset00 = octet(3) !
stuffer32::long_offset08 = octet(2) !
stuffer32::long_offset16 = octet(1) !
stuffer32::long_offset24 = octet(0) !
junk64 = stuffer32::quad0 !
%end %if
use !
junk64 = 0 !
end when !
octets_to_quad = junk64 !
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)
!=======================================================================
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 get-host-by-name-type (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
! : query_type$ : desired lookup type (MX = mail exchange)
! output_mode : 0 = string, 1 = array of longs
! exit : octets array : filled with 4 entries
!=======================================================================
function long nsr_dns_ghnt( long debug, &
string dns_name$, &
string query_type$, &
long output_mode, &
string ip_address$, &
long octets() by ref, &
string time_limit$ )
option type=explicit ! formal declarations required
!
%include "[.inc]WCSM_TCP_SUPPORT_109.INC" !
!
external long function nsr_dns_prep(long, ncv_rec )
external long function nsr_tcp_clos(long, ncv_rec )
external long function nsr_tcp_free(long, ncv_rec )
!
! <<< 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_ghnt() >>>>>" 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
!-----------------------------------------------------------------------
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
!
! 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 entries in the BIND cache)
!
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_ghnt = rc ! rc is returned to caller
print "-i-exit function: nsr_dns_ghnt() with status:";rc;"<<<<<" if debug > 0
end function !
Back to HomeNeil Rieck
Waterloo, Ontario, Canada.