OpenVMS Source-Code Demos

GET_HOST_BY_NAME_QIO

1000	%title "GET_HOST_BY_NAME_QIO.bas"					!
	%ident                      "version_102.1"				! <---+--- must match
        declare string constant k_version = "102.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)
	! Caveat : This program is just a proof-of-concept. It needs more work
	! 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 the intranet DNS; perhaps a malware detector)
	! 101 NSR 130107 1. more hacking
	! 102 NSR 130108 1. cleanup
	!========================================================================================================================
	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 old-school definitions for BASIC
	%include "sys$library:tcpip$inetdef.bas"				! tcp/ip network definitions for BASIC
!~~~	%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							!
			!
			! Also see chapter "Sockets API and System Services Programming"
			! of manual "Compaq TCP/IP Services for OpenVMS" Example 2-25 BIND Lookup (System Services)
			!
			word		iosb$w_status				!
			word		iosb$w_bcnt				!
			long		iosb$l_dev_depend			! device dependent data (or address)
		    end group one						!
		case								!
		    group two							!
			basic$quadword	iosb$quad				!
		    end group two						!
		case								!
	    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 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%			,			!				&
				binary_or_ascii%	,			!				&
		word		channel_0		,			! INET channel			&
				addr_len		,			!				&
		long		command			,			! INET command			&
		basic$QuadWord	DeltaQuad		,			! for sys$bintim		&
		myIosbRec	myIosb			,			!				&
		string		domain$			,			!				&
				address$		,			!				&
				junk$						!
	!
	!=======================================================================
	!	main
	!=======================================================================
1500	main:									!
	print k_program +"_"+ k_version						!
	print string$(len(k_program +"_"+ k_version), asc("="))			! how will this optimize on Alpha?
	!
	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: ";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, 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									!
	!
	!
	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 "Sub-call function"
	print " 0 = return binary address"
	print " 1 = return ascii address"
	input "choice? (0/1, 1=default) ";junk$
	!
	!	caveat: reserve space for a 128-bit (IPv6) address even though
	!	this program currently only works with 32-bit (IPv4) addresses
	!
	if junk$ = "0" then							!
	    binary_or_ascii% = 0						! signal: we selected binary
	    !
	    ! Programming Caveat:
	    !
	    ! 1) The following multiplication (x 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)          */
	    !	};
	    !
	    command = (inetacp$c_trans * 256) + inetacp_func$c_gethostbyname	! returns a binary address
	    address$ = space$(128/8)						! pre extend this string to 16 bytes
	else									!
	    binary_or_ascii% = 1						! signal: we selected ascii
	    command =                           inetacp_func$c_gethostbyname	! returns an ascii address
	    address$ = space$(128/8*4)						! pre extend this string to 16 octets
	end if									!
	!
	!=======================================================================
	!	do a dns lookup (not timed so use 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						&
			loc(addr_len		)	, 			! P3						&
			loc(address$		)	,			! P4						&
							, 			! P5						&
								)		! P6
	if ((rc% and 1%) = 1%) then 						! if the system call suceeded
	    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     "+str$(myIosb::iosb$w_status);
	    select myIosb::iosb$w_status					!
		case 1								!
		    print " (ok)"						!
		case 2160							!
		    print " (eof)"						!
		case else							!
		    print " (???)"						! needs more work
	    end select								!
	    print "-i-iosb-iosb$l_dev_depend "+str$(myIosb::iosb$l_dev_depend)	! address of where sys$qiow wrote the data
	    !
	    !	hacking (let's see storage details for variable address$
	    !
	    print "-i-descriptor details for address$"				!
	    ptr% = loc(address$)
	    print "-i-dsc w ";my_peek_w(ptr%       )
	    print "-i-dsc b ";my_peek_b(ptr%+2     )
	    print "-i-dsc b ";my_peek_b(ptr%+3     )
	    print "-i-dsc l ";my_peek_l(ptr%+4     )
	    print "   ============="
	    !
	    !	hacking (lets see storage details from the sys$qiow)
	    !
	    print "-i-storage details from the sys$qiow"			!
	    ptr% = myIosb::iosb$l_dev_depend					! address of where sys$qiow wrote the data
	    print "-i-ptr   ";str$(ptr%)					!
	    if (ptr% <> 0) and (myIosb::iosb$w_bcnt > 0) then			!
		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								!
	    print "   ========================================"
	    !
	    print "-i-domain : "; edit$(domain$ ,128)				!
	    if addr_len = 0 then						!
		print "-w-no data returned"					!
	    else								!
		print "-i-length : ";addr_len					!
		if binary_or_ascii% = 0 then					!
		    for i% = 1 to addr_len					! remember: we are "little endian"
			print "octet"+str$(i%)+": "; asc(mid$(address$,i%,1))
		    next i%							!
		else								!
		    print "-i-address: "; left$(address$,addr_len)		!
		end if								!
	    end if								!
	else									!
	    print "-e-rc% "+str$(rc%)						!
	    print "-e-Failed to do the DNS lookup"				!
	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 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::iosb$quad	,				!	&
					, ,					!	&
					, , , , , )				!
	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
	!
	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
!------------------------------------------------------------------------------------------------------------------------