OpenVMS Source Code Demos

TCPIP$TCP_CLIENT_QIO_2014A

1000	%title	"tcpip$tcp_client_qio_2014a.bas"
	%ident	"100.1"
	declare string constant k_program = "tcpip$tcp_client_qio_2014a"
	!========================================================================================================================
	! title      : tcpip$tcp_client_qio_2014a_100.bas
	! author     : Neil Rieck ( https://neilrieck.net )
	!	     : (c) copyright 1999,2014  Neil Rieck
	!            : Waterloo, Ontario, Canada.
	! created    : 2014-07-31
	! 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
	! 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_2014a_100.bas
	! link       : $ link	tcpip$tcp_client_qio_2014a_100
	! history    :
	! ver who when   what
	! --- --- ------ --------------------------------------------------------------------------------------------------------
	! 100 NSR 140801 1. this is a BASIC version of tcpip$tcp_client_qio_100.c (without gethostbyname)
	!========================================================================================================================
	option type=explicit							! formal coding
	on error goto common_trap						! old school trapping for this demo
	!
	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
	!
	%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: https://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				! unsigned quad word (system calls)
		    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 quad		junk64						!
	declare long		ip_address					!
	declare long		rc						!
	declare long		bytes_w						!
	declare long		readcount					!
	declare long		bytes_r						!
	declare long		bytes_r_total					!
	declare string		msg$						!
	declare string		inet_device					!
	!
	!=======================================================================
	!	main
	!=======================================================================
2000	main:
	print									!
	print "-i-program: "+ k_program						!
	print "-i-this program will connect to a website on port "+ str$(SERV_PORTNUM)
	sleep 1									!
	!
	!	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			!
	!
	declare word sck_parm(2)
	sck_parm(0) = TCPIP$C_TCP
	sck_parm(1) = INET_PROTYP$C_STREAM
	!
	serv_addr::SIN$W_FAMILY		= TCPIP$C_AF_INET			! init (remote) connection socket
	serv_addr::SIN$W_PORT		= htons(SERV_PORTNUM)			!
	!
	!	for this demo we will use a hard-coded address of 142.180.221.226
	!	(will perform a gethostbyname in a future demo)
	!
3000	junk64				= 142 * 16777216	+ 		! 2^24			&
					  180 * 65536		+ 		! 2^16			&
					  221 * 256		+ 		! 2^8			&
					  226					! 2^0
	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 (qio)"
	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		&
			,			! ast service routine		&
			,			! ast parameter			&
			conn_sockchar,		! p1 - socket characteristics	&
			,			! p2				&
			,			! p3				&
			,			! p4				&
			,			! p5				&
						! p6				&
			)			!
	if (rc and 7%) = 1% then						! if the system call queued properly
	   rc = iosb::iosb$w_status						! then we want to check the final result
	end if									!
	if (rc and 7%) <> 1% then						!
	    print "-e-error:";rc;"while creating socket"			!
	end if									!
	!
	!	connect to server
	!
4020	print "-i-connecting to host"
	rc = sys$qiow(	EFN$C_ENF,		! event flag			&
			conn_channel,		! i/o channel			&
			IO$_ACCESS,		! i/o function code		&
			iosb::iosb$quad,	! i/o status block		&
			,			! ast service routine		&
			,			! ast parameter			&
			,			! p1				&
			,			! p2				&
			loc(serv_itemlst),	! p3 - remote socket info	&
			,			! p4				&
			,			! p5				&
						! p6				&
			)			!
	if (rc and 7%) = 1% then						! if the system call queued properly
	   rc = iosb::iosb$w_status						! then we want to check the final result
	end if									!
	if (rc and 7%) <> 1% then						!
	    print "-e-error:";rc;"while connecting to server"			!
	end if									!
	!
	!	send a message to retrieve the default web page
	!
	msg$ = "GET / HTTP/1.0" + cr + lf + cr + lf				! a blank line marks the end of an HTTP block
	bytes_w = len(msg$)							! determine the data length
	buffer_w = msg$								! xref data to buffer for qio
	!
4030	print "-i-sending data"
	rc = sys$qiow(	EFN$C_ENF,		! event flag			&
			conn_channel,		! i/o channel			&
			IO$_WRITEVBLK,		! i/o function code		&
			iosb::iosb$quad,	! i/o status block		&
			,			! ast service routine		&
			,			! ast parameter			&
			buffer_w,		! p1 buffer address		&
			bytes_w,		! p2 buffer length (to send)	&
			,			! p3				&
			,			! p4				&
			,			! p5				&
						! p6				&
			)			!
	if (rc and 7%) = 1% then						! if the system call queued properly
	   rc = iosb::iosb$w_status						! then we want to check the final result
	end if									!
	if (rc and 7%) <> 1% then						!
	    print "-e-error:";rc;"while sending to server"			!
	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$qiow(	EFN$C_ENF,		! event flag			&
			conn_channel,		! i/o channel			&
			IO$_READVBLK,		! i/o function code		&
			iosb::iosb$quad,	! i/o status block		&
			,			! ast service routine		&
			,			! ast parameter			&
			buffer_r,		! p1 buffer address		&
			TCPBUFSIZ,		! p2 buffer length (to send)	&
			,			! p3				&
			,			! p4				&
			,			! p5				&
						! p6				&
			)			!
	if (rc and 7%) = 1% then						! if the system call queued properly
	   rc = iosb::iosb$w_status						! then we want to check the final result
	end if									!
	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
	   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			&
	      (readcount < 100) then						! if 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"
	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	&
			,				! ast service routine	&
			,				! ast parameter		&
			,				! p1			&
			,				! p2			&
			,				! p3			&
			,				! p4			&
			TCPIP$C_DSC_ALL,		! p5			&
							! p6			&
			)				!
	if (rc and 7%) = 1% then						! if the system call queued properly
	    rc = iosb::iosb$w_status						! then we want to check the final 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"
	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	&
			,				! ast service routine	&
			,				! ast parameter		&
			,				! p1			&
			,				! p2			&
			,				! p3			&
			,				! p4			&
			,				! p5			&
							! p6			&
			)				!
	if (rc and 7%) = 1% then						! if the system call queued properly
	   rc = iosb::iosb$w_status						! then we want to check the final 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...
	!
	!	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)						!
	resume fini								! fix the stack
	!
	fini:
	print "-i-adios..."							!
32000	end									!
	!
	!########################################################################################################################
	!	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
	!	truncate 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								!
	!