OpenVMS Source Code Demos
get_host_by_name_qio
1000 %title "GET_HOST_BY_NAME_QIO.bas" !
%ident "version_107.1" ! <---+--- must match
declare string constant k_version = "107.1" , ! <---+ &
k_program = "GET_HOST_BY_NAME_QIO" !
!================================================================================================================
! Title : GET_HOST_BY_NAME_QIO.BAS (c) copyright 2013-2015 Neil Rieck
! Author : Neil Rieck
! Waterloo, Ontario, Canada.
! Links: https://neilrieck.net
! Email: n.rieck@bell.net
! 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
! 107 NSR 150921 1. optionally accepts input from process logical: GHBN$FQDN (output to GHBN$ADDRESS)
!================================================================================================================
option type=explicit ! cuz tricks are for kids
set no prompt !
!
on error goto trap ! old-school error 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: https://neilrieck.net/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 mode% , ! &
quiet% , ! &
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 fqdn$ , ! &
buffer$ , ! &
junk$ , ! &
dscdef1 p4_dsc ! yep, a descriptor from starlet
map(twok)string yada = 2048 !
!
p4_dsc::DSC$W_MAXSTRLEN = len(yada) ! size of mapped string is 2k
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) !
!
%let %optionallogicals=1 ! additional mode for Joel
%if %optionallogicals=1 %then !
junk% = lib$get_logical("GHBN$FQDN",fqdn$,,"LNM$PROCESS") ! full qualified domain name
if len(fqdn$) >= 5 then ! a.com
mode% = 2 !
quiet% = 1 !
goto already_have_domain_data !
end if !
%end %if
!
!=======================================================================
! 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 fqdn$ !
!
already_have_domain_data: !
fqdn$ = edit$(fqdn$,2) ! no white space
goto fini if fqdn$ = "" !
!
! <<< 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) !
!
if mode% = 2 then !
my_switch% = 0 !
goto already_have_switch !
end if !
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 !
!
already_have_switch:
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" if quiet% = 0 !
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(fqdn$ ) , ! 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%) if quiet% = 0 !
!
! 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
!
goto bypass1 if quiet% = 1 and myIosb::iosb$w_status = 1
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
bypass1:
!
! hacking (lets see storage details from the sys$qiow)
!
if quiet%=0 then
print " ================================="
print "-i-fqdn : "; edit$(fqdn$ ,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 !
end if
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
if mode% = 2 then
junk$ = left$(buffer$,buf_len) !
junk% = lib$set_logical("GHBN$ADDRESS",junk$,"LNM$PROCESS")
else
print "-i-address : "; left$(buffer$,buf_len)
end if !
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
!
goto skip_secondary_analysis if quiet%=1
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 x
! print "-e-Failed to shut down the socket. rc:";rc% x
! end if x
!
! 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 services 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
!------------------------------------------------------------------------------------------------------------------------
Back to HomeNeil Rieck
Waterloo, Ontario, Canada.