OpenVMS Source-Code Demos

GET_HOST_BY_NAME_QIO

1000	%title "GET_HOST_BY_NAME_QIO.bas"					!
	%ident                      "version_106.1"				! <---+--- must match
        declare string constant k_version = "106.1"			,	! <---+					&
                                k_program = "GET_HOST_BY_NAME_QIO"		!
	!================================================================================================================
	! Title  : GET_HOST_BY_NAME_QIO.BAS
	! Author : Neil Rieck (http://www3.sympatico.ca/n.rieck) (mailto:n.rieck@sympatico.ca)
	!          (c) copyright 2013,2014  Neil Rieck
	!	   Waterloo, Ontario, Canada.
	! Caveat : This program is just a proof-of-concept.
	! History:
	! ver who when   what
	! --- --- ------ ------------------------------------------------------------------------------------------------
	! 100 NSR 130104 1. started work
	!     NSR 130105 2. got this working after some BASIC hacking via my_peek
	!     NSR 130106 3. more hacking (getting strange responses from our intranet DNS; perhaps a malware detector)
	! 101 NSR 130107 1. more hacking
	! 102 NSR 130108 1. cleanup
	! 103 NSR 130109 1. hacking experiments with INETACPC$C_HOSTENT_OFFSET + INETACP$C_NETENT_OFFSET
	! 104 NSR 140803 1. cleanup before publishing to the web
	! 105 NSR 140930 1. minor modifications after moving from TCPware to TCP/IP Services for OpenVMS
	! 106 NSR 141001 1. now build string descriptors from scratch as per the c-source example
	!================================================================================================================
	option type=explicit							! cuz tricks are for kids
	set no prompt								!
	!
	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 "$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://www3.sympatico.ca/n.rieck/docs/openvms_notes_hacking_starlet.html
	!
	!	my I/O Status Block (record)
	!
	record myIosbRec							!
	    variant								!
		case								!
		    group one							! 32-bit structure
			!
			! Product "Compaq TCP/IP Services for OpenVMS" v5.1
			! Manual  "Sockets API and System Services Programming"
			! Example 2-25: BIND Lookup (System Services) page 2-74
			!
			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 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 BASIC 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
	!
	!	<<< variable declarations >>>
	!
	declare long		rc%			,			! return code				&
				junk%			,			!					&
				ptr%			,			!					&
				i%			,			!					&
				j%			,			!					&
				timeout_count%		,			!					&
				tcp_event_flag%		,			! tcp event flag			&
				tcp_ef_state%		,			! tcp event flag state			&
				mask%			,			!					&
				my_switch%		,			!					&
		word		channel_0		,			! INET channel				&
				buf_len			,			!					&
		long		command			,			! INET command				&
				subcmd			,			!					&
		basic$QuadWord	DeltaQuad		,			! for sys$bintim			&
		myIosbRec	myIosb			,			!					&
		HostEntDef	myHostEnt		,			! see: sys$library:tcpip$inetdef.bas	&
		NetEntDef	myNetEnt		,			! see: sys$library:tcpip$inetdef.bas	&
		string		domain$			,			!					&
				buffer$			,			!					&
				junk$			,			!					&
		dscdef1		p4_dsc						! yep, a descriptor from starlet
	map(twok)string yada = 2048						!
	!=======================================================================
	!	main
	!=======================================================================
1500	main:									!
	print k_program +"_"+ k_version						!
	print string$(len(k_program +"_"+ k_version), asc("="))			! how will this optimize on Alpha?
	!
	p4_dsc::DSC$W_MAXSTRLEN	= len(yada)					! size of
	p4_dsc::DSC$B_DTYPE	= DSC$K_DTYPE_T					!
	p4_dsc::DSC$B_CLASS	= DSC$K_CLASS_S					!
	p4_dsc::DSC$A_POINTER	= loc(yada)					!
	!
	print "fully qualified domain name? ";					!
	input domain$								!
	domain$ = edit$(domain$,2)						! no white space
	goto fini	if domain$ = ""						!
	!
	!	<<< 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:";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, channel_0,,,)				! assign a channel
	if ((rc% and 7%) <> 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									!
	!
	!	we need a "long descriptor" to use io$_acpcontrol in a call to sys$qiow
	!	(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)				!
	!
	print "Function: inetacp_func$c_gethostbyname"				!
	print "Sub-function menu:"						!
	print " 0 = no sub-function          (return ascii adddress)"		!
	print " 1 = inetacp$c_trans          (return binary address)"		!
	print " 2 = inetacp$c_aliases        (hacking)"				!
	print " 3 = inetacp$c_hostent        (hacking)"				!
	print " 4 = inetacp$c_hostent_offset (promissing)"			!
	print "Function: inetacp_func$c_getnetbyname"				!
	print " 5 = inetacp$c_netent         (hacking)"				!
	print " 6 = inetacp$c_netent_offset  (hacking)"				!
	input "choice? (0-6, 0=default) ";junk$					!
	!
	when error in								!
	    my_switch% = integer(junk$)						!
	use									!
	    my_switch% = 0							!
	end when								!
	!
	select my_switch%							!
	    case 0 to 6								!
	    case else								!
		my_switch% = 0							!
	end select								!
	!
	!	idea: consider reserving space for a 128-bit (IPv6) address even though
	!	this program currently only works with 32-bit (IPv4) addresses
	!
	select my_switch%							!
	case 0									! ascii
	    subcmd =	0							! returns an ascii address
	    command = subcmd or inetacp_func$c_gethostbyname			!
!~~~	    buffer$ =	space$( 32/ 8*4)					x space for IPv4 (xxx.xxx.xxx.xxx)
	    buffer$ =	space$(128/16*5)					! space for IPv6 (xxxx:xxxx: ... )
	case 1									! trans
	    !
	    ! Programming Caveat:
	    !
	    ! 1) Multiplication by 256 is not documented in chapter "Sockets API and System
	    !     Services Programming" of manual "HP TCP/IP Services for OpenVMS" (82final - 6529)
	    ! 2) It is shown in chapter "System Services and C Socket Programming" of manual
	    !	 "DIGITAL TCP/IP Services for OpenVMS" Example 4-8 IO$_ACPCONTROL Function (C Programming)
	    ! 3) A different technique is shown in chapter "Sockets API and System Services Programming"
	    !	 of manual "Compaq TCP/IP Services for OpenVMS" Example 2-25 BIND Lookup (System Services)
	    !	 where a special acp function structure is employed to do the ACP call
	    !
	    !	struct acpfunc {			/* acp subfunction                  */
	    !		unsigned char code;		/* subfunction code                 */
	    !		unsigned char type;		/* call code                        */
	    !		unsigned short reserved;	/* reserved (must be zero)          */
	    !	};
	    !
	    subcmd =	(inetacp$c_trans         	* 256%)			! trans (binary address)
	    command = subcmd or inetacp_func$c_gethostbyname			!
!~~~	    buffer$ =	space$( 4)						x space for  4 binary bytes (IPv4)
	    buffer$ =	space$(16)						! space for 16 binary bytes (IPv6)
	case 2									!
	    subcmd =	(inetacp$c_aliases       	* 256%)			! alias names
	    command = subcmd or inetacp_func$c_gethostbyname			!
	    buffer$ =	space$(2048)						! space for 2048 bytes (hack)
	case 3									!
	    subcmd =	(inetacp$c_hostent       	* 256%)			! host record
	    command = subcmd or inetacp_func$c_gethostbyname			!
	    buffer$ =	space$(2048)						! space for 2048 bytes (hack)
	case 4									!
	    subcmd =	(inetacp$c_hostent_offset	* 256%)			! host record (pointers changed to offsets)
	    command = subcmd or inetacp_func$c_gethostbyname			!
	    buffer$ =	space$(2048)						! space for 2048 bytes (hack)
	case 5									!
	    subcmd =	(inetacp$c_netent       	* 256%)			! net record
	    command = subcmd or inetacp_func$c_getnetbyname			!
	    buffer$ =	space$(2048)						! space for 2048 bytes (hack)
	case 6									!
	    subcmd =	(inetacp$c_netent_offset	* 256%)			! net record (pointers changed to offsets)
	    command = subcmd or inetacp_func$c_getnetbyname			!
	    buffer$ =	space$(2048)						! space for 2048 bytes (hack)
	end select								!
	!
	!	reserve big space for hacking
	!
	buffer$ =	space$(2048)						! reserve 2048 bytes for hacking
	buf_len =	0							! init b4 qio
	!
	!=======================================================================
	!	do a dns lookup (not timed so use sys$qiow)
	!=======================================================================
	print "-i-calling sys$qiow"
	rc% = sys$qiow(	tcp_event_flag%			,			! Event flag				&
			channel_0			,			! Channel number			&
			io$_acpcontrol			,			! I/O function				&
			myIosb::iosb$quad		,			! I/O status block			&
							,			!					&
							,			!					&
			cmd_descriptor		 	,			! P1 needs to be a descriptor		&
			loc(domain$		)	,			! P2 read				&
			loc(p4_dsc::DSC$W_MAXSTRLEN)	, 			! P3 read/write				&
			loc(p4_dsc		)	,			! P4 read				&
							, 			! P5					&
								)		! P6
	if ((rc% and 7%) = 1) then 						! if the system call succeeded
	    print "-i-rc% "+str$(rc%)						!
	    !
	    !	At this point (after calling TCP/IP routines via qio), the whole
	    !	of myIosb is not the same as what we normally see in VMS
	    !
	    print "-i-iosb-iosb$w_status     ";myIosb::iosb$w_status;
	    select myIosb::iosb$w_status					!
		case 1								!
		    print " (ok)"						!
		case 20								!
		    print " (bad paramter)"					!
		case 2160							!
		    print " (eof)"						! usually not enough space
		case else							!
		    print " (???)"						! needs more work
	    end select								!
	    print "-i-iosb-iosb$w_bcnt       ";myiosb::iosb$w_bcnt		!
	    print "-i-iosb-iosb$l_dev_depend ";myiosb::iosb$l_dev_depend	!
	    !
	    !	hacking (lets see storage details from the sys$qiow)
	    !
	    print "   ================================="
	    !
	    print "-i-domain               : "; edit$(domain$ ,128)		!
	    print "-i-primary buffer length:";buf_len				!
	    print "-i-secondary buf length :";myIosb::iosb$w_bcnt		!
	    print "-i-tertiary buf length  :";p4_dsc::DSC$W_MAXSTRLEN		!
	    if p4_dsc::DSC$W_MAXSTRLEN = len(yada) then				!
		buf_len = 0							!
	    else								!
		buf_len = p4_dsc::DSC$W_MAXSTRLEN				!
		buf_len = 100	if buf_len > 100				! reduce output for hack
	    end if								!
	    buffer$ = left$(yada,buf_len)					!
	    if buf_len = 0 then							!
		print "-w-no data returned to primary buffer"			!
	    else								!
		buf_len = 99 if buf_len > 2000
		select my_switch%						!
		case 0								! ascii
		    print "-i-address: "; left$(buffer$,buf_len)		!
		case 1								! trans
		    for i% = 1 to buf_len					! remember: we are "little endian"
			print "-i-octet"+str$(i%)+": "; asc(mid$(buffer$,i%,1))	!
		    next i%							!
		case else							! all else
		    if my_switch% = 4 then					!
			print "-i-record layout (bytes):"
			print "   00-03 contains the offset to the ascii name"
			print "   04-07 contains the offset to the end-of-record?"
			print "   08-11 always represents 2? (perhaps a version number)"
			print "   12-15 always represents 4? (perhaps a version number)"
			print "   16-19 always points past the last I/P"
			print "   20    start of first I/P address (TCPIP)"
			print "   28    start of second I/P (if provided)"
			print "   28    start of second I/P (if provided)"
		    end if							!
		    for i% = 1 to buf_len					! remember: we are "little endian"
			junk$ = mid$(buffer$,i%,1)				!
			print "-i-byte ";					! no EOL
			print using "### ";i%-1;				! no EOL
			print using " ### ";asc(junk$);				! no EOL
			select asc(junk$)					!
			    case 32 to 127					!
				print junk$					!
			    case else						!
				print "."					!
			end select						!
		    next i%							!
		end select							!
	    end if								!
	    !
	    !	secondary analysis
	    !
	    print "-i-dump-2:"							!
	    ptr% = myIosb::iosb$l_dev_depend					! address of where sys$qiow wrote this data?
	    print "-i-buf addr             :";loc(buffer$)			!
	    print "-i-ptr address          :";ptr%				!
	    if (ptr% > 1) and (myIosb::iosb$w_bcnt > 0) then			!
		myIosb::iosb$w_bcnt = 20 if myIosb::iosb$w_bcnt > 20		!
		for i% = 0 to (myIosb::iosb$w_bcnt -1)				!
		    junk% = my_peek_b(ptr%+i%     )
		    print using "### ### ";i%;junk%;
		    select junk%
			case 0 to 31, 127
			    print "."
			case else
			    print chr$(junk%)
		    end select
		next i%
	    end if								!
	    skip_secondary_analysis:						!
	else									!
	    print "-e-Failed to do the DNS lookup. rc:";rc%			!
	end if									!
	!

	!=======================================================================
	!	Shut down the socket (optional)
	!=======================================================================
	shutdown:
	rc% = sys$qiow(	tcp_event_flag%				,		!				&
			channel_0				,		!				&
			(IO$_DEACCESS or IO$M_SHUTDOWN)		,		!				&
			myIosb::iosb$quad			,		!				&
			, ,							!				&
			, , ,							!				&
			TCPIP$C_DSC_ALL,					! P4 Discard all packets	&
			, )							!
	if ((rc% and 7%) <> 1) then						!
		print "-e-Failed to shut down the socket. rc:";rc%		!
	end if									!

	!
	!	Close the sockets
	!
10000	rc% = sys$qiow(	tcp_event_flag%		,				!	&
			channel_0		,				!	&
			IO$_DEACCESS		,				!	&
			myIosb::iosb$quad	,				!	&
						, , , , , , , )			!
	if ((rc% and 7%) <> 1) then						!
		print "-e-Failed to close the socket. rc:";rc%			!
	end if									!

	!
	!	Deassign the TCPIP device channels
	!
	rc% = sys$dassgn(channel_0)						!
	if ((rc% and 7%) <> 1) then						!
		print "-e-Failed to deassign the channel. rc:";rc%		!
	end if									!
	!
	goto fini

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