OpenVMS Source-Code Demos
TCPWARE_TELNET_SAMPLE
1000 %title "vms_basic_tcpware_telnet_sample"
%ident "version_102.1" ! <<<---+---***
declare string constant k_version = "102.1" , ! <<<---+ &
k_program = "basic_tcpware_telnet_sample" !
!
!0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
!1 2 3 4 5 6 7 8 9 0 1 2 3
!=========================================================================================================================
! Title : VMS_BASIC_TCPWARE_TELNET_SAMPLE.BAS
! Author : Neil S. Rieck (Kitchener/Waterloo/Cambridge, Ontario, Canada)
! : (http://www3.sympatico.ca/n.rieck) (mailto:n.rieck@sympatico.ca)
! Purpose: to explore the possibility of doing TELNET from within VAX-BASIC applications
! Notes : 1. written in VAX BASIC 3.8 running under OpenVMS 6.2 using Process Software's TCPware 5.3
! 2. rewritten in OpenVMS Alpha V1.6 under OpenVMS 8.2 using Process Software's TCPware 5.7-2
! 3. derived from file "telnet_sample.c" in TCPware's example directory which is
! copyrighted (c) by Process Software Corporation of Framingham, Massachusetts, USA.
! 4. by declaring passing mechanisms in the "external" declarations we won't need to use VAX-BASIC's
! "LOC" function to substitute for DEC-Cs ampersand (address reference)
! 5. optionally, rename this file to "telnet_sample.bas"
! 6. this progarm must be built (from DCL) as follows:
! $ basic vms_basic_tcpware_telnet_sample_102.bas
! $ link vms_basic_tcpware_telnet_sample_102, -
! sys$input/options
! tcpware:tellib/lib
! sys$share:tcpware_socklib_shr/share
! $ exit
! 7. interface to dcl as a foreign command like so:
! $telnet_sample :== $my$demos:basic_tcpware_telnet_sample_102.exe
! (where my$demos is a path specification)
! 8. program usage from DCL:
! $telnet_sample desired-host 7 (echo service)
! $telnet_sample desired-host 13 (daytime service)
! $telnet_sample desired-host 19 (chargen service)
! 9. Since this is just a demo, please disregard some early exits from within sub routines
!=========================================================================================================================
! History:
! ver who when what
! --- --- ------ ---------------------------------------------------------------------------------------------------------
! 100 NSR 991112 1. original program (derived from tcpware:telnet_sample.c)
! 101 NSR 070730 2. started added support for port 23 (but will not work as a DCL foreign command)
! NSR 070731 3. cleaned up the code in a few places
! 4. started cleanup of the telnet negotiator (see: port_23_user_cmd_proc)
! NSR 070801 5. more work
! NSR 070801 6. now send some telnet parameter negotiation requests when the connection is first opened
! 7. created a make-shift TELNET demo bf_101.7
! NSR 070802 8. now pass a debug paramter into port_23_user_cmd_proc via map(debug)
! 102 NSR 070806 1. added timer calls to the receive section to improve speed
!=========================================================================================================================
option type =explicit ! no kid stuff...
set no prompt !
!
declare string constant &
dq = '34'C ! double quote (ascii 34)
!
declare long rc% , ! return code &
ccb% , ! connection control block &
handler_error% , ! &
tcp_event_flag% , ! &
tcp_ef_state% , ! &
timer_event_flag% , ! &
timer_ef_state% , ! &
char_count% , ! &
junk%, i%, j%, k% , ! &
delay_junk% , ! &
fail_safe% , ! &
read_stall% , ! &
first_time% , ! &
mask% , ! &
pass_count% , ! &
word recvlen_w% , ! &
sendbuf_w% , ! &
service_port_w% , ! &
string buf$ , ! &
host_name$ , ! &
service_port$ , ! &
junk$ , ! &
p1$ , ! command line parameter #1 &
p2$ , ! command line parameter #2 &
basic$QuadWord DeltaQuad ! for sys$bintim etc.
!
! warning: these declarations should be the same in sub "port_23_user_cmd_proc"
!
declare word constant k_xmit_size_w = 1024 , ! &
k_recv_size_w = 2048 !
!
map(xyz) string sendbuf$ = k_xmit_size_w , ! static string(s) &
recvbuf$ = k_recv_size_w !
!
map(debug) long map_debug% ! this is shared with 'port_23_user_cmd_proc'
!
! OpenVMS System Services
!
%include "starlet" %from %library "sys$library:basic$starlet" ! system services
%include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$
!
external long function sys$waitfr( long by value ) ! wait for event flag
!
external string function wcsm_dt_stamp16 ! ccyymmddHHMMSStt
!
external long function get_timer_bit_vector(long) ! required for used with SYS$WFLOR
!
external long function sys$readef( long by value , ! read event flag &
long by ref ) !
!
external long port_23_user_cmd_proc ! this is an external sub process (telnet use only)
!
! see RFC-764, RFC-731 and RFC-854
! notes:
! 1. this is a partial list
! 2. if any of these conflict with BASIC keywords in the future then just add a "k" prefix ("k"=constant
! because "c"=char; maybe we should use "t"=TELNET). Note: I'm shocked we can use "DO" without a prefix.
! 3. Google this string for more information: "telnet iac sb se 250 240 nvt"
!
declare long constant WILL = 251 ,! Sender "requests to begin" or "confirms" something &
WONT = 252 ,! Demands to stop or not start something &
DO = 253 ,! Requests other side to begin or confirm &
DONT = 254 ,! Demands other side to stop &
IAC = 255 ,! Interpret As Command &
kSB = 250 ,! sub command &
kGA = 249 ,! go ahead &
kSE = 240 ,! sub end &
kBINARY = 0 ,! binary transmission &
kECHO = 1 ,! &
RECCONECTION = 2 ,! &
SUPPRESS_GA = 3 ,! supress go-ahead &
kMSG_SIZ_NEG = 4 ,! approx message size negotiation &
kSTATUS = 5 ,! &
TIMING_MARK = 6 ,! &
EXTENDED_ASCII = 17 ,! &
kLOGOUT = 18 ,! &
BM = 19 ,! Byte Macro &
kDET = 20 ,! Data Entry Terminal &
SUPDUP = 21 ,! &
SUPDUP_OUT = 22 ,! &
SEND_LOCATION = 23 ,! &
TERM_TYPE = 24 ,! from RFC-884 &
TACACS = 25 ,! &
Output_Marking = 27 ,! &
Term_Loc_Number = 28 ,! &
kEOR = 35 ,! end-of-record &
WINDOW_SIZE = 31 ,! &
TERM_SPEED = 32 ,! &
REMOTE_FLOW_CTL = 33 ,! &
LINE_MODE = 34 ,! &
ENVIRON = 36 ,! &
kAUTHENTICATION = 37 ,! &
kNEW_ENVIRONMENT= 39 ,! &
kTN3270E = 40 ,! &
EXTENDED_OPTIONS=255 !
!
! VMS RTL (run time library) LIB$ Services
!
external long function lib$get_foreign( string by desc , ! &
string by desc , ! &
word by ref , ! &
long by ref ) !
!
external long function lib$get_ef( long by ref ) ! get event flag (from local pool)
!
external long function lib$free_ef( long by ref ) ! release event flag
!
! TCPware Telnet Services
!
external long function tel_allocate_ccb( long by ref , ! ccb-ptr &
word by ref , ! rcv-buf-size &
word by ref ) ! snd-buf-size
!
external long function tel_deallocate_ccb( long by ref ) ! ccb-ptr
!
external long function tel_abort_connection( long by ref ) ! ccb-ptr
!
external long function tel_close_connection( long by ref ) ! ccb-ptr
!
external long function tel_open_connection( long by ref , ! ccb-ptr &
long by ref , ! ia &
string by desc , ! host &
! long by ref , x cmd-rtn (Oops. What is going on here?) &
long by value , ! cmd-rtn (for port_23_user_cmd_proc) &
long by ref , ! efn &
long by ref , ! ast-addr &
word by ref , ! port &
long by ref ) ! timeout
!
external long function tel_receive_data( long by ref , ! ccb-ptr &
word by ref , ! buffer-size &
string by ref , ! buffer &
word by ref ) ! byte-count
!
external long function tel_send_data( long by ref , ! ccb-ptr &
string by ref , ! buffer &
word by ref ) ! byte-count
!
external long function tel_send_command( long by ref , ! ccb-ptr &
string by ref , ! buffer &
word by ref ) ! byte-count
!
!================================================================================
! main
!================================================================================
main:
margin #0, 132 !
sendbuf$ = "" ! initialize
recvbuf$ = "" !
map_debug% = 1 ! pass this to 'port_23_user_cmd_proc'
first_time% = 1 !
rc% = 1 ! VMS-s-
!
print k_program +"_"+ k_version !
print string$(len(k_program +"_"+ k_version), asc("=")) ! what will the optimzer do with this?
!
rc% = LIB$GET_FOREIGN( junk$,,, ) !
junk$ = junk$ + " " ! make sure we have a trailing space
junk$ = edit$( junk$, 16%) ! multiple spaces to one
i% = 1% ! start at char #1
j% = pos(junk$, " ", i%) ! find first space
p1$ = seg$(junk$, i%, j%-1%) ! extract parameter #1
i% = j% + 1% ! slide past space
j% = pos(junk$, " ", i%) ! find next space
p2$ = seg$(junk$, i%, j%-1%) ! extract parameter #2
if p1$ <> "" and p2$ <> "" then ! if command line paramters exist...
when error in !
service_port_w% = integer(p2$) !
select service_port_w% !
case 7, 13, 19, 23 ! supported services
host_name$ = p1$ !
goto start_program ! so jump past interactive stuff
case else !
print "-e- unsupported service" ! illegal so fall thru
end select !
use !
print "-e- non numeric service" ! fall thru on error
end when !
end if !
!
! prompt for parameters
!
input "host name? (default=142.180.221.246) ";host_name$ !
host_name$ = edit$(host_name$, 4%+2%) ! no controls, no white space
host_name$ = "142.180.221.246" if host_name$ = "" !
!
print "Supported TCP Service Ports:"
print " 7 = echo (default)"
print " 13 = daytime"
print " 19 = chargen"
print " 23 = telnet"
input "Choice? (default=7) "; service_port$ !
service_port$ = edit$(service_port$, 4+2) ! no controls, no white space
select service_port$ !
case "7","13","19","23" !
case "23" !
case else !
service_port$ = "7" ! default to echo
end select !
service_port_w% = integer(service_port$) !
!
when error in !
input "debug level? (0-3, default=0) ";junk% !
use !
junk% = 0 ! oops
end when !
select junk% !
case 0 to 3 !
case else !
junk% = 0 ! oops
end select !
map_debug% = junk% ! pass this to 'port_23_user_cmd_proc'
start_program: ! <<< from foreign command
!
! <<< have the system allocate a connection control block and save the address in ccb%
!
rc% = tel_allocate_ccb( ccb%, k_recv_size_w, k_xmit_size_w ) ! allocate a ccb
if (rc% and 1%) <> 1% then !
print "-e-allo rc% ";rc% !
goto fini !
end if !
!
rc% = lib$get_EF( tcp_event_flag% ) ! procure an event flag
if (rc% and 1%) <> 1% then !
print "-e-gef_ef rc% ";rc% !
goto fini !
end if !
!
rc% = lib$get_EF( timer_event_flag% ) ! procure an event flag
if (rc% and 1%) <> 1% then !
print "-e-gef_ef rc% ";rc% !
goto fini !
end if !
!
! <<< open a connection >>>
!
! notes:
! 1. it isn't stated in the manual, but you'll get an error if timeout isn't >=20 or 0
! 2. undefined or unused parameters must be left blank. The compiler will push the proper null which is
! not what happens when you replace the blank with a zero.
!
rc% = tel_open_connection( ! &
ccb% , ! ccb-ptr &
, ! ia (use IA or HOST, not both) &
host_name$ , ! host (use IA or HOST, not both) &
loc(port_23_user_cmd_proc) by value , ! cmd-rtn leave blank for NONE (TELNET) &
tcp_event_flag% , ! efn &
, ! ast-addr leave blank for NONE &
service_port_w% , ! port &
20% ! timeout (secs) &
) !
if (rc% and 1%) <> 1% then !
print "-e-open rc% ";rc% !
goto fini !
end if !
!
! <<< let's get on with it >>>
!
loop: !
select service_port_w% !
case 13 , ! daytime &
19 ! chargen -----------------------------------------
while 1 !
rc% = sys$waitfr( tcp_event_flag% ) ! wait for flag to be set
if (rc% and 1%) <> 1% then !
print "-e-wait rc% ";rc% !
goto fini !
end if !
gosub receive_data !
next !
!
case 7 ! echo --------------------------------------------
input "enter text to send? (default=exit) ";junk$ !
if edit$(junk$, 4%+2%) = "" then !
goto close_n_exit !
end if !
!
! <<< send the data >>>
!
! Note: Since junk$ could be much than sendbuf$, it would be better to test lengths and then send
! multiple fixed chunks of data; However, this is just a demo.
!
sendbuf$ = junk$ !
sendbuf_w% = len(edit$(sendbuf$, 128%)) ! compute data string length
rc% = tel_send_data( ccb%, sendbuf$, sendbuf_w% ) !
if (rc% and 1%) <> 1% then !
print "-e-send rc% ";rc% !
goto fini !
end if !
!
! <<< wait for the event flag to be set >>>
!
gosub receive_data !
goto loop !
case 23 ! TELNET ---------------------------- bf_101.7
!
! TELNET-Demo Implementation Notes:
!
! 1. The proper way to do this is with Event Flags, Programmable Timers, and ASTs (I've already got it working
! in other programs) but doing that here would make you loose sight of how basic TELNET works
!
! 2. No one will use "HP-BASIC for OpenVMS" to build a TELNET client (although it can be done) which means the
! "interative input and wait" stuff is not necessary. The actual reason for doing something like this is to
! provide TELNET capabilities to BATCH + DETACHED process which can programmatically communicate with another
! system
!
junk$ = chr$(IAC) + chr$(DO ) + chr$(SUPPRESS_GA) + ! DO : SUPPRESS_GA &
chr$(IAC) + chr$(WILL) + chr$(SUPPRESS_GA) ! WILL: SUPPRESS_GA
sendbuf$ = junk$ !
sendbuf_w% = len(junk$) !
print "-i- sending initial handshakes" if map_debug% > 0 !
rc% = tel_send_command( ccb%, sendbuf$, sendbuf_w% ) !
if (rc% and 1%) <> 1% then !
print "-e-sndcmd rc% ";rc% !
goto fini !
end if !
gosub receive_data !
!
telnet_loop: !
rc% = sys$readef(tcp_event_flag% , tcp_ef_state%) ! test channel event flag (no hang method)
if (rc% and 1%) <> 1% then !
print "-e-readef rc% ";rc% !
goto fini !
end if !
select rc% !
case SS$_WASSET ! receive buffer not empty
gosub receive_data !
goto telnet_loop ! read until no more
case SS$_WASCLR ! receive buffer empty
end select !
!
! Interactive Input is in this block of code but while we are here we are not paying attention to
! the receive stream.
!
when error in !
if first_time% = 1 then !
print "Note: 1) don't enter anything until you see your prompt"
print " 2) timeout applies to keystrokes; not the time until you hit <enter>"
sleep 1 !
first_time% = 0 !
end if !
wait 2 ! enable keyboard timer
print "enter text to send followed by <enter> (blank line to exit; timeout in 2 seconds) ";
linput junk$ !
junk% = 0 ! not a timeout
use !
junk% = err ! probably a timeout
end when !
wait 0 ! disable timer
if junk% = 15 then !
print cr + lf + "-w- timeout" !
goto telnet_loop !
end if !
goto close_n_exit if len(junk$)=0 ! blank line so exit
!
junk$ = junk$ + cr + lf ! tack on an EOL
sendbuf$ = junk$ !
sendbuf_w% = len(junk$) ! compute data string length
rc% = tel_send_data( ccb%, sendbuf$, sendbuf_w% ) !
if (rc% and 1%) <> 1% then !
print "-e-send rc% ";rc% !
goto fini !
end if !
gosub delay_500 ! let the message get to the far end
goto telnet_loop !
end select !
!================================================================================
! <<< receive the data >>>
!
! this entry point does not wait for an event flag to be set. It just polls
!================================================================================
receive_data: !
!
! <<< arm a timer to expire 'x' time from now >>>
!
pass_count% = 0 ! init
read_loop: !
pass_count% = pass_count% + 1 ! advance
if pass_count% = 1 then ! if first pass
declare string constant k_delay5sec = "0 00:00:05.0" ! set delay time 5 sec from now
rc% = sys$bintim(k_delay5sec, DeltaQuad ) ! init delta time ('x' time from now)
else !
declare string constant k_delay500ms = "0 00:00:00.5" ! set delay time 500 ms from now
rc% = sys$bintim(k_delay500ms, DeltaQuad ) ! init delta time ('x' time from now)
end if !
print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
rc% = sys$setimr(timer_event_flag%,DeltaQuad by ref,,,) ! now use it to schedule a wake up
print "-e- sys$setimr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
!
! note: for the SYS$WFLOR call to work, both event flags must be in the same event flag cluster.
! The first parameter is only used to determine which event flag cluster to test.
! The second parameter (mask) contains bits representing event flags within that cluster
!
mask% = get_timer_bit_vector( tcp_event_flag%) ! insert vector 1 into mask
mask% = mask% or get_timer_bit_vector(timer_event_flag%) ! insert vector 2 into mask
!
! <<< wait for either the 'TCP event flag' or the 'TIMER event flag' to change state >>>
!
junk$ = wcsm_dt_stamp16 ! current time: ccyymmddHHMMSStt
junk$ = left$(junk$,8) +"."+ mid$(junk$,9,6) +"."+ right$(junk$,15) ! -> ccmmyydd.HHMMSS.tt
print "-i- waiting for flag "+ str$(tcp_event_flag%) +" or flag "+ str$(timer_event_flag%) +" time: "+ junk$ &
if map_debug% > 0
!
rc% = sys$wflor( tcp_event_flag%, mask%) ! wait for a response from one of two flags
print "-e- sys$waitfr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
goto close_connection if (rc% and 1%) <> 1% !
if map_debug% >= 1 then !
junk$ = wcsm_dt_stamp16 ! current time: ccyymmddHHMMSStt
junk$ = left$(junk$,8) +"."+ mid$(junk$,9,6) +"."+ right$(junk$,15) ! -> ccmmyydd.HHMMSS.tt
print "-i- waking from event some flag at time: "+ junk$ ! &
if map_debug% > 0 !
end if !
!
! <<< cancel all timer requests (if any) >>>
!
print "-i- Calling $CanTim" if map_debug% > 0 !
rc% = sys$cantim(,) ! cancel all timer requests
print "-e- sys$cantim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
!
! which event flag is set? TCP or TIMER?
!
rc% = sys$readEF(tcp_event_flag%, junk%) ! test TCP event flag
select rc% !
case SS$_WASCLR !
tcp_ef_state% = 0 !
case SS$_WASSET !
tcp_ef_state% = 1 !
case else !
print "-e- sys$readef-tcp rc: "+ str$(rc%) !
end select !
print "-i- TCP EF State: ";str$(tcp_ef_state%);" "; if map_debug% >= 1 ! no BASIC EOL required here
!
rc% = sys$readEF(timer_event_flag%, junk%) ! test TIMER event flag
select rc% !
case SS$_WASCLR !
timer_ef_state% = 0 !
case SS$_WASSET !
timer_ef_state% = 1 !
case else !
print "-e- sys$readef-timer rc: "+ str$(rc%) !
end select !
print "-i- Timer EF State: ";str$(timer_ef_state%) if map_debug% >= 1 !
!
! at this point either the TCP-EF or the TIMER-EF could be set
!
if (timer_ef_state% = 1) and ! if the TIMER-EF is set &
( tcp_ef_state% = 0) ! and the TCP-EF is clear
then ! then something timed out
print "-i- timer expired with no TCP data" if map_debug% > 0 !
goto read_exit !
else ! we've got TCP data so fall thru
print "-i- TCP data detected in buffer" if map_debug% > 0
end if !
!
! read data from the TCP buffer
!
rc% = tel_receive_data( ccb%, k_recv_size_w, recvbuf$, recvlen_w%) ! receive data <<<------***
select rc% !
case SS$_VCCLOSED, SS$_TIMEOUT, SS$_THIRDPARTY !
print "-e- the connection closed unexpectedly ("+ str$(rc%) +")" !
goto close_connection ! cleanup etc.
case else !
goto close_connection if (rc% and 1%) <> 1% !
select map_debug%
case 0
print "-i- recv>" +left$(recvbuf$, recvlen_w%) +"<" !
case 1
print "============================================================vvv"
print "-i- recv>" +left$(recvbuf$, recvlen_w%) !
print "============================================================^^^"
case else
print "============================================================vvv"
print "-i- recv data >"+ left$(recvbuf$, recvlen_w%);"<" !
print "============================================================^^^"
print "-i- recv count: "+ str$(recvlen_w%) !
end select !
goto read_loop ! loop back until timeout
end select !
!
read_exit: !
return !
!================================================================================
! my delay (because we can't sleep for less than 1 second)
!================================================================================
delay_500:
delay_junk% = sys$bintim("0 00:00:00.50", DeltaQuad ) ! then init delta time to 500 mS
goto delay_common !
!
delay_250:
delay_junk% = sys$bintim("0 00:00:00.25", DeltaQuad ) ! then init delta time to 250 mS
goto delay_common !
!
delay_100:
delay_junk% = sys$bintim("0 00:00:00.10", DeltaQuad ) ! then init delta time to 100 mS
!
delay_common:
delay_junk% = sys$schdwk(,,DeltaQuad by ref,) ! schedule a wakeup ? seconds from now
delay_junk% = sys$hiber ! go to sleep
return
!
!================================================================================
! <<< close the connection then exit >>>
!
! note: don't change rc% after this point
!================================================================================
fini:
close_n_exit: !
close_connection:
!
print "-i- closing connection" if map_debug% > 0 !
junk% = tel_close_connection( ccb% ) ! this just closes my xmit
if (junk% and 1%) <> 1% then !
print "-e-close junk% ";junk% !
end if !
!
fail_safe% = 0 ! init fail safe counter
buffer_purge: !
print "-i- purging receive buffer <<<---***" if map_debug% > 0 !
fail_safe% = fail_safe% + 1 !
junk% = tel_receive_data( ccb%, k_recv_size_w, recvbuf$, recvlen_w%) ! clean out receive buffer
print "-i- receive buffer purge. Bytes: "+ str$(recvlen_w%) +" rc: ";str$(junk%) if map_debug% > 0
select junk% !
case SS$_VCCLOSED, SS$_TIMEOUT, SS$_THIRDPARTY ! now totally closed so fall thru
case else !
if (junk% and 7%) = 1 then ! if no errors
junk% = sys$bintim("0 00:00:00.10", DeltaQuad ) ! then init delta time to 100 mS
junk% = sys$schdwk(,,DeltaQuad by ref,) ! schedule a wakeup ? seconds from now
junk% = sys$hiber ! go to sleep
goto buffer_purge if fail_safe% <= 50 ! loop back (5 second worse case limit)
junk% = tel_abort_connection( ccb% ) ! don't take any chances
sleep 5 !
else ! some kind of error....
junk% = tel_abort_connection( ccb% ) ! don't take any chances
sleep 1 !
end if
end select
!
if tcp_event_flag% <> 0 then !
print "-i- releasing EF: "+str$( tcp_event_flag% ) if map_debug% > 0
junk% = lib$free_EF( tcp_event_flag% ) ! get an event flag
end if !
!
if timer_event_flag% <> 0 then !
print "-i- releasing EF: "+str$( timer_event_flag% ) if map_debug% > 0
junk% = lib$free_EF( timer_event_flag% ) ! get an event flag
end if !
!
! <<< deallocate the ccb >>>
!
if ccb% <> 0 then !
print "-i- releasing CCB" if map_debug% > 0 !
junk% = tel_deallocate_ccb( ccb% ) !
if (junk% and 1%) <> 1% then !
print "-e-deal junk% ";junk% !
end if !
end if !
!
print "-i- exiting with code: "+ str$(rc%) !
30000 end program rc% ! rc% gets passed back to DCL
!
!========================================================================================================================
! port_23_user_cmd_proc
!
! notes:
! 1. This routine is run when an IAC (255) character is received
! 2. It is involved with the WILL-WONT-DO-DONT handshake that begins every telent session (see: RFC-764)
! 3. If you find a system you can't connect to, use the TCPware Client's debug option to trace a connection
! 4. Do not lie to the other end. Do not agree to do anything you aren't prepared to handle.
! 5. A really simple interface will support SUPPRESS_GA and refuse to do everything else
! 7. See RFC-764 at http://www.faqs.org/rfcs/rfc764.html for more details
! 8. Warning: this is not a complete implementation (but it is enough to get you connected to a complete implementation).
! We are supposed to save parameter states and not ACK any request putting us into a state we are already in (this
! is required to prevent us from getting into an infinate ACK loop with the far end)
!========================================================================================================================
32000 sub port_23_user_cmd_proc by ref( long ccb%, byte my_buf(), word my_length%)
option type=explicit !
declare long rc% , ! return code &
cmd% , ! command &
opt% , ! option &
k%, z% , ! &
word recvlen_w% , ! &
sendbuf_w% , ! &
my_port_w% , ! &
string dest_node$ , ! &
user_fs1$ , ! &
junk$ !
!
declare word constant k_xmit_size_w = 32 , ! &
k_recv_size_w = 32 ! superfluous?
!
! use different maps so we don't clobber sendbuf$ above
!
map(private) string sendbuf$ = k_xmit_size_w , ! &
recvbuf$ = k_recv_size_w ! superfluous?
!
map(debug) long map_debug% ! this is shared with 'the calling program'
!
external long function tel_send_command( long by ref , ! ccb-ptr &
string by ref , ! buffer &
word by ref ) ! byte-count
!
! see RFC-764, RFC-731 and RFC-854
! notes:
! 1. this is a partial list
! 2. if any of these conflict with BASIC keywords in the future then just add a "k" prefix ("k"=constant
! because "c"=char; maybe we should use "t"=TELNET). Note: I'm shocked we can use "DO" without a prefix.
! 3. Google this string for more information: "telnet iac sb se 250 240 nvt"
!
declare long constant WILL = 251 ,! Sender "requests to begin" or "confirms" something &
WONT = 252 ,! Demands to stop or not start something &
DO = 253 ,! Requests other side to begin or confirm &
DONT = 254 ,! Demands other side to stop &
IAC = 255 ,! Interpret As Command &
kSB = 250 ,! sub command &
kGA = 249 ,! go ahead &
kSE = 240 ,! sub end &
kECHO = 1 ,! &
SUPPRESS_GA = 3 ,! supress go-ahead &
kSTATUS = 5 ,! &
TIMING_MARK = 6 ,! &
BM = 19 ,! Byte Macro &
kDET = 20 ,! Data Entry Terminal &
TERM_TYPE = 24 ,! from RFC-884 &
WINDOW_SIZE = 31 ,! &
TERM_SPEED = 32 ,! &
REMOTE_FLOW_CTL = 33 ,! &
LINE_MODE = 34 ,! &
ENVIRON = 36 !
!====================================================================================================
! main (of port_23_user_cmd_proc)
!====================================================================================================
main: ! for sub 'port_23_user_cmd_proc'
!
if map_debug% >= 1 then !
print "=== port_23_user_cmd_proc ============================ begin"!
end if !
if map_debug% >= 3 then !
print "-i-user_cmd_proc (inbound: params ): "; !
for z% = 0% to (my_length% -1%) !
print using "#### ";my_buf(z%); !
next z% !
print !
end if !
!
cmd% = my_buf(0%) ! extract command byte
cmd% = cmd% + 256% if cmd% < 0% ! fix sign
!
opt% = my_buf(1%) ! extract option byte
opt% = opt% + 256% if opt% < 0% ! fix sign
!
if map_debug% >= 2 then !
print "-i-user_cmd_proc (inbound: cmd/opt): "; !
print using "#### ####"; cmd%; opt% !
end if !
!
! Example handshakes:
!
! if we receive a DO TERM_TYPE command then we need to answer back with only one of the following:
! 1. WONT TERM_TYPE (then do nothing) or
! 2. WILL TERM_TYPE (then actually send the TERM TYPE)
! if we receive a "WILL kECHO" query then we need to answer back with only one of the following:
! 1. DO kECHO
! 2. DONT kECHO (this is preferred; we don't want the other end to echo everything)
! Echo:
! 1. WILL ECHO - requests to begin echo or confirms do echo
! 2. WONT ECHO - demands to stop echo
! 3. DO ECHO - requests other side to begin echo
! 4. DONT ECHO - demand other side to stop echo
! Note: see RFC-764 at http://www.faqs.org/rfcs/rfc764.html for more details
!
!
sendbuf_w% = 0 ! initizlize...
select cmd% !
case WILL ! received WILL; so ack with DO or DONT (yes or no)
print "-i-user_cmd_proc rcv-cmd : WILL "+ str$(opt%) if map_debug% >= 1
select opt% !
case SUPPRESS_GA, TERM_TYPE ! we want him to "supress go-ahead"
sendbuf$ = chr$(IAC) + chr$(DO ) + chr$(opt%) ! DO: SUPPRESS_GA
sendbuf_w% = 3 !
case WINDOW_SIZE
!
! I never see the server ever do a sub-negotiation of WINDOW_SIZE (could this be an old legacy
! mode?). In all the traces below after the server sends a DO WINDOW_SIZE size the client reponds
! with: 1) WILL WINDOW_SIZE
! 2) followed immediately by a SB WINDOW_SIZE
!
junk$ = chr$(IAC) + chr$(DO ) + chr$(opt%) + ! WILL: window_size &
chr$(IAC) + chr$(kSB ) + chr$(opt%) + ! &
chr$(0 ) + chr$(132 ) + chr$(0 ) +chr$(24) + ! &
chr$(IAC) + chr$(kSE ) !
sendbuf$ = junk$ !
sendbuf_w% = len(junk$) !
case kECHO, kSTATUS ! we don't want him to echo
sendbuf$ = chr$(IAC) + chr$(DONT) + chr$(opt%) ! DONT: ECHO etc.
sendbuf_w% = 3 !
case else !
sendbuf$ = chr$(IAC) + chr$(DONT) + chr$(opt%) ! DONT do anything else
sendbuf_w% = 3 !
end select !
case DO ! received DO; so ack with WILL or WONT (yes or no)
print "-i-user_cmd_proc rcv-cmd : DO "+ str$(opt%) if map_debug% >= 1
select opt% !
case SUPPRESS_GA, TERM_TYPE !
sendbuf$ = chr$(IAC) + chr$(WILL) + chr$(opt%) ! WILL: suppress GA
sendbuf_w% = 3 !
case WINDOW_SIZE !
!
! I never see the server ever do a sub-negotiation of WINDOW_SIZE (could this be an old legacy
! mode?). In all the traces below after the server sends a DO WINDOW_SIZE size the client reponds
! with: 1) WILL WINDOW_SIZE
! 2) followed immediately by a SB WINDOW_SIZE
!
junk$ = chr$(IAC) + chr$(WILL) + chr$(opt%) + ! WILL: window_size &
chr$(IAC) + chr$(kSB) + chr$(opt%) + ! &
chr$(0) + chr$(132) + chr$(0) +chr$(24) + ! &
chr$(IAC) + chr$(kSE) !
sendbuf$ = junk$ !
sendbuf_w% = len(junk$) !
case TERM_SPEED, ENVIRON, kSTATUS, kECHO !
sendbuf$ = chr$(IAC) + chr$(WONT) + chr$(opt%) ! WONT: TERM_SPEED
sendbuf_w% = 3 !
case else !
sendbuf$ = chr$(IAC) + chr$(WONT) + chr$(opt%) ! WONT: everything else
sendbuf_w% = 3 !
end select !
case WONT ! WONT; must send DONT (as an ACK)
!
! note: we need to add code so we can tell the difference between a response and an ACK (see RFC-764)
!
print "-i-user_cmd_proc rcv-cmd : WONT "+ str$(opt%) if map_debug% >= 1
sendbuf$ = chr$(IAC) + chr$(DONT) + chr$(opt%) !
sendbuf_w% = 3 !
case DONT ! DONT; must send WONT (as an ACK)
!
! note: we need to add code so we can tell the difference between a response and an ACK (see RFC-764)
!
print "-i-user_cmd_proc rcv-cmd : DONT "+ str$(opt%) if map_debug% >= 1
sendbuf$ = chr$(IAC) + chr$(WONT) + chr$(opt%) !
sendbuf_w% = 3 !
case kSB ! requested a suboption negotiation
print "-i-user_cmd_proc rcv-cmd : kSB "+ str$(opt%);" "; if map_debug% >= 1
select opt% !
case TERM_TYPE ! he wants to know our terminal type
print "TERM_TYPE" if map_debug% >= 1
junk$ = chr$(IAC) + chr$(kSB) + chr$(opt%) + chr$(0) + &
"VT200" + ! &
chr$(IAC) + chr$(kSE) !
sendbuf$ = junk$
sendbuf_w% = len(junk$) !
case WINDOW_SIZE ! he wants to know our window size
print "WINDOW_SIZE" if map_debug% >= 1
junk$ = chr$(IAC) + chr$(kSB) + chr$(opt%) + ! &
chr$(0) + chr$(80) + chr$(0) +chr$(24) +! &
chr$(IAC) + chr$(kSE) !
sendbuf$ = junk$ !
sendbuf_w% = len(junk$) !
case TERM_SPEED !
print "TERM_SPEED" if map_debug% >= 1
sendbuf$ = chr$(IAC) + chr$(kSB) + chr$(opt%) + chr$(0) + &
"9600,9600" + ! &
chr$(0) + chr$(IAC) + chr$(kSE) !
sendbuf$ = junk$
sendbuf_w% = len(junk$) !
case else ! oops...
print " ???? unsupported SB: "; str$(opt%) if map_debug% >= 1
sendbuf$ = "" !
sendbuf_w% = 0 !
end select !
case else ! oops...
print "-i-user_cmd_proc rcv-cmd : ???? unsupported CMD: "+ str$(cmd%) +" OPT: "+str$(opt%) if map_debug% >= 1
sendbuf$ = "" !
sendbuf_w% = 0 !
end select !
!
if sendbuf_w% > 0 then ! if we have something to send...
rc% = tel_send_command( ccb%, sendbuf$, sendbuf_w% ) !
print "-i-user_cmd_proc snd-cmd rc: "+ str$(rc%) if map_debug% >= 2
if map_debug% >= 1 then ! if debug...
select asc( mid$(sendbuf$,2,1) ) !
case DO !
print "-i-user_cmd_proc snd-cmd : DO ";
Case WILL !
print "-i-user_cmd_proc snd-cmd : WILL ";
case WONT !
print "-i-user_cmd_proc snd-cmd : WONT ";
case DONT !
print "-i-user_cmd_proc snd-cmd : DONT ";
case kSB !
print "-i-user_cmd_proc snd-cmd : SB ";
case else !
junk$ = str$( asc(mid$(sendbuf$,2,1)) ) !
while len(junk$) < 4 !
junk$ = junk$ + " " !
next !
print "-i-user_cmd_proc snd-cmd : ? ("; junk$ +")"; !
end select !
select asc( mid$(sendbuf$,3,1) ) ! test the 2cd character in the buffer
case kECHO !
print "ECHO "
case SUPPRESS_GA !
print "SUPPRESS_GA "
case kSTATUS !
print "STATUS "
case TIMING_MARK !
print "TIMING_MARK "
case TERM_TYPE !
print "TERM_TYPE "
case WINDOW_SIZE !
print "WINDOW_SIZE "
case TERM_SPEED !
print "TERM_SPEED "
case REMOTE_FLOW_CTL !
print "REMOTE_FLOW_CTL"
case LINE_MODE !
print "LINE_MODE "
case ENVIRON !
print "ENVIRON "
case else !
junk$ = str$( asc(mid$(sendbuf$,3,1)) ) !
while len(junk$) < 4 !
junk$ = junk$ + " " !
next !
print "?? ("; junk$ +")" !
end select !
end if ! end if map_debug% >= 1
end if ! end if sendbuf_w% > 0
!
if map_debug% >= 1 then !
print "=== port_23_user_cmd_proc ============================ end" !
end if !
end sub !
!========================================================================================================================
! trace-1
! The following is a sample transaction from TCPware's TELNET-Client with debugging turned on (NSR - 000219)
! Note: another sample follows this one
!========================================================================================================================
!%TCPWARE_TELNET-I-OPTRECV, received WILL ECHO server says: I would like to ECHO
!%TCPWARE_TELNET-I-SENT, sent DO ECHO client says: I think you should ECHO
!
! here we deal with SUPPRESS_GA in each direction
!
!%TCPWARE_TELNET-I-SENT, sent DO SUPPRESS-GO-AHEAD client says: I think you should SUPPRESS-GA
!%TCPWARE_TELNET-I-SENT, sent WILL SUPPRESS-GO-AHEAD client says: I would also like to SUPPRESS-GA
!%TCPWARE_TELNET-I-OPTRECV, received WILL SUPPRESS-GO-AHEAD server says: I will SUPPRESS-GA
!%TCPWARE_TELNET-I-OPTRECV, received DO SUPPRESS-GO-AHEAD server says: I think you should SUPPRESS-GA
!
! here the server asks the client if he is willing to describe his hardware
!
!%TCPWARE_TELNET-I-OPTRECV, received DO TERMINAL-TYPE server says: I think you should do TERM-TYPE
!%TCPWARE_TELNET-I-SENT, sent WILL TERMINAL-TYPE client says: I will do TERM-TYPE if you ask me
!%TCPWARE_TELNET-I-OPTRECV, received DO WINDOW-SIZE server says: I think you should do WINDOW-SIZE
!%TCPWARE_TELNET-I-SENT, sent WILL WINDOW-SIZE client says: I will do WINDOW-SIZE if you ask me
!
! here the client send the WINDOW SIZE (why didn't the server ask for it?)
!
!%TCPWARE_TELNET-I-SENTSUBOPT, sent suboption SB WINDOW-SIZE 132 24 IAC SE
!
! here the server asks for the TERM-SPEED
!
!%TCPWARE_TELNET-I-OPTRECV, received DO TERMINAL-SPEED server says: I think you should do TERMINAL-SPEED
!%TCPWARE_TELNET-I-SENT, sent WILL TERMINAL-SPEED client says: I will do TERMINAL-SPEED
!
! here the server asks us to TOGGLE FLOW
! the client complies
!
!%TCPWARE_TELNET-I-OPTRECV, received DO TOGGLE-FLOW-CONTROL server says: I think you should do FLOW
!%TCPWARE_TELNET-I-SENT, sent WILL TOGGLE-FLOW-CONTROL client says: I will do FLOW
!
! here the server asks for the TERM-TYPE
! the client complies
!
!%TCPWARE_TELNET-I-SUBOPTRECV, received suboption SB TERMINAL-TYPE SEND SE server says: what is your TERM-TYPE?
!%TCPWARE_TELNET-I-SENTSUBOPT, sent suboption SB TERMINAL-TYPE IS VT400 SE client says: TERM-TYPE is VT400
!
! here the server asks for TERM-SPEED
! the client complies
!
! *** WARNING ***
!%TCPWARE_TELNET-I-SUBOPTRECV, received suboption SB TERMINAL-SPEED SEND SE server says: what is you TERM-SPEED?
!%TCPWARE_TELNET-I-SENTSUBOPT, sent suboption SB TERMINAL-SPEED IS 9600,9600 SE client says: TERM-SPEED is...
!
!========================================================================================================================
! Trace-2
! The following is a sample transaction from TCPware's TELNET-Client with debugging turned on (NSR - 2007-07-30)
! I was connecting from TCPware-5.7-2 on OpenVMS-8.2 to Solaris-8
!========================================================================================================================
!TELNET> set DEBUG/class=all
!%TCPWARE_TELNET-I-SHOWDBG, will show options processing
!%TCPWARE_TELNET-I-SHOWDBG, will show terminal input
!%TCPWARE_TELNET-I-SHOWDBG, will show network input
!%TCPWARE_TELNET-I-SHOWDBG, will show network output
!TELNET> connect 142.180.221.246 this is where I started the connection
!%TCPWARE_TELNET-I-TRYING, trying kawc3w.on.bell.ca,telnet (142.180.221.246,23) ...
!%TCPWARE_TELNET-I-ESCCHR, escape (attention) character is "^\"
!
!%TCPWARE_TELNET-I-OPTRECV, received DO TERMINAL-TYPE Solaris asks if we can do TERMINAL-TYPE
!%TCPWARE_TELNET-I-SENT, sent WILL TERMINAL-TYPE TCPware says yes
!%TCPWARE_TELNET-I-OPTRECV, received DO WINDOW-SIZE Solaris asks if we can do WINDOW-SIZE
!%TCPWARE_TELNET-I-SENT, sent WILL WINDOW-SIZE TCPware says yes
!%TCPWARE_TELNET-I-SENTSUBOPT, sent suboption SB WINDOW-SIZE 132 24 IAC SE then elaborates further
!%TCPWARE_TELNET-I-OPTRECV, received DO X-DISPLAY-LOCATION Solaris asks if we can do X-DISPLAY-LOCATION
!%TCPWARE_TELNET-I-SENT, sent WON'T X-DISPLAY-LOCATION TCPware say no
!%TCPWARE_TELNET-I-OPTRECV, received DO 39 (unsupported) I'm not sure about this
!%TCPWARE_TELNET-I-SENT, sent WON'T 39 (unsupported) But TCPware refused to do it
!%TCPWARE_TELNET-I-OPTRECV, received DO 36 (unsupported) I'm not sure about this
!%TCPWARE_TELNET-I-SENT, sent WON'T 36 (unsupported) But TCPware refused to do it
!%TCPWARE_TELNET-I-OPTRECV, received DON'T X-DISPLAY-LOCATION Solaris acks our WONT
!%TCPWARE_TELNET-I-OPTRECV, received DON'T 39 (unsupported) Solaris acks our WONT
!%TCPWARE_TELNET-I-OPTRECV, received DON'T 36 (unsupported) Solaris acks our WONT
!%TCPWARE_TELNET-I-SUBOPTRECV, received suboption SB TERMINAL-TYPE SEND SE Solaris wants to know about our terminal
!%TCPWARE_TELNET-I-SENTSUBOPT, sent suboption SB TERMINAL-TYPE IS VT200 SE TCPware tells Solaris is is a VT200
!
!SunOS 5.8
!
!
!%TCPWARE_TELNET-I-OPTRECV, received WILL ECHO far end offers to ECHO
!%TCPWARE_TELNET-I-SENT, sent DO ECHO we say OK
!%TCPWARE_TELNET-I-SENT, sent DO SUPPRESS-GO-AHEAD we command far-end to SUPPRESS-GO-AHEAD
!%TCPWARE_TELNET-I-SENT, sent WILL SUPPRESS-GO-AHEAD we say we will SUPPRESS-GO-AHEAD
!%TCPWARE_TELNET-I-OPTRECV, received WILL SUPPRESS-GO-AHEAD far end acks our SUPPRESS-GO-AHEAD
!%TCPWARE_TELNET-I-OPTRECV, received DO ECHO far end acks our DO ECHO
!login: received far-end prompt
!%TCPWARE_TELNET-I-SENT, sent WON'T ECHO (is this to hide the password?)
!%TCPWARE_TELNET-I-OPTRECV, received DO SUPPRESS-GO-AHEAD
!%TCPWARE_TELNET-I-OPTRECV, received DON'T ECHO at this point I hit <enter>
!login: ibam far-end prompt is shown again
!Password: I typed in our password
!Last login: Tue Jul 31 11:59:06 from kawc09.on.bell.c
!Sun Microsystems Inc. SunOS 5.8 Generic Patch October 2001
!========================================================================================================================
! Trace-3
! The following is a sample transaction from TCPware's TELNET-Client with debugging turned on (NSR - 2007-08-01)
! I was connecting from "TCPware-5.7-2 on OpenVMS-8.2" to "TCPware-5.7-2 on OpenVMS-8.2"
!========================================================================================================================
!TELNET> set debug/class=all
!%TCPWARE_TELNET-I-SHOWDBG, will show options processing
!%TCPWARE_TELNET-I-SHOWDBG, will show terminal input
!%TCPWARE_TELNET-I-SHOWDBG, will show network input
!%TCPWARE_TELNET-I-SHOWDBG, will show network output
!TELNET> open 142.180.39.15 this is where I started the connection
!%TCPWARE_TELNET-I-TRYING, trying kawc15.on.bell.ca,telnet (142.180.39.15,23) ...
!%TCPWARE_TELNET-I-ESCCHR, escape (attention) character is "^\"
!
!%TCPWARE_TELNET-I-OPTRECV, received WILL ECHO far-end offers to ECHO
!%TCPWARE_TELNET-I-SENT, sent DO ECHO we say OK
!%TCPWARE_TELNET-I-SENT, sent DO SUPPRESS-GO-AHEAD we command far-end to SUPPRESS-GO-AHEAD
!%TCPWARE_TELNET-I-SENT, sent WILL SUPPRESS-GO-AHEAD we offer to SUPPRESS-GO-AHEAD
!%TCPWARE_TELNET-I-OPTRECV, received WILL SUPPRESS-GO-AHEAD we receive an ACK for DO SUPPRESS-GO-AHEAD
!%TCPWARE_TELNET-I-OPTRECV, received DO SUPPRESS-GO-AHEAD we receive an ACK
!%TCPWARE_TELNET-I-OPTRECV, received DO TERMINAL-TYPE we are asked if we can DO TERMINAL-TYPE
!%TCPWARE_TELNET-I-SENT, sent WILL TERMINAL-TYPE we say yes
!%TCPWARE_TELNET-I-OPTRECV, received DO WINDOW-SIZE we are asked if we can DO WINDOW-SIZE
!%TCPWARE_TELNET-I-SENT, sent WILL WINDOW-SIZE we say yes
!%TCPWARE_TELNET-I-SENTSUBOPT, sent suboption SB WINDOW-SIZE 132 24 IAC SE then elaborate further
!%TCPWARE_TELNET-I-OPTRECV, received DO TERMINAL-SPEED we are asked if we can DO TERMINAL-SPEED
!%TCPWARE_TELNET-I-SENT, sent WILL TERMINAL-SPEED we say yes
!%TCPWARE_TELNET-I-OPTRECV, received DO TOGGLE-FLOW-CONTROL we are requested to DO TOGGLE-FLOW-CONTROL
!%TCPWARE_TELNET-I-SENT, sent WILL TOGGLE-FLOW-CONTROL we ack that request
!
!
!*** WARNING ***
!
! THE PROGRAMS AND DATA STORED ON THIS SYSTEM ARE LICENSED TO OR ARE
! PRIVATE PROPERTY OF THIS COMPANY AND ARE LAWFULLY AVAILABLE ONLY TO
!%TCPWARE_TELNET-I-SUBOPTRECV, received suboption SB TERMINAL-TYPE SEND SE we are asked our terminal type
!%TCPWARE_TELNET-I-SENTSUBOPT, sent suboption SB TERMINAL-TYPE IS VT200 SE so we send it
! AUTHORIZED USERS FOR APPROVED PURPOSES. UNAUTHORIZED ACCESS TO ANY
! PROGRAM OR DATA ON THIS SYSTEM IS NOT PERMITTED, AND ANY UNAUTHORIZED
! ACCESS BEYOND THIS POINT MAY LEAD TO PROSECUTION. THIS SYSTEM MAY BE
! MONITORED AT ANY TIME FOR OPERATIONAL REASONS, THEREFORE, IF YOU ARE
! NOT AN AUTHORIZED USER, DO NOT ATTEMPT TO LOGIN.
!
! LES PROGRAMMES ET LES DONNEES STOCKES DANS CE SYSTEME SONT VISES
! PAR UNE LICENCE OU SONT PROPRIETE PRIVEE DE CETTE COMPAGNIE ET ILS
! NE SONT ACCESSIBLES LEGALEMENT QU'AUX USAGERS AUTORISES A DES FINS
! AUTORISEES. IL EST INTERDIT D'Y ACCEDER SANS AUTORISATION, ET TOUT
! ACCES NON AUTORISE AU DELA DE CE POINT PEUT ENTRAINER DES POURSUITES.
! LE SYSTEME PEUT EN TOUT TEMPS FAIRE L'OBJET D'UNE SURVEILLANCE. SI
! VOUS N'ETES PAS UN USAGER AUTORISE, N'ESSAYEZ PAS D'Y ACCEDER.
!
!%TCPWARE_TELNET-I-SUBOPTRECV, received suboption SB TERMINAL-SPEED SEND SE we are asked our terminal speed
!%TCPWARE_TELNET-I-SENTSUBOPT, sent suboption SB TERMINAL-SPEED IS 9600,9600 SE we send it
!Username: neil far-end prompt (from OpenVMS)
!Password:
!==========================================================================================
! 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
!==========================================================================================
32010 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
!
!===================================================================================================================
! Title : Wcsm_DT_Stamp16.inc
! Author : Neil S. Rieck
! Purpose: an external function to return a y2k compliant system time in the form ccyymmddhhmmsstt (16 chars)
! Notes : all our programs call this function so optimizations here will speed up the whole system
! History:
! 100h NSR 070704 1. created this function from Wcsm_DT_Stamp15 by adding hundredth digit
!===================================================================================================================
32020 function string Wcsm_DT_Stamp16 !
option type=explicit ! cuz tricks are for kids...
declare long sys_status !
!
%include "starlet" %from %library "sys$library:basic$starlet" ! system services
%include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$
!
! this map is required for the call to sys$asctim (format: 19-JUN-1998 23:59:59.1)
!
map (WcsmDTStamp0) string Sys_buf_23 = 23, ! &
Sys_align = 0 !
map (WcsmDTStamp0) string Sys_day = 2, ! &
Sys_dash1 = 1, !- &
Sys_month = 3, ! &
Sys_dash2 = 1, !- &
Sys_year = 4, ! &
Sys_space = 1, ! &
Sys_Hour = 2, ! &
Sys_colon1 = 1, !: &
Sys_Minute = 2, ! &
Sys_colon2 = 1, !: &
Sys_Second = 2, ! &
Sys_period = 1, !. &
Sys_Tenth = 1, ! &
Sys_Hundredth = 1, ! &
Sys_align = 0 !
!
! map for Wcsm date (output)
!
map (WcsmDTStamp1) string Wcsm_buf_16 = 16, ! &
Wcsm_align = 0 !
map (WcsmDTStamp1) string Wcsm_year = 4, ! &
Wcsm_month = 2, ! &
Wcsm_day = 2, ! &
Wcsm_Hour = 2, ! &
Wcsm_Minute = 2, ! &
Wcsm_Second = 2, ! &
Wcsm_Fraction = 2, ! &
Wcsm_align = 0 !
map (WcsmDTStamp1) string Wcsm_year = 4, ! &
Wcsm_month_tens = 1, ! &
Wcsm_month_ones = 1, ! &
Wcsm_day_tens = 1, ! &
Wcsm_day_ones = 1, ! &
Wcsm_Hour = 2, ! &
Wcsm_Minute = 2, ! &
Wcsm_Second = 2, ! &
Wcsm_Tenth = 1, ! &
Wcsm_Hundredth = 1, ! &
Wcsm_align = 0 !
!
! string constants
! 00000000011111111112222222222333333333
! 12345678901234567890123456789012345678
declare string constant k_month_names$ = "XXJANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
! ||
! ++-- so I don't have to provide an offset in pos()
declare string constant my_space = '32'C
!
! <<< function 'code' starts here >>>
!
when error in !
!
sys_status = sys$asctim(,Sys_buf_23,,) ! get ASCII time into sys_buf_23
!~~~ if (sys_status and 7%) <> 1% then cause error 11 x not required - call will never fail
!
! transfer data from one map to the other
!
Wcsm_year = Sys_year !
!~~~ rset Wcsm_month = str$( pos(k_month_names$,Sys_Month,1%) / 3%) x bf_100f
Wcsm_day = Sys_day !
Wcsm_hour = Sys_hour !
Wcsm_minute = Sys_minute !
Wcsm_second = Sys_second !
Wcsm_tenth = Sys_tenth ! bf_100g
Wcsm_hundredth = Sys_Hundredth ! bf_100h
!
declare long temp% ! bf_100f
temp% = pos(k_month_names$,Sys_Month,1%) / 3% ! compute month number bf_100f
if temp% < 10% then ! if less than 10... bf_100f
Wcsm_month_ones = str$(temp%) ! ...then this goes into ONES bf_100f
Wcsm_month_tens = "0" ! ...and this goes into TENS bf_100f
else ! else >= 10 bf_100f
Wcsm_month = str$(temp%) ! bf_100f
end if
!
! make sure there are no spaces in the TENS area of our mapped variables (pad with '0' if necessary)
!
!~~~ Wcsm_month_tens = "0" if Wcsm_month_tens = my_space x disabled - see above code bf_100f
Wcsm_day_tens = "0" if Wcsm_day_tens = my_space !
!
! now pass result back to caller
!
Wcsm_DT_Stamp16 = Wcsm_Buf_16 ! this is it folks
use
Wcsm_DT_Stamp16 = "" ! error so return blank
end when
!
END Function