OpenVMS Source-Code Demos

TCPIP$TCP_CLIENT_QIO_2014C

1000	%title "tcpip$tcp_client_qio_2014c_xxx.bas"
	%ident "102.1"
	declare string constant k_program = "tcpip$tcp_client_qio_2014c"
	!========================================================================================================================
	! title      : tcpip$tcp_client_qio_2014c
	! author     : Neil Rieck ( http://neilrieck.net )
	!	     : (c) copyright 1999,2014  Neil Rieck
	!            : Waterloo, Ontario, Canada.
	! created    : 2014-08-04
	! references : HP TCP/IP Services for OpenVMS
	!              Sockets API and System Services Programming (manual: BA548-90002)
	! notes      : 1. stack programming on VMS and OpenVMS can be done by "Sockets API" (easier) or
	!		  "VMS System Services" (harder; a lot like building an Interociter)
	!	       2. A and B client demos employ sys$qiow (synchronous) via VMS System Services
	!	       3. The C client demo employs sys$qio (asynchronous) to provide even more control
	!	       4. Lots of in-line code in this demo. Normally it would be moved to subroutines or external functions.
	! OS         : OpenVMS (Alpha or Itanium) or VMS on VAX
	! Stack      : TCP/IP Services V5.0 or higher (but should work with any stack after a few mods)
	! compile    : $ bas	tcpip$tcp_client_qio_2014c_102.bas
	! link       : $ link	tcpip$tcp_client_qio_2014c_102
	! history    :
	! ver who when   what
	! --- --- ------ --------------------------------------------------------------------------------------------------------
	! 100 NSR 140804 0. started with TCPIP$TCP_CLIENT_QIO_2014B_100.BAS (synchronous)
	!		 1. function "my_gethostbyname" now contains asynchronous i/o (changed qiow to qio then added timers)
	! 101 NSR 140805 0. started with TCPIP$TCP_CLIENT_QIO_2014C_101.BAS
	!		 1. most of the main body now contains asynchronous i/o (changed qiow to qio then added timers)
	! 102 NSR 140814 1. annotation and code cleanup
	!========================================================================================================================
	option type=explicit							! formal coding
	set no prompt								!
	on error goto common_trap						! old school trapping for this demo
	!
	!	home brewed code
	!
	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 parse_dest(string,string)			!
	external long function my_gethostbyname(string by desc, long dim() by ref, long)
	external long function get_ef_bit_vector(long)				! required for used with SYS$WFLOR
	!
	!	system references
	!
	%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 "$efndef"	%from %library "sys$library:basic$starlet"	! efn$
	%include "lib$routines"	%from %library "sys$library:basic$starlet"	! lib$
	%include "$libdef"	%from %library "sys$library:basic$starlet"	! eg. lib$_normal
	%include "$iledef"      %from %library "sys$library:basic$starlet"      ! ile3$ (Item List Entry 3 structures)
!~~~	%include "$iosbdef"     %from %library "sys$library:basic$starlet"	x iosb$ (iosb structures)
	!
	!	I need the following iosb to get around a limitation found in the BASIC version of starlet
	!	(the library definition of sys$qio requires a quad datatype for iosb)
	!
	!	question : How did I know?
	!	answer   : Hacking
	!	reference: http://neilrieck.net/docs/openvms_notes_hacking_starlet.html
	!
	record my_iosb_rec							!
	    variant								!
		case								! vanilla
		    group one							!
			word		iosb$w_status				!
			word		iosb$w_bcnt				!
			long		iosb$l_dev_depend			!
		    end group							!
		case								! used in sys$getqui
		    group two							!
			long		iosb$l_getxxi_status			!
			long		iosb$l_reserved				!
		    end group							!
		case								! used to satisfy the compiler
		    group three							!
			basic$quadword	iosb$quad				!
		    end group							!
	    end variant								!
	end record								!
	%include "sys$library:TCPIP$INETDEF.BAS"				! need this for various inet constants etc.
	!
	record my_sockchar_rec							! socket characteristics (record definition)
	    word	sc_prot							! protocol
	    byte	sc_type							! type
	    byte	sc_af							! address family
	end record 								!
	!
	record my_itmlst2_rec							! item-list 2 descriptor
	    word	il2_length						! length
	    word	il2_type						!
	    long	il2_address						!
	end record								!
	!
	!	named constants
	!
	declare	long constant	TCPBUFSIZ	= 8192				! buffer size (no larger than 32767)
	declare long constant	USRBUFSIZ	= 512				! user input buffer size
	declare word constant	SERV_PORTNUM	= 80				! server port number (80=http)
	!
	!	declare variables
	!
	map(recv)string	buffer_r = TCPBUFSIZ					!
	map(xmit)string buffer_w = TCPBUFSIZ					!
	!
	declare my_iosb_rec	iosb						! i/o status block
	declare my_sockchar_rec conn_sockchar					! connection socket characteristics buffer
	declare SOCKADDRIN	serv_addr					! server socket address inet structure
	declare my_itmlst2_rec	serv_itemlst					!
	declare word		conn_channel					!
	declare long		mask						!
	declare quad		junk64						!
	declare basic$QuadWord	DeltaQuad					! for sys$bintim
	declare string		msg$						!
	declare string		inet_device					!
	declare string		dest$						!
	declare string		path$						!
	declare string		octet$(3)					!
	declare long		octet(3)				,	&
				ip_address				,	&
				rc					,	&
				bytes_w					,	&
				readcount				,	&
				bytes_r					,	&
				bytes_r_total				,	&
				http%					,	&
				junk%					,	&
				junk1					,	&
				junk2					,	&
				dest_kind				,	&
				i%					,	&
				tcp_ef					,	! tcpip event flag		&
				tcp_ef_state				,	! tcpip event flag state	&
				tmr_ef					,	! timer event flag		&
				tmr_ef_state					! timer event flag state
	!
	!=======================================================================
	!	main
	!=======================================================================
2000	main:
	print
	print "-i-program: "+ k_program
	print "-i-this program will connect to a website on port "+ str$(SERV_PORTNUM)
	!
	!	initialize variables
	!
	inet_device			= "TCPIP$DEVICE:"			!
	!
	conn_sockchar::sc_prot		= TCPIP$C_TCP				! init (local) connection socket
	conn_sockchar::sc_type		= TCPIP$C_STREAM			!
	conn_sockchar::sc_af		= TCPIP$C_AF_INET			!
	!
	serv_addr::SIN$W_FAMILY		= TCPIP$C_AF_INET			! init (remote) connection socket
	serv_addr::SIN$W_PORT		= htons(SERV_PORTNUM)			!
	!
	get_dest:
	print "-i-Menu:"
	print "   1 = 142.180.221.226"
	print "   2 = kawc96.on.bell.ca"
	print "   Q = quit (default)"
	print "   or anything else (eg. www3.sympatico.ca         )"
	print "                    (eg. neilrieck.net/)"
	print
	print "-?-destination? ";						!
	input dest$								!
	dest$ = edit$(dest$,2)							! no white space
	select dest$								!
	    case "1"								!
		dest$ = "142.180.221.226"					!
	    case "2"								!
		dest$ = "kawc96.on.bell.ca"					!
	    case else								!
		goto fini	if len(dest$)<=1 				! "Q","q"
	end select								!
	!
3000	dest_kind = parse_dest(dest$, path$)					! all three params will be modified
	!
	if dest_kind = 0 then							!
	    print "-e-error, your input data is not useable"			!
	    goto get_dest							!
	end if									!
	!-----------------------------------------------------------------------
	if dest_kind = 1 then							! we "know" this is an IPv4 address
	    print "-i-you entered an IPv4 address"				!
	    http% = 0								! send HTTP/1.0 request
	    junk1 = 0								! init for parse
	    for i% = 0 to 3							! sc
		junk2 = pos(dest$, ".", junk1+1)				!
		junk2 = len(dest$)+1	if junk2 = 0				!
		octet$(i%) = seg$(dest$,junk1+1,junk2-1)			!
		junk1 = junk2							! reference pt moves along
	    next i%								!
	    when error in							!
		junk64	= integer(octet$(0)) * 16777216	+ 			! 2^24			&
			  integer(octet$(1)) * 65536	+ 			! 2^16			&
			  integer(octet$(2)) * 256	+ 			! 2^8			&
			  integer(octet$(3))					! 2^0
	    use									!
		junk64 = 0							!
	    end when								!
	    if junk64 = 0 then							!
		print "-e-error:";err;"during data conversion"			!
		goto get_dest							!
	    end if								!
	end if									!
	!-----------------------------------------------------------------------
	if dest_kind = 2 then							! we think this might be a dns name
	    print "-i-you entered a dns name"					!
	    http% = 1								! send HTTP/1.1 request
	    rc = my_gethostbyname(dest$, octet(), 1)				! magic happens here :-)
	    if ((rc and 7%) <> 1) then						!
		print "-e-dns lookup failed with status:";rc			!
		goto get_dest							!
	    end if								!
	    when error in							!
		junk64	= octet(0) * 16777216	+ 				! 2^24			&
			  octet(1) * 65536	+ 				! 2^16			&
			  octet(2) * 256	+ 				! 2^8			&
			  octet(3)						! 2^0
	    use									!
		junk64 = 0							!
	    end when								!
	    if junk64 = 0 then							!
		print "-e-error:";err;"during data conversion"			!
		goto get_dest							!
	    end if								!
	end if									!
	!-----------------------------------------------------------------------
	!	prepare to connect
	!
	!	allocate some event flags
	!	create a socket (open a connetion to the network device)
	!	open a connection to the network device)
	!-----------------------------------------------------------------------
	gosub allocate_event_flags
	!
	!	init some network stuff
	!
	ip_address			= qtol (junk64)				!
	serv_addr::SIN$L_ADDR		= htonl (ip_address)			! eg. 142.180.221.226
	!
	serv_itemlst::il2_length	= SIN$K_LENGTH				! need size of serv_addr (SOCKADDRIN)
	serv_itemlst::il2_type		= TCPIP$C_SOCK_NAME			!
	serv_itemlst::il2_address	= loc(serv_addr)			! need addr of serv_addr
	!
	!	create socket (part 1/2)
	!
4000	print "-i-creating socket (assign)"					!
	rc = sys$assign(inet_device, conn_channel,,)				!
	if ((rc and 7%) <> 1) then						!
	    print "-e-error:";rc;"while assigning channel to TCPIP device"	!
	end if									!
	!
	!	create socket (part 2/2)
	!
4010	print "-i-creating socket (qiow)"					! synchronous (no point changing to async)
	rc = sys$qiow(	EFN$C_ENF,		! event flag			&
			conn_channel,		! i/o channel			&
			IO$_SETMODE,		! i/o function code		&
			iosb::iosb$quad,,,	! i/o status block		&
			conn_sockchar,,,,,)	! p1 - socket characteristics
	if ((rc and 7%) = 1) then						! if the system call queued properly
	   rc = 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									!
	!-----------------------------------------------------------------------
	!	connect to server (async)
	!
	!	arm 10-second timer
	!	que async request
	!	wait for one of the flags
	!	test
	!-----------------------------------------------------------------------
4020	declare string constant	k_delay010 = "0 00:00:10"			! prep for a 10 second timeout
	rc = sys$bintim(k_delay010, DeltaQuad )					! compute delta time
	print "-e-sys$bintim rc: "+ str$(rc) if ((rc and 1%) <> 1)		! oops, didn't work
	!
	print "-i-arming timer associated with ef:";tmr_ef
	rc = sys$setimr(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-connecting to server via qio associated with ef:";tcp_ef	! async (no wait)
	rc = sys$qio(	tcp_ef,			! event flag			&
			conn_channel,		! i/o channel			&
			IO$_ACCESS,		! i/o function code		&
			iosb::iosb$quad,,,,,	! i/o status block		&
			loc(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
	!
	mask =		get_ef_bit_vector(tcp_ef)				! insert vector 1 into mask
	mask = mask or	get_ef_bit_vector(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"				!
	rc = sys$wflor( tcp_ef, 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(tcp_ef, junk%)						! test TCP event flag
	select rc								!
	    case SS$_WASCLR							!
		tcp_ef_state = 0						!
	    case SS$_WASSET							!
		print "-i-tcp ef was set"					!
		tcp_ef_state = 1						!
	    case else								!
		print "-e-sys$readef-tcp rc: "+ str$(rc)			!
	end select								!
	!
	rc = sys$readEF(tmr_ef, junk%)						! test TIMER event flag
	select rc								!
	    case SS$_WASCLR							!
		tmr_ef_state = 0						!
	    case SS$_WASSET							!
		print "-w-timer ef was set (oops)"				!
		tmr_ef_state = 1						!
	    case else								!
		print "-e-sys$readef-timer rc: "+ str$(rc)			!
	end select								!
	!
	if (tcp_ef_state = 1) then						! tcp fired so cancel timer
	    junk% = sys$cantim(,)						!
	end if									!
	!
	if (tmr_ef_state = 1)	then						! timer fired so cancel i/o
	    print "-e-did not connect in time"					!
	    junk% = sys$cancel(conn_channel)					!
	    rc = 2								! vms-e-
	    goto rc_exit							!
	end if									!
	!
	!	At this point the qio has completed. so test operational status (iosb)
	!
	rc = 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"					!
	end if									!
	!-----------------------------------------------------------------------
	!	send a message to retrieve the default web page
	!
	!	eg. examples:	1	GET / HTTP/1.0
	!
	!			2	GET /n.rieck HTTP/1.0
	!
	!			3	GET /n.rieck HTTP/1.1
	!				host: www3.sympatico.ca
	!
	!	caveat: websevers sitting behind load balancers, or webservers in the cloud,
	!		usually will not accept requests employing HTTP/1.0
	!-----------------------------------------------------------------------
	path$ = "/" if path$ = ""						!
	if http% = 0 then							!
	    print "-i-sending this HTTP 1.0 request:"
	    msg$ = "GET "+ path$ +" HTTP/1.0"	+ cr + lf +			&
			cr + lf							! blank line marks end of HTTP block
	else									!
	    print "-i-sending this HTTP 1.1 request:"
	    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$
	bytes_w = len(msg$)							! determine the data length
	buffer_w = msg$								! xref data to buffer for qio
	!
	rc = sys$bintim(k_delay010, DeltaQuad )					! compute delta time
	print "-e-sys$bintim rc: "+ str$(rc) if ((rc and 1%) <> 1)		! oops, didn't work
	!
	print "-i-arming timer associated with ef:";tmr_ef
	rc = sys$setimr(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-sending to server via qio associated with ef:";tcp_ef		! async (no wait)
4030	rc = sys$qio(	tcp_ef,			! event flag			&
			conn_channel,		! i/o channel			&
			IO$_WRITEVBLK,		! i/o function code		&
			iosb::iosb$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									!
	!
	mask =		get_ef_bit_vector(tcp_ef)				! insert vector 1 into mask
	mask = mask or	get_ef_bit_vector(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"				!
	rc = sys$wflor( tcp_ef, 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(tcp_ef, junk%)						! test TCP event flag
	select rc								!
	    case SS$_WASCLR							!
		tcp_ef_state = 0						!
	    case SS$_WASSET							!
		print "-i-tcp ef was set"
		tcp_ef_state = 1						!
	    case else								!
		print "-e-sys$readef-tcp rc: "+ str$(rc)			!
	end select								!
	!
	rc = sys$readEF(tmr_ef, junk%)						! test TIMER event flag
	select rc								!
	    case SS$_WASCLR							!
		tmr_ef_state = 0						!
	    case SS$_WASSET							!
		print "-w-timer ef was set (oops)"				!
		tmr_ef_state = 1						!
	    case else								!
		print "-e-sys$readef-timer rc: "+ str$(rc)			!
	end select								!
	!
	if (tcp_ef_state = 1) then						! tcp fired so cancel timer
	    junk% = sys$cantim(,)						!
	end if									!
	!
	if (tmr_ef_state = 1)	then						! timer fired so cancel i/o
	    print "-e-did not connect in time"					!
	    junk% = sys$cancel(conn_channel)					!
	    rc = 2								! vms-e-
	    goto rc_exit							!
	end if									!
	!
	!	At this point the qio has completed so test the operational status (iosb)
	!
	rc = iosb::iosb$w_status						! test the operational status
	if ((rc and 7%) <> 1) then						!
	    print "-e-error:";rc;"while sending to server"			!
	    goto rc_exit							!
	else									!
	    print "-i-message sent"						!
	end if									!
	!-----------------------------------------------------------------------
	!	read the response
	!-----------------------------------------------------------------------
4040	print "-i-receiving data"
	readcount = 0								! init loop counter
	bytes_r_total = 0							!
	!
	read_loop:
	bytes_r = 0								! init
	readcount =  readcount + 1
	print "-i-receiving count:";readcount
	print "   -------------------"
	rc = sys$bintim(k_delay010, DeltaQuad )					! compute delta time
	print "-e-sys$bintim rc: "+ str$(rc) if ((rc and 1%) <> 1)		! oops, didn't work
	!
	print "-i-arming timer associated with ef:";tmr_ef			!
	rc = sys$setimr(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-connecting to server via qio associated with ef:";tcp_ef	! async (no wait)
	rc = sys$qio(	tcp_ef,			! event flag			&
			conn_channel,		! i/o channel			&
			IO$_READVBLK,		! i/o function code		&
			iosb::iosb$quad,,,	! i/o status block		&
			buffer_r,		! p1 buffer address		&
			TCPBUFSIZ,,,,)		! p2 buffer length (recv buffer size)
	if ((rc and 7%) <> 1) then						! if system call failed (never happens)
	    junk% = sys$cantim(,)						! cancel timers and bail
	    goto rc_exit							!
	end if									!
	!
	mask =		get_ef_bit_vector(tcp_ef)				! insert vector 1 into mask
	mask = mask or	get_ef_bit_vector(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"				!
	rc = sys$wflor( tcp_ef, 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(tcp_ef, junk%)						! test TCP event flag
	select rc								!
	    case SS$_WASCLR							!
		tcp_ef_state = 0						!
	    case SS$_WASSET							!
		print "-i-tcp ef was set"					!
		tcp_ef_state = 1						!
	    case else								!
		print "-e-sys$readef-tcp rc: "+ str$(rc)			!
	end select								!
	!
	rc = sys$readEF(tmr_ef, junk%)						! test TIMER event flag
	select rc								!
	    case SS$_WASCLR							!
		tmr_ef_state = 0						!
	    case SS$_WASSET							!
		print "-w-timer ef was set (oops)"				!
		tmr_ef_state = 1						!
	    case else								!
		print "-e-sys$readef-timer rc: "+ str$(rc)			!
	end select								!
	!
	if (tcp_ef_state = 1) then						! tcp fired so cancel timer
	    junk% = sys$cantim(,)						!
	end if									!
	!
	if (tmr_ef_state = 1) then						! timer fired so cancel i/o
	    print "-e-did not read anything in time"				!
	    junk% = sys$cancel(conn_channel)					!
	    rc = 2								! vms-e-
	    goto rc_exit							!
	end if									!
	!
	!	At this point the qio has completed.
	!	Now we test the status word assiociated with the iosb
	!
	rc = iosb::iosb$w_status						! test the operational status
	if ((rc and 7%) <> 1) then						!
	   select rc								!
		case 8428							! this fatal error is normal for the web
		   print "-w-status:";rc;"network partner disconnected logical link"
		case else							!
		   print "-e-error:";rc;"while reading from server"		!
	   end select								!
	else									!
	   bytes_r = iosb::iosb$w_bcnt						! get the actual number of bytes xfer'd
	   if 1=0 then								! if we want more information after each $qio
		print
		print "----------------------"
		print "xfer count:";bytes_r
		print "----------------------"
		sleep 1
	   end if
	   print left$(buffer_r,bytes_r)					! output that amount
	   bytes_r_total = bytes_r_total + bytes_r				! also add to total
	   if (bytes_r > 0)				and			! if data was present		&
	      (readcount < 150) then						! and we're not too crazy
		goto read_loop		 					! yeah, I know, bad form (but this is just a demo)
	   end if								!
	end if									!
	print "-i-total bytes received:";bytes_r_total
	!
	!	shutdown
	!
	print "-i-shutting down the socket"					! no point changing to async
	rc = sys$qiow(	EFN$C_ENF,			! event flag		&
			conn_channel,			! i/o channel		&
			IO$_DEACCESS or IO$M_SHUTDOWN,	! i/o function code	&
			iosb::iosb$quad,,,,,,		! i/o status block	&
			TCPIP$C_DSC_ALL,,)		! p5
	if ((rc and 7%) = 1) then						! if system call queued properly
	    rc = iosb::iosb$w_status						! then check the operational result
	end if									!
	if ((rc and 7%) <> 1) then						!
	    print "-e-error:";rc;"during socket shutdown"			!
	end if									!
	!
	!	close the socket
	!
	print "-i-closing the socket"						! no point changing to async
	rc = sys$qiow(	EFN$C_ENF,			! event flag		&
			conn_channel,			! i/o channel		&
			IO$_DEACCESS,			! i/o function code	&
			iosb::iosb$quad,		! i/o status block	&
			,,,,,,,)			!
	if ((rc and 7%) = 1) then						! if system call queued properly
	   rc = iosb::iosb$w_status						! then check the operational result
	end if									!
	if ((rc and 7%) <> 1) then						!
	   print "-e-error:";rc;"during socket shutdown"			!
	end if									!
	!
	!	deassign the socket
	!
	rc = sys$dassgn(conn_channel)						!
	if ((rc and 7%) <> 1) then						!
	   print "-e-error:";rc;"during deassign"				!
	end if									!
	!
	goto fini								! that's all she wrote...
	!
	!	<<< allocate event flags >>>
	!
	allocate_event_flags:
	if tcp_ef = 0 then							! if not yet allocated
	    rc = lib$get_EF( 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 tmr_ef = 0 then							! if not yet allocated
	    rc = lib$get_EF( 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									!
	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-
	goto fini_common							!
	!
	rc_exit:								!
	print "-i-in abnormal exit area"					!
	!
	fini_common:
	print "-i-adios..."							!
32000	end program rc								! <<<--- return exit code to DCL
	!
	!########################################################################################################################
	!	external functions
	!########################################################################################################################
	!
	!=======================================================================
	!	host to network short
	!	OpenVMS is little endian but the network is big endian
	!=======================================================================
32010	function word htons(word inbound)					!
	option type=explicit							!
	!
	map(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
	!	OpenVMS is little endian but the network is big endian
	!=======================================================================
32020	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)
	!=======================================================================
32030	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)"	!
	end if									!
	end function								!
	!
	!=======================================================================
	!	<<< parse_dest >>>
	!
	! examples:
	! 1	input:		"142.180.221.226"		??
	!	return:	1	"142.180.221.226"		""
	! 2	input:		"www3.sympatico.ca"		??
	!	return: 2	"www3.sympatico.ca"		""
	! 3	input:		"142.180.221.226/n.rieck/"	??
	!	return: 1	"142.180.221.226"		"/n.rieck/"
	! 4	input:		"neilrieck.net/"	??
	!	return: 2	"www3.sympatico.ca"		"/n.rieck/"
	! 5	input:		"abcd"				??
	!	return: 0	""				""
	! 6	input:		"http://www3.sympatico.ca"	??
	!	return: 0	""				""
	!		+------ 0 = unusable address
	!		+------ 1 = IP address
	!		+------ 2 = dns name
	!=======================================================================
32040	function long parse_dest(string dest$, string path$)			!
	option type=explicit							!
	declare long	dots		,&
			nums		,&
			alph		,&
			othe		,&
			slash_pos	,&
			i%		,&
			result
	!-----------------------------------------------------------------------
	main:
	result = 0								! assume the worst (unusable)
	!
	slash_pos = pos(dest$, "/", 1)						! any slashes here?
	if slash_pos > 0 then							! yes
	    path$ = right$(dest$,slash_pos)					! do this first
	    dest$ = left$( dest$,slash_pos - 1)					!
	else									! no
	    path$ = ""								!
	end if									!
	!
	for i% = 1 to len(dest$)						! prescan the destination
	    select mid$(dest$, i%, 1)						!
		case "."							!
		    dots = dots + 1						!
		case "0" to "9"							!
		    nums = nums + 1						!
		case "a" to "z"							!
		    alph = alph + 1						!
		case else							!
		    othe = othe + 1						!
	    end select								!
	next i%									!
	!
	goto data_unusable	if othe > 0					! we can't use this data
	!
	!	eg. "142.180.221.226"
	!
	if dots=3 and nums>=4 and alph=0 then					! hey, might be IP4
	    result = 1								!
	    goto function_exit							!
	end if									!
	!
	!	eg. "bell.ca" or "www3.sympatico.ca"
	!
	if dots>0 and alph>=3 then						! hey, might be a dns
	    result = 2								!
	    goto function_exit							!
	end if									!
	!
	data_unusable:
	dest$	= ""								!
	path$	= ""								!
	result	= 0								!
	!
	!	result must be set before this point
	!
	function_exit:								!
	parse_dest = result							!
	end function								!
	!

	!=======================================================================
	! <<< my 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
	!=======================================================================
32050	function long my_gethostbyname(string dns_name$, long octets() by ref, long debug)
	option type=explicit							! cuz tricks are for kids
	print "-i- >>> function: my_gethostbyname()"	if debug > 0		!
	!
	!	<<< 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 "$dscdef"      %from %library "sys$library:basic$starlet"	! descriptor stuff
!~~~	%include "sys$library:ucx$inetdef.bas"					x ucx defs   (for tcpip <  v5.0)
	%include "sys$library:tcpip$inetdef.bas"				! tcpip defs (for tcpip >= v5.0)
!~~~	%include "$iosbdef"	%from %library "sys$library:basic$starlet"	x iosb$ (iosb structures)
	!
	!       I need this iosb to get around a limitation in the BASIC version of starlet
	!
	!       question : How did I know?
	!       answer   : Hacking
	!       reference: http://neilrieck.net/docs/openvms_notes_hacking_starlet.html
	!
	!	my I/O Status Block (record)
	!
	record myIosbRec							!
	    variant								!
		case								!
		    group one							! 32-bit structure
			!
			! Manual: "Compaq TCP/IP Services for OpenVMS"
			! Chapter "Sockets API and System Services Programming"
			! Example 2-25: BIND Lookup (System Services)
			!
			word		iosb$w_status				! 16-bit status
			word		iosb$w_bcnt				! 16-bit byte count
			long		iosb$l_dev_depend			! 32-bit device dependent data
		    end group one						!
		case								!
		    group two							!
			basic$quadword	iosb$quad				!
		    end group two						!
	    end variant								!
	end record myIosbRec							!
	!
	!	<<< home brewed functions >>>
	!
	external long   function get_ef_bit_vector(long)			! required for used with SYS$WFLOR
	!
	!	<<< variable declarations >>>
	!
	declare long		rc			,			! return code				&
				junk%			,			!					&
				ptr%			,			!					&
				i%			,			!					&
				j%			,			!					&
				timeout_count%		,			!					&
				tcp_ef			,			! tcp event flag			&
				tcp_ef_state		,			! tcp event flag state			&
				tmr_ef			,			! timer event flag			&
				tmr_ef_state		,			! timer event flag state		&
				mask			,			!					&
		word		dns_channel		,			! INET channel				&
				bytecnt			,			!					&
		long		command			,			! INET command				&
		basic$QuadWord	DeltaQuad		,			! for sys$bintim			&
		myIosbRec	iosb			,			!					&
		HostEntDef	myHostEnt		,			! see: sys$library:tcpip$inetdef.bas	&
		NetEntDef	myNetEnt		,			! see: sys$library:tcpip$inetdef.bas	&
		string		buffer$			,			!					&
				junk$						!
	!-----------------------------------------------------------------------
	!	function main
	!-----------------------------------------------------------------------
	main:									!
	!
	!	<<< allocate some event flags for later use >>>
	!
	if tcp_ef = 0 then							! if not yet allocated
	    rc = lib$get_EF( tcp_ef )						! allocate ef for tcp
	    if ((rc and 7%) <> 1) then						!
		print "-e-lib$get_EF-1 rc: ";str$(rc)				!
		goto rc_exit							!
	    end if								!
	end if									!
	!
	if tmr_ef = 0 then							! if not yet allocated
	    rc = lib$get_EF( tmr_ef )						! allocate ef for timer
	    if ((rc and 7%) <> 1) then						!
		print "-e-lib$get_EF-2 rc: ";str$(rc)				!
		goto rc_exit							!
	    end if								!
	end if									!
	!
	!	<<< prep >>>
	!
	declare string	inet_dev						! dynamic string descriptor (good)
			inet_dev = "TCPIP$DEVICE:"				!
	!
	!	Assign a channel to the TCPIP device
	!
	rc = sys$assign(inet_dev, dns_channel,,,)				! assign a channel
	if ((rc and 7%) <> 1) then						!
	    print "-e-Failed to assign channel to TCPIP device."		!
	    goto rc_exit							!
	end if									!
	!
	!	we need a "long descriptor" to use io$_acpcontrol in a call to sys$qio
	!	(I wonder which idiot 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 an integer
	!
	command = inetacp_func$c_gethostbyname +				! function:	gethostbyname		&
		  (inetacp$c_trans         	* 256)				! sub-func:	(binary address)
!~~~	buffer$	= space$( 4)							x space for  4 binary bytes (IPv4)
	buffer$ = space$(16)							! space for 16 binary bytes (IPv6)
	!
	!-----------------------------------------------------------------------
	!	do an actual dns lookup asynchonously (guarenteed no-hang)
	!
	!	1. arm a 10-second timer
	!	2. enque the tcp operation
	!	3. wait for what whichever flag is rasied first
	!-----------------------------------------------------------------------
	declare string constant	k_delay010 = "0 00:00:10"			! prep for a 10 second timeout
	rc = sys$bintim(k_delay010, DeltaQuad )					! compute delta time
	print "-e-sys$bintim rc: "+ str$(rc) if ((rc and 1%) <> 1)		! oops, didn't work
	!
	print "-i-arming timer associated with ef:";tmr_ef
	rc = sys$setimr(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-requesting dns lookup via qio associated with ef:";tcp_ef
	rc = sys$qio(	tcp_ef			,				! Event flag				&
			dns_channel		,				! Channel number			&
			io$_acpcontrol		,				! I/O function				&
			iosb::iosb$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									!
	!
	mask =		get_ef_bit_vector(tcp_ef)				! insert vector 1 into mask
	mask = mask or	get_ef_bit_vector(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"				!
	rc = sys$wflor( tcp_ef, 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(tcp_ef, junk%)						! test TCP event flag
	select rc								!
	    case SS$_WASCLR							!
		tcp_ef_state = 0						!
		junk% = sys$cancel(dns_channel)					!
		print "-e-sys$cancel junk%: "+ str$(junk%) if ((junk% and 1%) <> 1)
	    case SS$_WASSET							!
		print "-i-tcp ef was set"
		tcp_ef_state = 1						!
	    case else								!
		print "-e-sys$readef-tcp rc: "+ str$(rc)			!
	end select								!
	!
	rc = sys$readEF(tmr_ef, junk%)						! test TIMER event flag
	select rc								!
	    case SS$_WASCLR							!
		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)"
		tmr_ef_state = 1						!
	    case else								!
		print "-e-sys$readef-timer rc: "+ str$(rc)			!
	end select								!
	!
	if (tcp_ef_state = 1) then						! tcp fired so cancel timer
	    junk% = sys$cantim(,)						!
	end if									!
	!
	if (tmr_ef_state = 1) then						! timer fired so cancel i/o
	    print "-e-DNS lookup timed out"					!
	    junk% = sys$cancel(dns_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"
	!
!~~~	print "-i-iosb-iosb$w_status:"; str$(iosb::iosb$w_status)
	rc = iosb::iosb$w_status						!
	if ((rc and 7%) = 1) then						!
		if bytecnt = 0 then						!
		    print "-w-no data returned"					!
		    rc = 2							! vms-error
		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								!
	else									!
	    print "-e-rc:";rc							!
	    print "-e-Failed to do the DNS lookup"				!
	end if									!
	!
	!	do not change rc after this point; use junk%
	!
	!-----------------------------------------------------------------------
	!	Shut down the socket (optional)
	!-----------------------------------------------------------------------
	shutdown:								! no point changing to async
	junk% = sys$qiow(	tcp_ef				,		!				&
				dns_channel			,		!				&
				(IO$_DEACCESS or IO$M_SHUTDOWN)	,		!				&
				iosb::iosb$quad			,,,,,,		!				&
				TCPIP$C_DSC_ALL,				! P4 Discard all packets	&
				,)						!
	if ((junk% and 1%) <> 1) then						!
	    print "-e-Failed to shut down the socket"				!
	end if									!

	!
	!	Close the sockets ( no point changing to async )
	!
	junk% = sys$qiow(	tcp_ef			,			!	&
				dns_channel		,			!	&
				IO$_DEACCESS		,			!	&
				iosb::iosb$quad		,			!	&
							,,,,,,,)		!
	if ((junk% and 1%) <> 1) then						!
	    print "-e-Failed to close the socket."				!
	end if									!

	!
	!	Deassign the TCPIP device channels
	!
	junk% = sys$dassgn(dns_channel)						!
	if ((junk% and 1%) <> 1) then						!
	    print "-e-Failed to deassign the channel"				!
	end if									!
	!
	goto rc_exit

	!-----------------------------------------------------------------------
	!	cleanup (release event flags)
	!	caveat: rc must be preserved so use junk%
	!-----------------------------------------------------------------------
	cleanup:
	if tcp_ef <> 0 then							! if allocated
	    junk% = lib$free_EF( tcp_ef )					! deallocate an event flag
	    tcp_ef = 0								!
	end if									!
	!
	if tmr_ef <> 0 then							! if allocated
	    junk% = lib$free_EF( tmr_ef )					! deallocate an event flag
	    tmr_ef = 0								!
	end if									!
	return									!
	!
	!	rc must be set up before this point
	!
	rc_exit:								!
	gosub cleanup								! release event flags used here
	my_gethostbyname = rc							! rc is returned to caller
	print "-i- <<< exit my_gethostbyname() with status:";rc if debug > 0
	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)
	!=======================================================================
32060	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
!------------------------------------------------------------------------------------------------------------------------