OpenVMS Source-Code Demos

TCPIP$TCP_SERVER_QIO_BASIC

1000	%title                              "TCPIP$TCP_SERVER_QIO_BASIC"	!
	%ident                      "version_101.2"				! <---+---
	declare string constant k_version = "101.2"			,	! <---+						&
				k_program = "TCPIP$TCP_SERVER_QIO_BASIC"	!
	!========================================================================================================================
	! Title  : TCPIP$TCP_SERVER_QIO_BASIC.BAS
	! Author : Neil Rieck
	! Notes  : 1. this program is 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 to directory TCPIP$EXAMPLES in 2003 and 2008.
	! History:
	! ver who when   what
	! --- --- ------ --------------------------------------------------------------------------------------------------------
	! 100 NSR 001020 1. started conversion from DECC source (in my spare time)
	!     NSR 001024 2. finished conversion and testing (good enough for a demo)
	! 101 NSR 121230 1. fixed a few obvious bugs
	!		 2. brought a little more up-to-date
	!========================================================================================================================
	option type=explicit							! cuz tricks are for kids
	!
	!	<<< 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:tcpip$inetdef.bas"				! tcp/ip network definitions for BASIC
	!
	!	<<< home brewed functions >>>
	!
	external word function htons(word by ref)				!
	!
	!	note: for this little 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 )			!
	external long function my_peek_W( long by value )			!
	external long function my_peek_B( long by value )			!
	!
	!	my I/O Status Block
	!
	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 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_status	,				!				&
		word	channel_0	,				! INET channel			&
		word	channel_1	,				! Template for ACCEPT		&
		word	sck_parm(2)	,				! Socket creation parameter	&
		long	junk%		,				!				&
		IosbRec	myIosb						!
	!
	map(buf)string		buf	= 512				! reserve 512 bytes of static storage
	declare	long		buflen
				buflen	= 512%
	declare	word		port%					!
	declare long		dummy_ptr%				! in DECC was unsigned char *dummy
	declare long		r_retlen				!
	declare sockaddrin	local_host,				! was sockaddr_in in 'C'				&
				remote_host				!
	!
	record IL2							! input list 2 descriptor
		long il2_length
		long il2_address
	end record IL2
	declare IL2		lhst_adrs				! local host address
	!
	record IL3							! input list 3 descriptor
		long il3_length
		long il3_address
		long il3_retlen
	end record IL3
	declare IL3		rhst_adrs				! remote host address
	!===============================================================
	!	main
	!===============================================================
1500	main:								!
	print k_program +"_"+ k_version					!
	print string$(len(k_program +"_"+ k_version), asc("="))		! how will this optimize on Alpha?
	declare string	inet_dev					! a dynamic string descriptor (good)
			inet_dev = "TCPIP$DEVICE:"			!

!	struct	{ short len, param; int *ptr; }
!		item_list[] = {{sizeof(one), TCPIP$C_REUSEADDR, (int*)0 }},
!		options = {sizeof(item_list), TCPIP$C_SOCKOPT, (int*)0 };

	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%					! nothing
	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...

	lhst_adrs::il2_length	= SIN$S_SOCKADDRIN			! size of local host sockaddrin
	lhst_adrs::il2_address	= loc( local_host )			! address of local host sockaddrin

	rhst_adrs::il3_length	= SIN$S_SOCKADDRIN			! size of remote host sockaddrin
	rhst_adrs::il3_address	= loc ( remote_host )			! address of remote host sockaddrin
	rhst_adrs::il3_retlen	= loc ( r_retlen )			!

	sck_parm(0)			= TCPIP$C_TCP			! TCP/IP protocol
	sck_parm(1)			= INET_PROTYP$C_STREAM		! stream type of socket
	local_host::sin$w_family	= TCPIP$C_AF_INET		! INET family		(in 'c' was: sin_family		)
	local_host::sin$l_addr		= TCPIP$C_INADDR_ANY		! Any address		(in 'c' was: sin_addr.s_addr	)
	port% = 5321%							! hard code the port for now
	local_host::sin$w_port = htons(port%)				!			(in 'c' was: sin_port		)
	!
	!	Assign two channels to the TCPIP device
	!
	rc_status = sys$assign(inet_dev, channel_0,,,)			! assign a channel
	if ((rc_status and 1%) = 1%) then				! if success...
		rc_status = sys$assign(inet_dev, channel_1,,,)		! assign another
	end if								!
	if ((rc_status and 1%) <> 1%) then				!
		print "-e-Failed to assign channel to TCPIP device."	!
		call lib$stop(rc_status)				! death is rather abrupt :-)
	end if								!

	!
	!	Create the socket and set the REUSEADDR option.
	!
	!	notes:	1. P1 is defined as ANY BY REF so don't use LOC() but let the compiler pass the address
	!		2. P2-P5 are defined as LONG BY VALUE so use LOC() to pass an address by value
	!
	rc_status = sys$qiow(	3%,					! 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		ar , lv		&
				, ,					!					lv , lv		&
				loc(sock_opts(0%)::BuffLen), )		! P5 Socket option descriptor		lv , lv
	if ((rc_status and 1%) = 1%) then				!
		rc_status = myIosb::rc
	end if
	if ((rc_status and 1%) <> 1%) then
		print "-e-Failed to create the device socket"
		call lib$stop(rc_status)
	end if

	!
	!	Bind to chosen port number (after REUSEADDR is set above)
	!
	rc_status = sys$qiow(	3%,					! Event flag		&
				channel_0,				! Channel number	&
				IO$_SETMODE,				! I/O function		&
				myIosb::quad_0,				! I/O rc_status block	&
				, ,					!			&
				, ,					!			&
				loc(lhst_adrs::il2_length),		! P3 local socket name	&
				3%,					! P4 Connection backlog	&
				, )					!
	if ((rc_status and 1%) = 1%) then				!
		rc_status = myIosb::rc
	end if
	if ((rc_status and 1%) <> 1%) then
		print "-e-Failed to bind the device socket"
		call lib$stop(rc_status)
	end if

	!
	!	Accept a connection from a client
	!
	print "-i-waiting for TCP connection on port: "+ str$(port%)	!
	rc_status = sys$qiow(	3%,					! Event flag			&
				channel_0,				! Channel number		&
				(IO$_ACCESS or IO$M_ACCEPT),		! I/O function			&
				myIosb::quad_0,				! I/O rc_status block		&
				, ,					!				&
				, ,					!				&
				loc(rhst_adrs::il3_length),		! P3 Remote IP address		&
				loc(channel_1 ),			! P4 Channel for new socket	&
				, )					!
	if ((rc_status and 1%) = 1%) then
		rc_status = myIosb::rc
	end if
	if ((rc_status and 1%) <> 1%) then
		print "-e-Failed to accept a connection from a client"
		call lib$stop(rc_status)
	end if

	dummy_ptr% = loc( remote_host::sin$l_addr )			! copy the address
	print "-i-Connection from host: ";				&
		str$(	my_peek_B( dummy_ptr%		));	".";	&
		str$(	my_peek_B( dummy_ptr% + 1%	));	".";	&
		str$(	my_peek_B( dummy_ptr% + 2%	));	".";	&
		str$(	my_peek_B( dummy_ptr% + 3%	));		!
	junk% = htons(remote_host::sin$w_port)				!
	!
	!	sin$w_port is an unsigned word but BASIC has no such data type
	!
	if junk% < 0 then						!
	    junk% = 65536 + junk%					! so "-1" becomes "65535"
	end if								!
	print " on port "+ str$(junk%)					!

	!
	!	Read I/O buffer
	!
	rc_status = sys$qiow(	3%,					! Event flag		&
				channel_1,				! Channel number	&
				IO$_READVBLK,				! I/O function		&
				myIosb::quad_0,				! I/O rc_status block	&
				, ,					!			&
				buf,					! P1 buffer		&
				buflen,					! P2 buffer length	&
				, , , )					!
	if ((rc_status and 1%) = 1%) then				!
		rc_status = myIosb::rc					!
	end if								!
	if ((rc_status and 1%) <> 1%) then				!
		print "-e-Failed to read from socket"			!
	else								!
		print "-i-Received text: "; left$(buf,myIosb:: xfer_count)
	end if								!

	!
	!	Shut down the socket (optional)
	!
	rc_status = sys$qiow(	3%,					!				&
				channel_1,				!				&
				(IO$_DEACCESS or IO$M_SHUTDOWN),	!				&
				myIosb::quad_0,				!				&
				, ,					!				&
				, , ,					!				&
				TCPIP$C_DSC_ALL,			! P4 Discard all packets	&
				, )					!
	if ((rc_status and 1%) = 1%) then
		rc_status = myIosb::rc
	end if
	if ((rc_status and 1%) <> 1%) then
		print "-e-Failed to shut down the socket"
	end if

	!
	!	Close the sockets -- accepted and listner (optional).
	!
	rc_status = sys$qiow(		3%,				!	&
					channel_1,			!	&
					IO$_DEACCESS,			!	&
					myIosb::quad_0,			!	&
					, ,				!	&
					, , , , , )			!
	if ((rc_status and 1%)=1%) then
	    rc_status = sys$qiow(	3%,				!	&
					channel_0,			!	&
					IO$_DEACCESS,			!	&
					myIosb::quad_0,			!	&
					, ,				!	&
					, , , , , )
	end if
	if ((rc_status and 1%) = 1%) then
		rc_status = myIosb::rc
	end if
	if ((rc_status and 1%) <> 1%) then
		print "-e-Failed to close the socket."
	end if
	!
	!	Deassign the TCPIP device channels
	!
	rc_status = sys$dassgn(channel_1)
	if ((rc_status and 1%) = 1%) then
		rc_status = sys$dassgn(channel_0)
	end if
	if ((rc_status and 1%) <> 1%) then
		print "-e-Failed to deassign the channel"
	end if
	!
	!	rc_status must be set up before this point
	!
	fini:
	print "-i-program exiting with code: "+ str$(rc_status)			!
32000	end program rc_status							!
	!
	!#######################################################################
	!
	!----------------------------------------------------------------------------------------------------
	!	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
	map(my_map)byte	bits_70,&
			bits_F8
	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)
	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
	!