OpenVMS Source Code Demos
TCPIP$TCP_SA_CLIENT_QIO_BASIC
1000 %title "TCPIP$TCP_SA_CLIENT_QIO_BASIC" !
%ident "version_203.3" ! <---+--- must match
declare string constant k_version = "203.3" , ! <---+ &
k_program = "TCPIP$TCP_SA_CLIENT_QIO_BASIC" !
!========================================================================================================================
! Title : TCPIP$TCP_SA_CLIENT_QIO_BASIC.BAS (SA=standalone)
! Author : Neil Rieck
! Notes : 1. this demo program is derived from "TCPIP$TCP_CLIENT_QIO_BASIC_101.bas"
! which was derived from "TCPIP$EXAMPLES:TCPIP$TCP_CLIENT_QIO.C"
! which is a TCP/IP (UCX) example program for DEC-C and VAX-C
! copyrighted in 1989 and 1998 by "Digital Equipment Corporation" and
! subsequently by "Compaq Computer Corporation".
! More 'C' programs were added in 2003 and 2008.
! 2. this program does not (yet) support IPV6
! 3. this program has very little structure (spaghetti exits, etc). I wrote it this way so the good parts
! could be used for teaching basic concepts.
! History:
! ver who when what
! --- --- ------ --------------------------------------------------------------------------------------------------------
! 201 NSR 121230 1. started work (derived from: TCPIP$TCP_CLIENT_QIO_BASIC_101.bas) to implement TELNET
! 202 NSR 130101 1. split the combo-select into separate send and receive select blocks
! NSR 130102 2. added code to reduce debug messages
! 3. now prompt for username and password
! 203 NSR 130103 1. added code to implement HTTP
! 2. a few mods for improved clarity
!========================================================================================================================
option type=explicit ! cuz tricks are for kids
!
declare string constant k_port = "80" ! default port
declare string constant k_destination = "127.0.0.1" ! default destination
declare string constant k_user = "neil" ! default username
declare string constant k_pass = "whatever" ! default password
declare long constant k_r_buf_size = 4096 ! size of receive buffer
declare long constant k_w_buf_size = 80 ! size of xmit buffer
!
on error goto trap ! old-school trapping
!
! <<< external declarations >>>
!
%include "starlet" %from %library "sys$library:basic$starlet" ! system services
%include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$
%include "$iodef" %from %library "sys$library:basic$starlet" ! io$
%include "lib$routines" %from %library "sys$library:basic$starlet" ! lib$
!~~~ %include "sys$library:ucx$inetdef.bas" x old-school definitions for BASIC
%include "sys$library:tcpip$inetdef.bas" ! tcp/ip network definitions for BASIC
!
! <<< home brewed functions >>>
!
external word function htons(word by ref) !
external byte function long_to_byte( long by ref ) !
external long function get_timer_bit_vector(long) ! required for used with SYS$WFLOR
!
! note: for the peek trick to work, we must...
!
! 1. declare LONG BY VALUE passing mechanisms here (we are passing 32-bit addresses)
! 2. declare BY REF passing mechanisms in the receiving functions
!
external long function my_peek_L( long by value ) ! hacking use only
external long function my_peek_W( long by value ) ! hacking use only
external long function my_peek_B( long by value ) ! hacking use only
!
! my I/O Status Block (record)
!
record IosbRec !
variant !
case !
group one !
word rc !
word xfer_count !
long long_0 !
end group one !
case !
group two !
basic$quadword quad_0 ! unsigned quad word (system calls)
end group two !
end variant !
end record IosbRec !
!
! my Item Record Block (record)
!
record ItemRec !
variant !
case !
group one !
word BuffLen !
word ItemCode !
long BuffAddr !
long RtnLenAdr !
end group one !
case !
group two !
long ListTerm
long junk1
long junk2
end group two
end variant
end record ItemRec !
!
! <<< variable declarations >>>
!
declare long rc% , ! return code &
need_cr% , ! &
skip_send% , ! &
skip_receive% , ! &
read_limit% , ! &
timeout_limit% , ! &
look_for_prompts% , ! &
debug% , ! &
trace% , ! &
junk% , ! &
junk1% , ! &
junk2% , ! &
discard% , ! &
i% , ! &
j% , ! &
dots% , ! &
dot1% , ! &
dot2% , ! &
dot3% , ! &
oct1% , ! &
oct2% , ! &
oct3% , ! &
oct4% , ! &
state% , ! &
read_counter% , ! &
timeout_count% , ! &
tcp_event_flag% , ! tcp event flag &
tcp_ef_state% , ! tcp event flag state &
timer_event_flag% , ! timer event flag &
timer_ef_state% , ! &
mask% , ! &
max_secs% , ! &
word channel_0 , ! INET channel &
word sck_parm(2) , ! Socket creation parameter &
basic$QuadWord DeltaQuad , ! for sys$bintim &
IosbRec myIosb , ! &
string buffer$ , ! &
buffer_uc$ , ! &
send$ , ! &
expect$ , ! &
unexpect$ , ! &
junk$ , ! &
address$ , ! &
port$ , ! &
http$ , ! &
username$ , ! &
password$ !
!
map(rbuf)string r_buf = k_r_buf_size !
map(wbuf)string w_buf = k_w_buf_size !
declare word port% !
declare long dummy_ptr% ! in DECC was unsigned char *dummy
declare long r_retlen !
declare sockaddrin remote_host ! was sockaddr_in in 'C'
!
record IL2 ! input list 2 descriptor
long il2_length !
long il2_address !
end record IL2 !
declare IL2 rhst_adrs ! remote host address
!
! <<< nvt option definitions >>>
!
declare long constant WILL = 251 ,&
WONT = 252 ,&
DO = 253 ,&
DONT = 254 ,&
IAC = 255 ,&
kSB = 250 ,&
kGA = 249 ,&
kSE = 240 ,&
kECHO = 1 ,&
SUPPRESS_GA = 3 ,&
kSTATUS = 5 ,&
TIMING_MARK = 6 ,&
TERM_TYPE = 24 ,&
WINDOW_SIZE = 31 ,&
TERM_SPEED = 32 ,&
REMOTE_FLOW_CTL = 33 ,&
LINE_MODE = 34 ,&
ENVIRON = 36
!
!===============================================================
! main
!===============================================================
1500 main: !
print k_program +"_"+ k_version !
print string$(len(k_program +"_"+ k_version), asc("=")) ! how will this optimize on Alpha?
!
prompt_port:
print "Port menu:"
print " 23 = telnet"
print " 80 = http (web)"
print "port? (Q/uit, default="+ k_port +")"; !
input port$ !
port$ = edit$(port$,2) ! no whitespace
goto fini if edit$(port$,32) = "Q" ! Q/uit
port$ = k_port if port$="" ! default
when error in !
port% = integer(port$) ! make sure port is numeric
use !
port% = 0 !
end when !
!
select port% !
case 23, 80
!~~~ case 1 to 6000 !
case else !
print "-e-error, port no supported" !
goto prompt_port !
end select !
!
if port% = 80 then
prompt_http:
print "HTTP Menu:"
print " 0 = 1.0 (disconnects immediately)"
print " 1 = 1.1 (persistant connection)"
print "HTTP Type? (0,1, default=1) "; !
input http$ !
http$ = edit$(http$,2) ! no whitespace
select http$
case "1.0"
case "1.1"
case "0"
http$ = "1.0"
case else
http$ = "1.1" !
end select !
end if
!
! username and password are only required with TELNET
!
if port% = 23 then !
prompt_username:
print "destination user name? (Q/uit, default="+ k_user +")"; !
input username$ !
username$ = edit$(username$,2) ! no whitespace
goto fini if edit$(username$,32) = "Q" ! Q/uit
username$ = k_user if username$="" ! default
!
prompt_password:
print "destination password? (Q/uit, default="+ k_pass +")"; !
input password$ !
password$ = edit$(password$,2) ! no whitespace
goto fini if edit$(password$,32) = "Q" ! Q/uit
password$ = k_pass if password$="" ! default
end if
!
! prompt for an address
!
address_prompt:
print "destination address? (Q/uit, default="+ k_destination +")";
input address$ !
address$ = edit$(address$,32+2) ! upcase, no whitespace
goto fini if left$(address$,1)="Q" ! Q/uit
address$ = k_destination if address$="" ! default
if len(address$) < 8 then !
print "-e-address is too short" !
goto address_prompt !
end if !
!
dots% = 0 ! init address test
for i% = 1 to len(address$) !
select mid$(address$,i%,1) !
case "0" to "9" ! legal range
case "." !
dots% = dots% +1 !
select dots% !
case 1 !
dot1% = i% !
case 2 !
dot2% = i% !
case 3 !
dot3% = i% !
case else !
print "-e-more than 3 dots detected" !
goto address_prompt !
end select !
case else !
print "-e-illegal character detected at position "+str$(i%)
goto address_prompt !
end select !
next i% !
if dots% < 3 then !
print "-e-less than 3 dots detected" !
end if !
!
! do range checks on the octets
!
1600 oct1% = integer(left$ (address$, dot1%-1 ) )
select oct1%
case 1 to 254
case else
print "-e-error, octet #1 is out of range"
goto address_prompt
end select
!
oct2% = integer(seg$ (address$, dot1%+1,dot2%-1 ) )
select oct2%
case 0 to 255
case else
print "-e-error, octet #2 is out of range"
goto address_prompt
end select
!
oct3% = integer(seg$ (address$, dot2%+1,dot3%-1 ) )
select oct3%
case 0 to 255
case else
print "-e-error, octet #3 is out of range"
goto address_prompt
end select
!
oct4% = integer(right$(address$, dot3%+1 ) )
select oct4%
case 1 to 254
case else
print "-e-error, octet #4 is out of range"
goto address_prompt
end select
!
! Debug menu
!
print "Debug Menu" !
print " 0 = some informationals" !
print " 1 = all informationals" !
print " 2 = some data details" !
print " 3 = all data details" !
print "-?-debug level: (0-3) "; !
input junk$ !
when error in !
debug% = integer(junk$) !
use !
debug% = 0 !
end when !
debug% = 0 if debug% < 0 !
print "-i-debug level: "+ str$(debug%) !
!
! <<< allocate some event flags for later use >>>
!
if tcp_event_flag% = 0 then ! if not yet allocated
rc% = lib$get_EF( tcp_event_flag% ) ! allocate an event flag
if ((rc% and 7%) <> 1) then !
print "lib$get_EF-1 rc: ";str$(rc%) !
goto rc_exit !
end if !
end if !
!
if timer_event_flag% = 0 then ! if not yet allocated
rc% = lib$get_EF( timer_event_flag% ) ! allocate another event flag
if ((rc% and 7%) <> 1) then !
print "lib$get_EF-2 rc: ";str$(rc%) !
goto rc_exit !
end if !
end if !
!
! <<< prep to create a socket >>>
!
declare string inet_dev ! dynamic string descriptor (good)
inet_dev = "TCPIP$DEVICE:" !
!
declare ItemRec Item_List(1) ! 0->1
item_list(0)::BuffLen = 4 ! 4 bytes (the size of next param)
item_list(0)::ItemCode = TCPIP$C_REUSEADDR !
item_list(0)::BuffAddr = 0 ! none
item_list(0)::RtnLenAdr = 0 ! no address given (so call will not store return length)
item_list(1)::ListTerm = 0 ! no more items...
!
declare ItemRec sock_opts(1) !
sock_opts(0)::BuffLen = 4 ! 4 bytes
sock_opts(0)::ItemCode = TCPIP$C_SOCKOPT !
sock_opts(0)::BuffAddr = loc( item_list(0) ) !
sock_opts(0)::RtnLenAdr = 0 ! no address given (so call will not store return length)
sock_opts(1)::ListTerm = 0 ! no more items...
rhst_adrs::il2_length = SIN$S_SOCKADDRIN ! size of local host sockaddrin
rhst_adrs::il2_address = loc( remote_host ) ! address of local host sockaddrin
sck_parm(0) = TCPIP$C_TCP ! TCP/IP protocol
sck_parm(1) = INET_PROTYP$C_STREAM ! stream type of socket
!
! Both VAX + Alpha are little-endian architectures.
! However, network order requires that we send MSB first so we load structures as if we were big-endian
!
map(switcheroo) long long0 !
map(switcheroo) byte byte0 , ! LSB (little-endian) &
byte1 , ! &
byte2 , ! &
byte3 ! MSB (little-endian)
!
2000 %let %loopback=0% ! 1=use loopback, 0=use entered address
%if %loopback=1% !
%then
byte0= 127 ! 127.0.0.1
byte1= 0 !
byte2= 0 !
byte3= 1 !
%else
byte0= long_to_byte( oct1% )
byte1= long_to_byte( oct2% )
byte2= long_to_byte( oct3% )
byte3= long_to_byte( oct4% )
%end %if
!
3000 remote_host::sin$w_family = TCPIP$C_AF_INET ! INET family (in 'c' was: sin_family )
remote_host::sin$l_addr = long0 ! address (in 'c' was: sin_addr.s_addr )
remote_host::sin$w_port = htons(port%) ! (in 'c' was: sin_port )
print "-i-address: "+ address$ !
print "-i-port : "+ port$ !
!
! Assign a channel to the TCPIP device
!
rc% = sys$assign(inet_dev, channel_0,,,) ! assign a channel
if ((rc% and 1%) <> 1%) then !
print "-e-Failed to assign channel to TCPIP device." !
!~~~ call lib$stop(rc%) x death seems rather abrupt :-)
goto rc_exit !
end if !
!===============================================================
! create a socket (not timed so use sys$qiow)
!===============================================================
rc% = sys$qiow( tcp_event_flag% , ! Event flag &
channel_0 , ! Channel number &
IO$_SETMODE , ! I/O function &
myIosb::quad_0 , ! I/O status block &
, ! &
, ! &
sck_parm(0) , ! P1 Socket creation parameter &
, ! P2 &
, ! P3 &
, ! P4 &
, ! P5 Socket option descriptor &
) ! P6
if ((rc% and 1%) = 1%) then ! if the system call suceeded
rc% = myIosb::rc ! then use the rc of the operation
end if !
if ((rc% and 1%) <> 1%) then ! oops
print "-e-Failed to create the device socket. rc: "+str$(rc%)
goto rc_exit !
end if !
!===============================================================
! Bind to chosen port number (after REUSEADDR is set above)
! Internet events need to be timed so use $qio
!===============================================================
max_secs% = 9 ! max time to connect
gosub arm_timer !
rc% = sys$qio( tcp_event_flag% , ! Event flag &
channel_0 , ! Channel number &
IO$_ACCESS , ! I/O function &
myIosb::quad_0 , ! I/O status block &
, ! &
, ! &
, ! P1 &
, ! P2 &
loc(rhst_adrs::il2_length) , ! P3 local socket name &
, ! P4 &
, ! P5 &
) ! P6
if ((rc% and 1%) <> 1%) then !
print "-e-bind failed: rc% "+str$(rc%) !
junk% = sys$cantim(,) ! cancel all timer requests
if (junk% and 1%) <> 1% then !
print "-e-cantim rc: "+ str$(junk%) !
end if !
goto rc_exit !
end if !
!
gosub process_event_flags !
!
! at this point either the TCP-EF or the TIMER-EF should be set
!
if (timer_ef_state% = 1) then ! if the TIMER-EF is set
print "-i-the tcp event timed out (so do something)" !
print "-e-Failed to connect to remote host" !
rc% = 2 !
goto rc_exit !
else !
if ((rc% and 1%) = 1%) then ! if the system call suceeded
rc% = myIosb::rc ! then use the rc of the operation
end if !
end if !
!===============================================================
! (a very) simple state handler
!===============================================================
select port% !
case 23 !
state% = 1 ! start with NVP
case 80 !
select http$ !
case "1.0" !
state% = 80 !
case "1.1" !
state% = 180 !
end select !
case else !
state% = 80 ! init machine state
end select !
goto this_state !
!
next_state: !
state% = state% + 1 !
this_state:
print "-i-moving to machine state: "+ str$(state%) +" <<<<<<<<<<"
skip_receive% = 0 ! init each pass
skip_send% = 0 !
read_limit% = 99 ! 99 read operations per call
timeout_limit% = 3 ! 3 timeouts qio with no data returned
!===============================================================
! send block
!===============================================================
select state% !
!
! TELNET SECTION
!
case 1 ! wait for NVT handshake from server (telnet)
skip_send% = 1 !
read_limit% = 1 ! do not read until timeout (one read)
case 2 ! send our NVT data
!
! send NVT handshake (see: RFC 854/855)
! 1. server options -> client (case 1 above)
! 2. client options -> server (case 2)
! 3. server options -> client (case 3 below)
! (if no options then the server will send
!
! Hacking fun: try sending the SERVER "IAC WILL ECHO" (meaning we will echo everything the server sends
! us "back to the server". In the response (case 3) you will see the server respond with "IAC DONT ECHO"
! telling us not to do it. Why? This echo feature is meant to be server-to-client only so humans get a
! confirmation that the keystroke was sucessfull.
!
send$ = chr$(IAC) + chr$(WILL) + chr$(SUPPRESS_GA) + ! &
chr$(IAC) + chr$(DO) + chr$(SUPPRESS_GA) + ! &
!~~~ chr$(IAC) + chr$(WILL) + chr$(kECHO) + x enable for "hacking fun" &
chr$(IAC) + chr$(DONT) + chr$(kECHO) + ! &
chr$(IAC) + chr$(WONT) + chr$(TERM_TYPE) + ! &
chr$(IAC) + chr$(WONT) + chr$(WINDOW_SIZE) + ! &
chr$(IAC) + chr$(WONT) + chr$(TERM_TYPE) + ! &
chr$(IAC) + chr$(WONT) + chr$(TERM_SPEED) + ! &
chr$(IAC) + chr$(DONT) + chr$(TERM_TYPE) + ! &
chr$(IAC) + chr$(DONT) + chr$(WINDOW_SIZE) + ! &
chr$(IAC) + chr$(DONT) + chr$(TERM_TYPE) + ! &
chr$(IAC) + chr$(DONT) + chr$(TERM_SPEED) + ! &
chr$(IAC) + chr$(DONT) + chr$(kECHO) !
read_limit% = 1 ! do not read until timeout (one read)
case 3 ! wait for login prompt server
skip_send% = 1 !
case 4 !
send$ = username$ + cr ! send username
case 5 !
send$ = password$ + cr ! send password (in the clear)
timeout_limit% = 8 ! need bigger window for SET TERM/INQUIRE. On our system,
! we have 5 second delay before bringing terminal type
! up to VT200 (a minimum requirements)
case 6 !
send$ = "show time" + cr ! send dcl command
case 7 !
send$ = "logoutnow" + cr ! send dcl command
skip_receive% = 1 !
case 8 !
print "-i-all was well so finishing" !
goto shutdown !
!
! HTTP/1.0 SECTION
!
case 80 !
send$ = 'GET / HTTP/1.0' +cr+lf+ !&
'Accept: text/html' +cr+lf+ !&
cr+lf ! end of HTTP block
read_limit% = 3 ! do not read until timeout (3 reads max)
case 81 !
print "-i-all was well so finishing" !
goto shutdown !
!
! HTTP/1.1 SECTION
!
case 180 !
send$ = 'GET / HTTP/1.1' +cr+lf+ ! &
'Host: '+ address$ +cr+lf+ ! mandatory with HTTP/1.1 &
'User-Agent: Neil' +cr+lf+ ! optional &
'Accept: text/html' +cr+lf+ ! &
cr+lf ! end of HTTP block
case 181 !
print "-i-all was well so finishing" !
goto shutdown !
case else !
print "-e-unhandled send state so shutting down" !
goto shutdown !
end select !
!
if skip_send% = 0 then !
max_secs% = 5 ! max secs for send operation
gosub send_data !
end if !
if skip_receive% = 1 then !
goto next_state !
end if !
!===============================================================
! receive block
!===============================================================
same_recv_state:
look_for_prompts% = 0 ! init (every pass thru)
need_cr% = 0 !
expect$ = "" !
unexpect$ = "" !
!
select state% !
case 1 ! receive initial nvt from server
case 2 ! sent our nvt
case 3 ! receive final nvt handshake from server
expect$ = "USERNAME:" ! waiting for username prompt
case 4 !
expect$ = "PASSWORD" ! waiting for password prompt
case 5 !
unexpect$ = "USER AUTHORIZATION FAILURE" ! would only get this if login failed
look_for_prompts% = 1 ! the stuff we always see during login
case 6 !
!~~~ trace% = 1 x
case 80 !
case 180
case else !
print "-e-unhandled recv state so shutting down" !
goto shutdown !
end select !
!
max_secs% = 5 ! max time to recv
gosub recv_data !
!
if expect$ <> "" then ! if we expected something
if pos( buffer_uc$, edit$(expect$ ,32),1) > 0 ! if we found it
then !
print "-i-expected data detected (yay!)" !
else !
print "-e-expected data NOT detected (oops)" !
goto shutdown ! just exit (spaghetti)
end if !
end if !
!
if unexpect$ <> "" then ! if we did not expect something
if pos( buffer_uc$, edit$(unexpect$ ,32),1) > 0 !
then !
print "-e-unexpected data detected (oops)" !
resume shutdown ! just fix stack and exit (spaghetti)
else !
print "-i-unexpected data NOT detected (yay!)" !
end if !
end if !
!
if look_for_prompts% > 0 then ! we just do this during login
gosub response_detect ! did we need to send <cr>
goto same_recv_state if need_cr% > 0 ! jump if yes
end if !
!
goto next_state !
!
!===============================================================
! Write I/O buffer (event is timed so use $qio)
! entry: max_secs% = max secs b4 timeout
! send$ = data to send
!===============================================================
send_data:
gosub arm_timer !
w_buf = send$ ! move data to write buffer
print "-i-calling qio (sending "+ str$(len(send$)) +" chars) <<<<<"
rc% = sys$qio( tcp_event_flag% , ! Event flag &
channel_0 , ! Channel number &
IO$_WRITEVBLK , ! I/O function &
myIosb::quad_0 , ! I/O status block &
, ! &
, ! &
w_buf , ! P1 buffer &
len(send$) , ! P2 buffer length &
, ! P3 &
, ! P4 &
, ! P5 &
) ! P6
gosub process_event_flags !
!
! at this point either the TCP-EF or the TIMER-EF should be set
!
if (timer_ef_state% = 1) then ! if the TIMER-EF is set
print "-i-the tcp event timed out (so do something)" !
print "-e-Failed to write to socket" !
rc% = 2 !
goto rc_exit !
else !
if ((rc% and 1%) = 1%) then ! if the system call suceeded
rc% = myIosb::rc ! then use the rc of the operation
end if !
end if !
return
!===============================================================
! Read I/O buffer (event is timed so use $qio)
! entry: max_secs% = max secs b4 timeout
! expect$ = string to detect (when not blank)
!===============================================================
recv_data:
buffer$ = "" ! init
read_counter% = 0 ! init
timeout_count% = 0 ! init
!
read_loop: !
gosub arm_timer !
print "-i-calling qio (receiving) <<<<<" !
read_counter% = read_counter% + 1 !
rc% = sys$qio( tcp_event_flag% , ! Event flag &
channel_0 , ! Channel number &
IO$_READVBLK , ! I/O function &
myIosb::quad_0 , ! I/O status block &
, ! &
, ! &
r_buf , ! P1 buffer &
k_r_buf_size , ! P2 buffer length (declared size) &
, ! &
, ! &
, ! &
) !
gosub process_event_flags
!
! at this point either the TCP-EF or the TIMER-EF should be set
!
if (timer_ef_state% = 1) then ! if the TIMER-EF is set
print "-i-the tcp read timed-out" !
myIosb::xfer_count = 0 ! ensure nothing is extracted
else !
if ((rc% and 1%) = 1%) then ! if the system call suceeded
rc% = myIosb::rc ! then use the rc of the operation
end if !
end if !
!
if ((rc% and 1%) <> 1%) then !
print "-e-Failed to read to data" !
goto rc_exit !
end if !
junk% = myIosb::xfer_count ! how many bytes?
print "-i-read#: "+ str$(read_counter%) !
print "-i-bytes: "+ str$(junk%) +" characters" !
if (junk% > 0) then ! if we have any data in the buffer
if debug% >=3 then !
print "-i-text : "+ string$(70, ascii("v")) !
print left$(r_buf, junk%) !
print "-i-textz: "+ string$(70, ascii("^")) !
end if !
!
! on first read, display NVT options (see: RFC 854/855)
!
! IAC (interpret as command) 255
! WILL (option code) 251 Indicates the desire to begin performing...
! WON'T (option code) 252 Indicates the refusal to perform...
! DO (option code) 253 Indicates the request that the other party perform...
! DON'T (option code) 254 Indicates the demand that the other party perform...
!
! ff fb 01 = 255,251,1 (will echo)
! ff ff 03 = 255,251,3 (will suppress-go-ahead)
!
if ((read_counter% = 1) and (state% <= 2) and (debug% >=2)) or &
(trace% > 0) or &
(debug% >=3) &
then !
for i% = 1 to min(junk%, 30) !
print "-i-debug-byte: "+ format$(i%,"##### ") + format$(asc(mid$(r_buf,i%,1)),"### ");
select asc(mid$(r_buf,i%,1)) !
case 32 to 126 ! if printable
print mid$(r_buf,i%,1) ! then show it
case else !
print "." ! else a dot
end select !
next i% !
end if !
!
! VMS-BASIC strings (at least in 2012) must never exceed 32767 bytes even on Alpha and Itanium
!
if (len(buffer$) + junk%) > 32767 then ! do we have room to append?
print "-w-oops, a BASIC string was about to overflow (data discarded)"
else !
buffer$ = buffer$ + left$(r_buf, junk%) ! append data
max_secs% = 1 ! now go faster
timeout_count% = 0 ! reset timeout counter
goto read_loop if read_counter% < read_limit% ! loop for more data
end if !
else !
timeout_count% = timeout_count% + 1 !
if (read_counter% < read_limit%) and ! if we have not exceeded our read limit &
(timeout_count% < timeout_limit%) ! and not exceeded our timeout limit
then !
max_secs% = 1 ! now go faster
goto read_loop !
end if !
end if !
!
if debug% >= 0 then !
print "-i-buffer : " + string$(70, ascii("V")) !
print buffer$ !
print "-i-bufferz: " + string$(70, ascii("^")) !
end if !
!
! cleanup the buffer for quick searches
!
buffer_uc$ = edit$(buffer$ ,128+32+16+8) ! trailing,ucase,compress,leading
!
return
!===============================================================
! response_detect
!===============================================================
response_detect:
need_cr% = 0 ! init <cr> request
junk$ = edit$(buffer$ ,128+32+16+8) ! init for prompt test
need_cr% = 1 if pos(junk$, "PRESS ENTER" , 1)>0
need_cr% = 1 if pos(junk$, "HIT ENTER" , 1)>0
need_cr% = 1 if pos(junk$, "PRESS <ENTER>" , 1)>0 ! eg. Press <enter> to continue...
need_cr% = 1 if pos(junk$, "HIT <ENTER>" , 1)>0 ! eg. Hit <enter> to continue...
need_cr% = 1 if pos(junk$, "PRESS RETURN" , 1)>0
need_cr% = 1 if pos(junk$, "HIT RETURN" , 1)>0
need_cr% = 1 if pos(junk$, "PRESS <RETURN>" , 1)>0
need_cr% = 1 if pos(junk$, "HIT <RETURN>" , 1)>0
need_cr% = 1 if pos(junk$, "PRESS CR" , 1)>0
need_cr% = 1 if pos(junk$, "HIT CR" , 1)>0
need_cr% = 1 if pos(junk$, "PRESS <CR>" , 1)>0
need_cr% = 1 if pos(junk$, "HIT <CR>" , 1)>0
!
junk1% = pos(junk$,"SET ",1) ! eg. SET TERMINAL WIDTH 132 (Y/N,DEFAULT=N)
if junk1% > 0 then !
!~~~ junk2% = pos(junk$,"(Y/N",junk1%+1) x
!~~~ need_cr% = 1 if (junk2% > 0) and (junk2% - junk1%) < 30 x
junk2% = pos(junk$,"(Y",junk1%+1) ! this will take care of variations
need_cr% = 1 if (junk2% > 0) and (junk2% - junk1%) < 30 !
end if !
!
junk1% = pos(junk$,"TEST ",1) ! eg. TEST PRINT QUEUES (Y/N,DEFAULT=N)
if junk1% > 0 then !
!~~~ junk2% = pos(junk$,"(Y/N",junk1%+1) x
!~~~ need_cr% = 1 if (junk2% > 0) and (junk2% - junk1%) < 30 x
junk2% = pos(junk$,"(Y",junk1%+1) ! this will take care of variations
need_cr% = 1 if (junk2% > 0) and (junk2% - junk1%) < 30 !
end if !
!
if need_cr% = 1 then !
print "-i-a DCL prompt was detected so sending <cr>" !
send$ = cr !
gosub send_data !
need_cr% = 2 ! show request sent
end if !
return
!===============================================================
! Shut down the socket (optional)
!===============================================================
shutdown:
rc% = sys$qiow( tcp_event_flag% , ! &
channel_0 , ! &
(IO$_DEACCESS or IO$M_SHUTDOWN) , ! &
myIosb::quad_0 , ! &
, , ! &
, , , ! &
TCPIP$C_DSC_ALL, ! P4 Discard all packets &
, ) !
if ((rc% and 1%) = 1%) then !
rc% = myIosb::rc !
end if !
if ((rc% and 1%) <> 1%) then !
print "-e-Failed to shut down the socket" !
end if !
!
! Close the sockets
!
10000 rc% = sys$qiow( tcp_event_flag% , ! &
channel_0 , ! &
IO$_DEACCESS , ! &
myIosb::quad_0 , ! &
, , ! &
, , , , , ) !
if ((rc% and 1%) = 1%) then !
rc% = myIosb::rc !
end if !
if ((rc% and 1%) <> 1%) then !
print "-e-Failed to close the socket." !
end if !
!
! Deassign the TCPIP device channels
!
rc% = sys$dassgn(channel_0)
if ((rc% and 1%) <> 1%) then
print "-e-Failed to deassign the channel"
end if
!
gosub cleanup
!
goto fini
!===============================================================
! <<< arm a timer to expire 'x' time from now >>>
! entry: max_secs% (desired delay of 1-59 seconds)
!===============================================================
arm_timer:
junk$ = format$(max_secs%,"<0>#") ! eg. 01-59
junk$ = "0 00:00:"+ junk$ ! eg. "0 00:00:10"
rc% = sys$bintim(junk$, DeltaQuad ) ! init delta time ('x' time from now)
print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
!
rc% = sys$setimr(timer_event_flag%, DeltaQuad by ref,,,) ! now use it to schedule a wake up
print "-e- sys$setimr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
return !
!===============================================================
! process event flags
! caveat: rc% must be preserved so use junk%
!===============================================================
process_event_flags:
!
! note: for the SYS$WFLOR call to work, both event flags must be in the same event flag cluster.
! The first parameter is only used to determine which event flag cluster to test.
! The second parameter (mask) contains bits representing event flags within that cluster
!
mask% = get_timer_bit_vector( tcp_event_flag%) ! insert vector 1 into mask
mask% = mask% or get_timer_bit_vector(timer_event_flag%) ! insert vector 2 into mask
!
! <<< wait for either the 'TCP event flag' or the 'TIMER event flag' to change state >>>
!
junk% = sys$wflor( tcp_event_flag%, mask%) ! wait for a response from one of two flags
print "-e- sys$waitfr rc: "+ str$(junk%) if ((junk% and 1%) <> 1%)
!
! which event flag is set? TCP or TIMER?
!
junk% = sys$readEF(tcp_event_flag%, discard%) ! test TCP event flag
select junk% !
case SS$_WASCLR !
tcp_ef_state% = 0 !
case SS$_WASSET !
tcp_ef_state% = 1 !
case else !
print "-e- sys$readef-tcp rc: "+ str$(junk%) !
tcp_ef_state% = 0 !
end select !
!~~~ print "-i- TCP EF State : ";str$(tcp_ef_state%) !
!
junk% = sys$readEF(timer_event_flag%, discard%) ! test TIMER event flag
select junk% !
case SS$_WASCLR !
timer_ef_state% = 0 !
case SS$_WASSET !
timer_ef_state% = 1 !
case else !
print "-e- sys$readef-timer rc: "+ str$(junk%) !
timer_ef_state% = 0 !
end select !
!~~~ print "-i- Timer EF State: ";str$(timer_ef_state%) !
!
! we really should only do this next stub on tcp activity
!
junk% = sys$cantim(,) ! cancel all timer requests
if (junk% and 1%) <> 1% then !
print "-e-cantim rc: "+ str$(junk%) !
end if !
!
! we really should only do this next stub on timeout
!
junk% = sys$cancel(channel_0) ! cancel all pending requests on this channel
if (junk% and 1%) <> 1% then !
print "-e-cancel rc: "+ str$(junk%) !
end if !
return !
!===============================================================
! cleanup
! caveat: rc% must be preserved so use junk%
!===============================================================
cleanup:
if tcp_event_flag% <> 0 then ! if allocated
junk% = lib$free_EF( tcp_event_flag% ) ! allocate an event flag
tcp_event_flag% = 0 !
end if !
!
if timer_event_flag% <> 0 then ! if allocated
junk% = lib$free_EF( timer_event_flag% ) ! allocate another event flag
timer_event_flag% = 0 !
end if !
!
return !
!===============================================================
! <<< error trap >>>
!===============================================================
31000 trap:
print
print "=== Common Error Trap ===" !
print "error num : "+ str$(err) +" on line "+ str$(erl) !
print "error text: "+ ert$(err) !
rc% = 2 ! vms-e-
resume rc_exit ! fix stack
!===============================================================
! <<< adios >>>
!===============================================================
fini: !
rc% = 1 ! vms-s-
!
! rc% must be set up before this point
!
rc_exit:
gosub cleanup !
print "-i-program exiting with status: "+str$(rc%) !
32000 end program rc% !
!
!####################################################################################################
!
!----------------------------------------------------------------------------------------------------
! this BASIC function replaces the C-MACRO 'hton' (which is nothing more than a byte swap)
!
! Notes:
! 1. 'hton' means host-to-network byte order ('s' means 'short' or 'word')
! 2. both VAX + Alpha are little-endian architectures but network order requires that we send
! ports (and IP addresses) MSB first
!----------------------------------------------------------------------------------------------------
32010 function word htons(word incoming_data by ref) !
option type=explicit
!
map(my_map)word bits_F0 ! Bits F->0
map(my_map)byte bits_70 , ! Bits 7->0 &
bits_F8 ! Bits F->8
declare byte temp%
!
bits_F0 = incoming_data !
temp% = bits_70
bits_70 = bits_F8
bits_F8 = temp%
htons = bits_F0 ! prepare to exit the function
!
end function
!----------------------------------------------------------------------------------------------------
! peek LONG
!----------------------------------------------------------------------------------------------------
32020 function long my_peek_L(long incoming by ref) !
option type=explicit !
!
my_peek_L = incoming !
end function !
!----------------------------------------------------------------------------------------------------
! peek WORD
!----------------------------------------------------------------------------------------------------
32030 function long my_peek_W(word incoming by ref) !
option type=explicit !
!
declare long temp% !
temp% = incoming !
temp% = abs( temp%) if temp% < 0% !
my_peek_W = temp% !
end function !
!----------------------------------------------------------------------------------------------------
! peek BYTE
!----------------------------------------------------------------------------------------------------
32040 function long my_peek_B(byte incoming by ref) !
option type=explicit !
!
declare long temp% !
temp% = incoming !
temp% = abs( temp%) if temp% < 0% !
my_peek_B = temp% !
end function !
!
!----------------------------------------------------------------------------------------------------
! long_to_byte
!
! Notes:
! 1. when jamming bytes (as is the case with the octets in an I/P address) we may wish to poke an
! unsigned byte like 192 but all bytes in BASIC are signed so this little function will do the
! conversion for us with very little fuss.
! 2. remember that we are little-endian
!----------------------------------------------------------------------------------------------------
32050 function byte long_to_byte(long incoming by ref) !
option type=explicit
!
map(my_map)long long0
map(my_map)byte byte0, ! LSB &
byte1, ! &
byte2, ! &
byte3 ! MSB
!
long0 = incoming !
long_to_byte = byte0 !
end function !
!======================================================================
! get timer bit vector
! (see OpenVMS system systevices documentation for "sys$wflor")
!
! notes: cluster event flags
! 0 00- 31
! 1 32- 63
! 2 64- 95
! 3 96-127
!======================================================================
32060 function long get_timer_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 ! this code will avoid an integer overflow
case 31 ! need to set bit #31
! 33222222222211111111110000000000
! 10987654321098765432109876543210
get_timer_bit_vector = B"10000000000000000000000000000000"L ! so return this
case else !
get_timer_bit_vector = (2% ^ temp) ! else return this
end select
!
end function ! get_timer_bit_vector