OpenVMS Source Code Demos
TCPIP$TCP_CLIENT_QIO_2014E
1000 %title "tcpip$tcp_client_qio_2014e_xxx.bas"
%ident "version_107.2"
declare string constant k_version = "107.2" , &
k_program = "tcpip$tcp_client_qio_2014e" !
!========================================================================================================================
! title : tcpip$tcp_client_qio_2014e
! author : Neil Rieck ( https://neilrieck.net )
! : (c) copyright 1999,2014 Neil Rieck
! : Waterloo, Ontario, Canada.
! created : 2014-08-04
! 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_2014e_106.bas (where 106 is the version number)
! link : $ link tcpip$tcp_client_qio_2014e_106
! references : HP TCP/IP Services for OpenVMS
! Sockets API and System Services Programming (manual: BA548-90002)
! notes : 1. stack programming on VMS/OpenVMS can be done by "Sockets API" (easier) or using
! "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
! 5. The E client demo adds NVT routines so we can telnet
! Caveat : after the NVT-handshake at the beginning of a telnet session, most stacks will already know the
! TERMIMAL TYPE. However, many VMS/OpenVMS systems contain login scripts which always execute DCL
! command "SET TERM/INQUIRE". This operation works as follows:
! a) host sends: <esc> [ c (ANSI request to identify terminal type)
! expecting: <esc> [ ? 1 ; 0 c (for VT100 within 2 seconds)
! or: <esc> [ ? 1 ; 2 c (for VT102) within 2 seconds
! b) if no terminal response after 2-seconds then you will see:
! host sends: <esc> \ (clear character set)
! folowed by: <esc> Z (VT52 request to identify terminal type)
! c) if no terminal response after 2-seconds then you will see:
! host sends: <esc> [ 0 c (alternate ANSI request to identify terminal)
! Obviously these 2-second delays will mess up my timers when set too low
! history :
! ver who when what
! --- --- ------ --------------------------------------------------------------------------------------------------------
! 105 NSR 140825 0. started with TCPIP$TCP_CLIENT_QIO_2014D_105.BAS
! 1. adding code to support NVT handshakes (see external function nsr_nvt_scan)
! NSR 140828 2. the saga continues
! 106 NSR 140829 1. moved octets_to_quad into an external function
! NSR 140902 2. added nvt enhancements
! 3. introduced a little code mtce
! NSR 140903 4. introduced a tweak for the WONT/DONT problem with Solaris bf_106.4
! 107 NSR 140903 1. replace "any" with the correct data types in external function declarations
! NSR 140904 2. moved destination decoding into an external function (got to stick with the KISS principle)
!========================================================================================================================
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 k_os_vanilla = 1 , &
k_os_openvms = 2 , &
k_os_solaris = 3 , &
k_os_windows = 4
!
%include "TCPIP$TCP_CLIENT_QIO_2014E.INC" !
%include "nvt_definitions.inc" ! nvt = network virtual terminal
!
! declare variables
!
map(recv)string buffer_r = TCPBUFSIZ !
map(xmit)string buffer_w = TCPBUFSIZ !
!
declare string msg$ , &
keyboard$ , &
dest$ , &
path$ , &
tcp_proto$ , &
username$ , &
password$ , &
buffer$ , &
junk$ , &
long ip_address , &
first_time , &
send_count , &
word tcp_port , &
long rc , &
bytes_w , &
readcount , &
bytes_r , &
nvt_msgs , &
bytes_r_total , &
os_type , &
http% , &
junk% , &
try% , &
junk1 , &
junk2 , &
dest_kind , &
i% , &
debug , &
ncv_rec ncv , ! network connection variables &
ncv2 ! support for a second connection
!
!=======================================================================
! main
!=======================================================================
2000 main:
print
print k_program +"_"+ k_version !
!
get_dest:
print string$(len(k_program + k_version) + 1, asc("=")) !
select tcp_port !
case 23 !
tcp_proto$ = "telnet" !
case else !
tcp_port = 80 ! default to HTTP
tcp_proto$ = "http" !
end select !
print "-i-port:";tcp_port;"(";tcp_proto$;")" !
print "-i-debug:";debug
print "-i-Menu:"
print " 1 = 142.180.221.226 (OpenVMS-8.4 w/TCPware stack)"
print " 2 = kawc96.on.bell.ca"
print " 3 = 142.180.221.246 (Solaris-8 )"
print " 4 = kawc3w.on.bell.c"
print " 5 = 142.180.221.220 (OpenVMS-8.4 w/native stack )"
print " 6 = kawc0f.on.bell.ca"
print " or any string (eg. www3.sympatico.ca )"
print " (eg. neilrieck.net/ )"
print " T = toggle tcp port between 80 (http) and 23 (telnet)"
PRINT " D = set debug level"
print " Q = quit (default)"
print
print "-?-";tcp_proto$;" destination? "; !
input dest$ !
dest$ = edit$(dest$,2) ! no white space
select dest$ !
case "T","t" !
if tcp_port = 80 then !
tcp_port = 23 !
else !
tcp_port = 80 !
end if !
goto get_dest !
case "1" !
dest$ = "142.180.221.226" !
case "2" !
dest$ = "kawc96.on.bell.ca" !
case "3" !
dest$ = "142.180.221.246" !
case "4" !
dest$ = "kawc3w.on.bell.ca" !
case "5" !
dest$ = "142.180.221.220" !
case "6" !
dest$ = "kawc0f.on.bell.ca" !
case "D","d" !
when error in !
input "-?-debug? (0-3) ";debug !
debug = 0 if debug < 0 !
use !
debug = 0 !
end when !
goto get_dest !
case else !
goto fini if len(dest$)<=1 ! "Q", "q"
end select !
!
3000 ip_address = nsr_adr_prep(debug, dest$, path$, dest_kind) ! all params (except debug) may be modified
select dest_kind !
case 1 ! we "know" this is an IPv4 address
print "-i-you entered an IPv4 address" !
http% = 0 ! only HTTP/1.0 requests are possible
case 2 ! this might be a dns name
print "-i-you entered a dns name" !
http% = 1 ! HTTP/1.1 request is possible
case else !
print "-e-error, your input data is not useable" !
goto get_dest !
end select !
!
!-----------------------------------------------------------------------
!
if tcp_port = 23 then ! telnet requires more information
input "-?-username: ";username$ !
goto get_dest if edit$(username$,2) = "" !
input "-?-password: ";password$ !
goto get_dest if edit$(password$,2) = "" !
try% = 200 ! start with sequence 200
else !
sleep 1
try% = 100 ! start with sequence 100
end if !
!-----------------------------------------------------------------------
!
! create socket
!
rc = nsr_tcp_prep(debug, ncv ) ! allocate flags, allocate channel, etc.
goto rc_exit if (rc and 7%) <> 1 !
!
! connect
!
!~~~ tcp_port = SERV_PORTNUM x
rc = nsr_tcp_open(debug, ncv, ip_address, tcp_port,"0 0:0:05.0") ! connect with 5 second time limit
goto rc_exit if (rc and 7%) <> 1 !
!-----------------------------------------------------------------------
! send loop
!-----------------------------------------------------------------------
send_count = 0 ! init
!
! entry pt.
!
send_loop: !
send_count = send_count + 1 if debug > 0
print "-i-SEND-try:";try%;" count:";send_count;" ############################>>>" if debug > 0
!
! action states (send)
! ====================
! <=99 nothing
! 100-199 http handshake sequences
! 200-299 telnet handshake sequences
! >=300 nothing
!
select try% !
case <100 ! this is more for information
print "-e-try:";try%;"which is a programming error"
rc = 2
goto rc_exit
case 100 ! http demo sequence starts here ------
!-----------------------------------------------------------------------
! 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:" if debug > 0
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:" if debug > 0
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$ if debug > 0
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 0:0:05.0") ! xmit with 5 second time limit
goto rc_exit if (rc and 7%) <> 1 !
case 101 !
if http% = 1 then !
print
print "-i-since this is a persistent connection..."
print "-i-resending this HTTP 1.1 request:"
msg$ = "GET "+ path$ +" HTTP/1.0" + cr + lf + &
"host: "+ dest$ + cr + lf + &
cr + lf ! blank line marks end of HTTP block
sleep 1
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 0:0:05.0") ! xmit with 5 second time limit
goto rc_exit if (rc and 7%) <> 1 !
end if !
case 102 ! http demo sequence ends here --------
goto no_more_processing !
case 103 to 199
print "-e-try:";try%;"which is a programming error"
rc = 2
goto rc_exit
case 200 ! telnet demo sequence starts here ----
buffer$ = "" ! zap buffer
print "-i-nothing to send"
! telent usually starts nvt receive
case 201 !
!
! caveat: if you know this is a VMS system then you might wish to send: username/nocommand
! to avoid processing startup scripts
!
print "-i-sending username" !
msg$ = username$ + cr !
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 0:0:05.0") ! xmit with 5 second time limit
goto rc_exit if (rc and 7%) <> 1 !
case 202 !
print "-i-sending password" !
msg$ = password$ + cr !
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 0:0:05.0") ! xmit with 5 second time limit
goto rc_exit if (rc and 7%) <> 1 !
case 203 to 209 !
print "-i-sending <cr>" !
msg$ = cr !
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 0:0:05.0") ! xmit with 5 second time limit
goto rc_exit if (rc and 7%) <> 1 !
case 210
select os_type !
case k_os_openvms ! OpenVMS
msg$ = "show symbol *" ! see DCL variables
case k_os_solaris ! Solaris
msg$ = "set " ! see shell variables
case else !
msg$ = "" !
end select !
print "-i-sending: "; msg$ !
msg$ = msg$ + cr !
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 0:0:05.0") ! xmit with 5 second time limit
case 211 ! LOGOUT
select os_type !
case k_os_vanilla ! Vanilla
msg$ = "logout" !
case k_os_openVMS ! OpenVMS
msg$ = "logoutnow" !
case k_os_solaris ! Solaris
msg$ = "exit" !
case k_os_windows !
msg$ = "log" ! Windows
case else !
msg$ = "exit" !
end select !
print "-i-sending: "; msg$ !
msg$ = msg$ + cr !
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 0:0:05.0") ! xmit with 5 second time limit
case 212 !
goto no_more_processing !
case else !
print "-e-try:";try%;"which is a programming error"
rc = 2
goto rc_exit
end select
!
!-----------------------------------------------------------------------
! read the response
!-----------------------------------------------------------------------
receive_data:
print "-i-RECV-try:";try%;" ######################################<<<" if debug > 0
4040 print "-i-receiving data" if debug > 0
readcount = 0 ! init loop counter
bytes_r_total = 0 !
!
read_loop:
bytes_r = 0 ! init
readcount = readcount + 1
print "-i-receiving count:";readcount if debug > 0 !
print " -------------------" if debug > 0 !
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 !
goto no_more_processing !
end if !
!
! action states (recv)
! ====================
! <=99 nothing
! 100-199 http handshake sequences
! 200-299 telnet handshake sequences
! >=300 nothing
!
select try% !
case <100 ! this is more for information
goto no_more_processing !
case 100 to 101 ! http demo sequence starts here ------
if bytes_r > 0 then ! if any data bytes
print left$(buffer_r,bytes_r) ! then output that amount
bytes_r_total = bytes_r_total + bytes_r ! also add to total
end if !
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 !
print
print "------------------------------"
sleep 1 !
try% = try% + 1 ! 100 -> 101
goto send_loop !
case 102 ! http demo sequence ends here --------
goto no_more_processing !
case 103 to 199 ! unsupported
goto no_more_processing !
case 200 ! telnet demo sequence starts here ----
! waiting for login prompt
junk% = nsr_nvt_scan( ! &
debug, ncv, buffer_w, bytes_w, "0 0:0:05.0", ! same params as nsr_tcp_send() &
buffer_r, bytes_r, nvt_msgs) ! params to test and set
if bytes_r > 0 then ! if any data bytes (after nvt processing)
print left$(buffer_r,bytes_r) ! output that amount
bytes_r_total = bytes_r_total + bytes_r ! also add to total
buffer$ = buffer$ + left$(buffer_r,bytes_r) !
end if !
if ((bytes_r + nvt_msgs) > 0) and ! if we received something &
(readcount < 150) then ! and we're not too crazy
goto read_loop ! then read some more
end if !
junk$ = edit$(buffer$,128+32+16+8+4) ! trailing,ucase,compress,leading
junk% = 0 ! init
junk% = 1 if pos(junk$,"USERNAME:",1)>0 ! OpenVMS-8.4
junk% = 1 if pos(junk$,"LOGIN:" ,1)>0 ! Solaris-8
if junk% = 1 then !
print "-i-detected login prompt" !
try% = try% + 1 !
goto send_loop !
else !
print "-w-oops, didn't detect a login prompt" ! just exit this demo
end if !
case 201 ! waiting for password prompt
junk% = nsr_nvt_scan( ! &
debug, ncv, buffer_w, bytes_w, "0 0:0:05.0", ! same params as nsr_tcp_send() &
buffer_r, bytes_r, nvt_msgs) ! params to test and set
if bytes_r > 0 then ! if any data bytes (after nvt processing)
print left$(buffer_r,bytes_r) ! output that amount
bytes_r_total = bytes_r_total + bytes_r ! also add to total
buffer$ = buffer$ + left$(buffer_r,bytes_r) !
end if !
if ((bytes_r + nvt_msgs) > 0) and ! if we received something &
(readcount < 150) then ! and we're not too crazy
goto read_loop ! then read some more
end if !
junk$ = edit$(buffer$,128+32+16+8+4) ! trailing,ucase,compress,leading
junk% = 0 ! init
junk% = 1 if pos(junk$,"PASSWORD:",1)>0 ! OpenVMS-8.4 (and Solaris-8)
if junk% = 1 then !
try% = try% + 1 !
goto send_loop !
else !
print "-w-oops, didn't detect a password prompt" ! just exit this demo
end if !
case 202 ! waiting for login success
junk% = nsr_nvt_scan( ! &
debug, ncv, buffer_w, bytes_w, "0 0:0:05.0", ! same params as nsr_tcp_send() &
buffer_r, bytes_r, nvt_msgs) ! params to test and set
if bytes_r > 0 then ! if any data bytes (after nvt processing)
print left$(buffer_r,bytes_r) ! output that amount
bytes_r_total = bytes_r_total + bytes_r ! also add to total
buffer$ = buffer$ + left$(buffer_r,bytes_r) !
end if !
if ((bytes_r + nvt_msgs) > 0) and ! if we received something &
(readcount < 150) then ! and we're not too crazy
goto read_loop ! then read some more
end if !
junk$ = edit$(buffer$,128+32+16+8+4) ! trailing,ucase,compress,leading
junk% = 0 ! init
junk% = k_os_vanilla if pos(junk$,"WELCOME",1)>0 !
junk% = k_os_openvms if pos(junk$,"LAST INTERACTIVE LOGIN ON",1)>0
junk% = k_os_solaris if pos(junk$,"SUN MICROSYSTEMS",1)>0 !
junk% = k_os_solaris if pos(junk$,"SUNOS",1)>0 !
junk% = k_os_windows if pos(junk$,"MICROSOFT",1)>0 !
junk% = 9 if pos(junk$,"BAD PASSWORD",1)>0 ! vanilla
junk% = 9 if pos(junk$,"USER AUTHORIZATION FAILURE",1)>0 ! OpenVMS
junk% = 9 if pos(junk$,"LOGIN INCORRECT",1)>0 ! Solaris
select junk% !
case 0, 9 !
print "-w-oops, didn't detect login success" ! just exit this demo (fall thru)
case else !
os_type = junk% ! rememeber OS type
try% = try% + 1 !
goto send_loop !
end select !
case 202 to 299 !
junk% = nsr_nvt_scan( ! &
debug, ncv, buffer_w, bytes_w, "0 0:0:05.0", ! same params as nsr_tcp_send() &
buffer_r, bytes_r, nvt_msgs) ! params to test and set
if bytes_r > 0 then ! if any data bytes (after nvt processing)
print left$(buffer_r,bytes_r) ! output that amount
bytes_r_total = bytes_r_total + bytes_r ! also add to total
buffer$ = buffer$ + left$(buffer_r,bytes_r) !
end if !
if ((bytes_r + nvt_msgs) > 0) and ! if we received something &
(readcount < 150) then ! and we're not too crazy
goto read_loop ! then read some more
end if !
junk$ = edit$(buffer$,128+32+16+8+4) ! trailing,ucase,compress,leading
junk% = 0 ! init
!
! various tests could go here
!
junk% = 1
if junk% = 1 then !
try% = try% + 1 !
goto send_loop ! we'll just send <cr>
else !
print "-w-oops, didn't detect login success" ! just exit this demo
end if !
case else !
print "-e-try:";try%;"which is a programming error" !
rc = 2 !
goto rc_exit !
end select !
no_more_processing:
!
! but we still may have received something so test bytes_r
!
print "-i-total bytes received:";bytes_r_total if debug > 0 !
!
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...
!-----------------------------------------------------------------------
! get keyboard
!-----------------------------------------------------------------------
get_keyboard:
!
! Interactive Input is in this block of code but...
! while we are here we are not paying attention to the receive stream (bad)
!
keyboard$ = "" !
when error in !
if first_time = 0 then !
print "Note: 1) don't enter anything until you see your prompt"
print " 2) timeout applies to keystrokes; not the time until you hit <enter>"
sleep 1 !
first_time = 1 ! don't come back this way
end if !
wait 2 ! enable keyboard timer (2-secs)
print "-?-text to send (blank line to exit) "; !
linput keyboard$ !
junk% = 0 ! not a timeout
use !
junk% = err ! probably a timeout
end when !
wait 0 ! disable timer
if junk% = 15 then !
print cr + lf + "-w- timeout" !
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
!########################################################################################################################
!
!=======================================================================================
! <<< 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: "neilrieck.net/"
! 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
!=======================================================================================
32701 function long nsr_adr_prep(long debug, string dest$, string path$, long kind)
option type=explicit !
!
%include "TCPIP$TCP_CLIENT_QIO_2014E.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 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
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>=3 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 !
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
!=======================================================================
32702 function long nsr_tcp_prep( long debug , &
ncv_rec ncv by ref )
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014E.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 !
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)
!=======================================================================
32703 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_2014E.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
!=======================================================================
32704 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_2014E.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 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
!=======================================================================
32705 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_2014E.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 = 2 x vms-e-
rc = 8 + 1 ! vms-w-
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 !
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()
!=======================================================================
32706 function long nsr_tcp_clos( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014E.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()
!=======================================================================
32707 function long nsr_tcp_free( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014E.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
!=======================================================================
32708 function long nsr_dns_prep( long debug, &
ncv_rec ncv )
option type=explicit ! formal declarations required
!
%include "TCPIP$TCP_CLIENT_QIO_2014E.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
!=======================================================================
32709 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 "TCPIP$TCP_CLIENT_QIO_2014E.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 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 !
!
!=======================================================================
! 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
!
32710 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 "TCPIP$TCP_CLIENT_QIO_2014E.INC" !
%include "nvt_definitions.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
!=======================================================================
32711 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
!=======================================================================
32712 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)
!=======================================================================
32713 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
!=======================================================================
32714 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 "TCPIP$TCP_CLIENT_QIO_2014E.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)
!=======================================================================
32715 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
!=======================================================================