OpenVMS Source Code Demos
TCPWARE_TELNET_SAMPLE
1000 %title "tcpware_telnet_sample"
%ident "version_103.4" ! <<<---+---***
declare string constant k_version = "103.4" , ! <<<---+ &
k_program = "tcpware_telnet_sample" !
!=========================================================================================================================
! Title : tcpware_telnet_sample_xxx.bas
! Author : Neil S. Rieck (Waterloo, Ontario, Canada)
! : (https://neilrieck.net) (mailto:[email protected])
! Purpose: to explore the possibility of doing TELNET from within VMS-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 1.6 under OpenVMS 8.2 using Process Software's TCPware 5.7-2
! 3. derived, in part, from file "telnet_sample.c" in TCPware's example directory which is
! copyrighted (c) by Process Software Corporation of Framingham, Massachusetts, USA.
! 4. this progarm must be built (from DCL) as follows:
! $ basic tcpware_telnet_sample_103.bas
! $ link tcpware_telnet_sample_103, -
! sys$input/options
! tcpware:tellib/lib
! sys$share:tcpware_socklib_shr/share
! $ exit
! 5. interface to DCL as a foreign command like so:
! $telnet_sample :== $my$demos:tcpware_telnet_sample_103.exe
! (where my$demos is a path specification)
! 6. 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)
! 7. This is just a demo so please disregard some early subroutine exits
!=========================================================================================================================
! History:
! ver who when what
! --- --- ------ ---------------------------------------------------------------------------------------------------------
! 100 NSR 991112 1. original program (derived from tcpware:telnet_sample.c)
! 101 NSR 070730 1. started added NVT support for port 23 (but will not work as a DCL foreign command)
! (this program will not connect to our older Solaris-8 systems unless the NVT handshake works properly
! and one of those handshakes must be TERM_TYPE)
! NSR 070731 2. cleaned up the code in a few places
! 3. started cleanup of the NVT handshake routine (see: port_23_user_cmd_proc)
! NSR 070801 4. more work
! NSR 070801 5. now send some telnet parameter negotiation requests when the connection is first opened
! 6. created a make-shift TELNET demo bf_101.7
! NSR 070802 7. 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
! 103 NSR 140825 1. added verbose messaging to the NVT handshake (need to debug a problem talking to Solaris-9)
! 2. use a map to convert bytes to words (so we don't see negative bytes)
! NSR 140826 3. simplified the NVT handshake
! 4. a little code mtce
!=========================================================================================================================
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 !
!
! this map is shared with subprogram "port_23_user_cmd_proc"
!
map(share) long debug_main , ! only used by main &
long debug_nvt , ! only used by port_23_user_cmd_proc &
long nvt_one_time , ! only used by port_23_user_cmd_proc &
long nvt_hs_count ! only used by 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$
%include "lib$routines" %from %library "sys$library:basic$starlet" ! lib$
!
external string function wcsm_dt_stamp16 ! ccyymmddHHMMSStt
external long function get_timer_bit_vector(long) ! required for used with SYS$WFLOR
external long port_23_user_cmd_proc ! an external sub process (telnet use only)
!
! 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$ = "" !
debug_main = 1 !
debug_nvt = debug_main !
nvt_one_time = 0 !
nvt_hs_count = 0 !
first_time% = 0 !
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 !
print "note: enter 11-13 to only debug the NVT handshake"
input "debug level? (0-3, default=0) ";junk% !
use !
junk% = 0 ! oops
end when !
select junk% !
case 0 to 3 ! previous functionality
debug_main = junk% !
debug_nvt = junk% !
case 11 to 13 ! new functionality
debug_main = 1 !
debug_nvt = junk% - 10 !
case else !
print "-e-Oops, no debugging for you" !
debug_main = 0 !
debug_nvt = 0 !
end select !
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 7%) <> 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 7%) <> 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 7%) <> 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 7%) <> 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 7%) <> 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 7%) <> 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
!
print "-i-sending initial blank line" if debug_main > 0
sendbuf_w% = 0
rc% = tel_send_command( ccb%, sendbuf$, sendbuf_w% ) !
if (rc% and 7%) <> 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 7%) <> 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% = 0 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% = 1 ! don't come back this way
end if !
wait 2 ! enable keyboard timer
print "-?-text to send (blank line to exit) ";
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 7%) <> 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 7%) <> 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 7%) <> 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 debug_main > 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 7%) <> 1%) !
goto close_connection if (rc% and 7%) <> 1% !
if debug_main >= 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 debug_main > 0 !
end if !
!
! <<< cancel all timer requests (if any) >>>
!
print "-i-Calling $CanTim" if debug_main > 0 !
rc% = sys$cantim(,) ! cancel all timer requests
print "-e-sys$cantim rc: "+ str$(rc%) if ((rc% and 7%) <> 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 debug_main >= 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 debug_main >= 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 debug_main > 0 !
goto read_exit !
else ! we've got TCP data so fall thru
print "-i-TCP data detected in buffer" if debug_main > 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, SS$_LINKDISCON !
print "-e-the connection closed unexpectedly ("+ str$(rc%) +")" !
goto close_connection ! cleanup etc.
case else !
goto close_connection if (rc% and 7%) <> 1% !
print "main ========================================================vvv" if debug_main >= 1
print "-i-recv>" +left$(recvbuf$, recvlen_w%) +"<" !
print "main ========================================================^^^" if debug_main >= 1
print "-i-recv count: "+ str$(recvlen_w%) if debug_main >= 1
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 debug_main > 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 debug_main > 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 debug_main > 0
select junk% !
case SS$_VCCLOSED, SS$_TIMEOUT, SS$_THIRDPARTY, SS$_LINKDISCON ! 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 debug_main > 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 debug_main > 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 debug_main > 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 called when an IAC (255) character is received in the data stream (it is not passed here)
! 2. This routine is supports the NVT WILL-WONT-DO-DONT handshake that begins every telent session
! 3. If you find a system you can't connect to, use 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 (it is better to refuse)
! 5. A really simple interface will support SUPPRESS_GA and refuse to do everything else
! 6. Less overhead will be involved overall if you refuse to let the far end ECHO
! 7. 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 a differnet map here so we don't clobber sendbuf$ in main
!
map(private) string sendbuf$ = k_xmit_size_w , ! &
recvbuf$ = k_recv_size_w ! superfluous?
!
! this map is sharred with main
!
map(share) long debug_main , ! shared with main &
long debug_nvt , ! only used here &
long nvt_one_time , ! only used here &
long nvt_hs_count ! only used here
!
! wee need this structure because VMS-BASIC does not have unsigned bytes
!
record switcheroo_rec !
variant !
case !
group a !
byte byte0 ! OpenVMS is little endian
byte byte1 !
end group !
case !
group b !
word word0 !
end group !
end variant !
end record !
!
declare switcheroo_rec switcher ! cuz all our bytes are signed (ugh)
!
external long function tel_send_command( long by ref , ! ccb-ptr &
string by ref , ! buffer &
word by ref ) ! byte-count
!
! see: RFC-854 to RFC-861
! 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: "iac will wont do dont"
!
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 &
kIS = 0 ,! IS TT (RFC-1091) &
kSEND = 1 ,! SEND TT (RFC-1091) &
kECHO = 1 ,! &
kSGA = 3 ,! supress go-ahead &
kSTATUS = 5 ,! &
kTIMING_MARK = 6 ,! &
kBM = 19 ,! Byte Macro &
kDET = 20 ,! Data Entry Terminal &
kTERM_TYPE = 24 ,! &
kWINDOW_SIZE = 31 ,! &
kTERM_SPEED = 32 ,! &
kREMOTE_FLOW_CTL= 33 ,! &
kLINE_MODE = 34 ,! &
XDISPLAY_LOC = 35 ,! &
kOLD_ENVIRON = 36 ,! old evironment &
kAUTHENTICATION = 37 ,! &
kNEW_ENVIRON = 39 ,! new evironment &
kTN3270E = 40 !
!====================================================================================================
! main (of port_23_user_cmd_proc)
!====================================================================================================
main: ! for sub 'port_23_user_cmd_proc'
switcher::word0 = 0 ! init both bytes
!
nvt_hs_count = nvt_hs_count + 1 ! update the handshake count
if debug_nvt >= 1 then !
print "port_23_user_cmd_proc ============================ begin" !
print "-i-nvt_hs_count:";nvt_hs_count ! lets see our handshake count
end if !
if (debug_nvt >= 3) or ! if full debug mode &
((debug_nvt >= 1) and (my_length% > 2)) ! or more than two bytes &
then !
print "-i-user_cmd_proc (inbound: params ): "; !
for z% = 0 to (my_length% -1) !
!~~~ print using "#### "; my_buf(z%); x ugh; signed bytes
switcher::byte0 = my_buf(z%) !
print using "#### ";switcher::word0; ! better
next z% !
print " (note: more than 2 bytes)"; if my_length% > 2
print ! EOL
end if !
!
switcher::byte0 = my_buf(0) ! extract command byte
cmd% = switcher::word0 !
!
switcher::byte0 = my_buf(1) ! extract option byte
opt% = switcher::word0 !
!
if debug_nvt >= 2 then !
print "-i-user_cmd_proc (inbound: cmd/opt): "; !
print using "#### ####"; cmd%; opt% !
end if !
!
! Example NVT handshakes:
!
! if we receive then send back
! ------------- --------------
! WILL SGA DO SGA (we want to supress go-ahead)
! WILL ECHO DONT ECHO (we do not want the server to echo)
! WILL anything else DONT anything else (refuse all)
! DO TERM_TYPE WILL TERM_TYPE (then be prepared FOR kSB TERM_TYPE)
! DO WINDOW-SIZE WONT WINDOW-SIZE (refuse commands to change our screen size)
! DO anything else DONT anything else (dont agree to anything else)
!
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 debug_nvt >= 1
select opt% !
case kSGA ! we want him to "supress go-ahead"
sendbuf$ = chr$(IAC) + chr$(DO ) + chr$(opt%) + ! DO: SUPPRESS_GA &
chr$(IAC) + chr$(WILL) + chr$(opt%) ! tell him we want to do the same thing
sendbuf_w% = 6 ! 3 bytes
case else !
sendbuf$ = chr$(IAC) + chr$(DONT) + chr$(opt%) ! DONT do anything else (including echo)
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 debug_nvt >= 1
select opt% !
case kSGA, kTERM_TYPE !
sendbuf$ = chr$(IAC) + chr$(WILL) + chr$(opt%) ! WILL: noun
sendbuf_w% = 3 !
case else !
sendbuf$ = chr$(IAC) + chr$(WONT) + chr$(opt%) ! WONT: everything else
sendbuf_w% = 3 !
end select !
case WONT ! received 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
!
print "-i-user_cmd_proc rcv-cmd : WONT "+ str$(opt%) if debug_nvt >= 1
sendbuf$ = chr$(IAC) + chr$(DONT) + chr$(opt%) !
sendbuf_w% = 3 !
case DONT ! received 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
!
print "-i-user_cmd_proc rcv-cmd : DONT "+ str$(opt%) if debug_nvt >= 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 debug_nvt >= 1
select opt% !
case kTERM_TYPE ! server wants to know our terminal type
print "TERM TYPE"
junk$ = chr$(IAC) + chr$(kSB) + chr$(opt%) + ! &
chr$(kIS) + ! RFC-1091 &
"VT200" + ! tell server we are VT200 &
chr$(IAC) + chr$(kSE) !
sendbuf$ = junk$ !
sendbuf_w% = len(junk$) !
case else ! oops...
print " ???? unsupported SB: "; str$(opt%) if debug_nvt >= 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 debug_nvt >= 1
sendbuf$ = "" !
sendbuf_w% = 0 !
end select !
!
if sendbuf_w% > 0 then ! if we have something to send...
if debug_nvt >= 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 kSGA !
print "SGA " !
case kSTATUS !
print "STATUS " !
case kTIMING_MARK !
print "TIMING_MARK " !
case kTERM_TYPE !
print "TERM_TYPE " !
case kWINDOW_SIZE !
print "WINDOW_SIZE " !
case kTERM_SPEED !
print "TERM_SPEED " !
case kREMOTE_FLOW_CTL !
print "REMOTE_FLOW_CTL" !
case kLINE_MODE !
print "LINE_MODE " !
case XDISPLAY_LOC ! comes from Solaris-8
print "XDISPLAY_LOC " !
case kOLD_ENVIRON !
print "OLD_ENVIRON " !
case kNEW_ENVIRON ! comes from Solaris-8
print "NEW_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 debug_nvt >= 1
!
rc% = tel_send_command( ccb%, sendbuf$, sendbuf_w% ) !
print "-i-user_cmd_proc snd-cmd rc:";rc% if debug_nvt >= 2 !
end if ! end if sendbuf_w% > 0
!
if debug_nvt >= 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 compiles
!
!%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 compiles
!
!%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 compiles
!
! *** 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