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