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					!
		    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