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
!