OpenVMS Source Code Demos
ICSIS_TO_SMTP_INTERFACE.BAS
1000 %title "ICSIS_TO_SMTP_INTERFACE_xxx.bas"
%ident "version_104.3" ! <<<---***
declare string constant k_version = "104.3" , ! &
k_program = "ICSIS_TO_SMTP_INTERFACE" !
!=========================================================================================================================
! Title : ICSIS_to_SMTP_INTERFACE_xxx.BAS !
! Author : Neil Rieck
! Purpose: send mail messages directly to an SMTP server on port 25
! Notes : 1. by declaring the passing mechanisms in the external statements, it seems that we don't need to use
! VAX-BASIC's LOC() statement to substitute for an ampersand (address ref) in DEC-C and VAX-C
! 2. this program must be built (from DCL) as follows:
! $ basic file.bas
! $ link file, sys$input/options
! tcpware:tellib/lib
! sys$share:tcpware_socklib_shr/share
!=========================================================================================================================
! History:
! ver who when what
! --- --- ------ ---------------------------------------------------------------------------------------------------------
! 100 NSR 090426 1. original demo program (with hard coded test messages)
! 101 NSR 090510 1. tweaked before placing in public domain
! 102 NSR 090510 1. tweaked for Bell use
! 103 NSR 090511 1. started adding code for use with our enhanced ESPP system
! 090512 2. more work
! 090513 3. more work
! 104 NSR 090513 1. more work
! 090514 2. more work
! 3. created function wcsm_get_mime_time
!=========================================================================================================================
option type = explicit ! no kid stuff...
set no prompt !
!
! constants
!
declare word constant k_recv_size_w = 32700 !
declare word constant k_xmit_size_w = 4096 !
declare long constant k_sleep_time = 10 !
!
! system declarations
!
%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$
%include "$secdef" %from %library "sys$library:basic$starlet" ! sec$
%include "$libdtdef" %from %library "sys$library:basic$starlet" ! eg. LIB$K_DELTA_SECONDS_F
%include "$libdef" %from %library "sys$library:basic$starlet" ! eg. lib$_normal
%include "$jpidef" %from %library "sys$library:basic$starlet" ! jpi$
%include "[.inc]VMS_Structures.inc" ! IOSB recs etc.
!
! home brewed functions
!
external string function wcsm_trnlnm (string, string) !
external string function wcsm_dt_stamp !
external long function get_timer_bit_vector(long) ! required for used with SYS$WFLOR
external string function format_dt !
external string function wcsm_get_mime_time !
!
! local declarations
!
declare long debug% , ! &
rc% , ! return code &
i% , ! &
stage% , ! for flow tracing &
ccb% , ! connection control block &
sleep_counter% , ! time stamp period &
timer_event_flag% , ! timer event flag &
timer_ef_state% , ! timer event flag state &
tcp_event_flag% , ! tcp event flag &
tcp_ef_state% , ! tcp event flag state &
mask% , ! required for sys$wflor &
try% , ! &
read_miss% , ! &
read_count% , ! &
junk% , ! &
request_coldstart% , ! &
fail_safe% , ! &
error_handler% , ! when error test &
field_name% , ! count fields &
connected_once% , ! &
word recvlen_w% , ! &
sendbuf_w% , ! &
my_port_w% , ! &
received_bytes_waiting_w% , ! &
string default_node$ , ! &
msg$ , ! &
msg_previous$ , ! &
src_node$ , ! &
dest_node$ , ! &
dest_port$ , ! &
user_name$ , ! &
pass_word$ , ! &
target_id$ , ! logical &
temp$ , ! &
junk$ , ! &
my_date$ , ! &
default_dir$ , ! default dir &
wrkg_buff$ , ! working buffer &
collapsed$ , ! collapsed buffer &
choice$ , ! pick a command &
temp_to$ , ! &
temp_from$ , ! &
temp_subj$ , ! &
temp_body$ , ! &
temp_mime$ , ! &
content_type$ , ! &
basic$QuadWord DeltaQuad ! for sys$bintim etc.
!
declare rfa rfa93 !
!
map(smtpbuf)string ! &
sendbuf$ = k_xmit_size_w , ! &
recvbuf$ = k_recv_size_w !
!
declare string constant dq = '34'C ! double quote (ascii 34)
!
! <<< TCPware definitions >>>
!
%include "[.inc]tcpware_ccb_definitions.inc" ! ccb definitions
!
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_get_ccb( long by ref , ! ccb-ptr &
word by ref , ! field-code &
any by ref ) ! value
!
external long function tel_deallocate_ccb( long by ref ) ! ccb-ptr
!
external long function tel_close_connection( long by ref ) ! ccb-ptr
!
external long function tel_abort_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 &
long by value , ! cmd-rtn &
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
!
!==========================================================================================
!
! /// Jpi Setup ///
!
record JpiRec ! structure of Jpi Record
ItemRec ItemVar(0) ! 0 -> 0 items
long list_term ! mark end-of-list
end record JpiRec !
!
declare JpiRec JpiBuf ! Now declare a variable using it
!
! Storage for info returned by GETJpi
!
MAP(Jpi)string ProcName = 15 , ! process name &
long ProcName_L ! returned length of PROC NAME
!
!========================================
! Make JpiBuf Entries
!========================================
!
JpiBuf::ItemVar(0%)::BuffLen = 15 ! 4 bytes (1 long)
JpiBuf::ItemVar(0%)::ItemCode = Jpi$_Prcnam ! Process Name
JpiBuf::ItemVar(0%)::BuffAddr = LOC( ProcName) !
JpiBuf::ItemVar(0%)::RtnLenAdr = LOC( ProcName_L) !
!
JpiBuf::LIST_TERM = Jpi$C_ListEnd ! end of list
!
!====================================================================================================
! init
!====================================================================================================
init: !
margin #0, 132 ! width for the log file
print k_program +"_"+ k_version !
print string$(len(k_program +"_"+ k_version), asc("=")) ! underline previous line (how will this optimize?)
print "-i- time: "+ format_dt( wcsm_dt_stamp ) !
print "-i- mime time: "+ wcsm_get_mime_time !
debug% = 0 ! init
connected_once% = 0 !
request_coldstart% = 0 !
!
when error in !
print !
print "You have 5 seconds to answer the next question <<<---***" !
print "(on timeout, this program will use logical ICSIS_TO_SMTP_DEBUG)"
print "Debug Menu:" !
print " 0 = errors" !
print " 1 = errors + informationals" !
print " 2 = errors + informationals + data" !
wait 5 !
input "Enter Debug Level? (0-2, defaults to 0) "; temp$ !
error_handler% = 0 !
use !
print "-i- timer expired" !
temp$ = edit$( WCSM_TrnLnm( "ICSIS_TO_SMTP_DEBUG", "LNM$SYSTEM_TABLE" ),32+4+2)
end when !
!
! note: some debug logicals use YES/NO so we'll support this as well as numbers
!
select left$(temp$,1) ! YES -> Y
case "Y" !
temp$ = "2" !
case "N" !
temp$ = "0" !
end select !
when error in !
debug% = integer(temp$) !
use !
debug% = 0 !
end when !
print "-i- program Started with a Debug Level of "; debug% !
!
rc% = sys$GetJpiW(,0%,,JpiBuf,,,) ! get our process name
print "-e- GetJpiW rc: "+ str$(rc%) if ((rc% and 7%) <> 1) !
print "-i- ProcName: "+ left$(ProcName,ProcName_L) !
goto main_loop2 ! bypass first sleep
!
!========================================================================================================================
! main loop
!========================================================================================================================
main: !
when error in !
close 93 !
use !
end when !
print "-i- starting "+ str$(k_sleep_time) +" second sleep at time: "+ format_dt( wcsm_dt_stamp ) if debug% >= 1
sleep 10 ! kill some time
print "-i- running" if debug% >= 1 !
main_loop2: !
!
map (smtprequest) string d93_smtp_whole_record = 1000 , ! &
d93_smtp_align = 0 !
map (smtprequest) string d93_smtp_stamp_request = 14 , ! 14 ccyymmddhhmmss &
d93_smtp_stamp_sent = 14 , ! 28 &
d93_smtp_to = 50 , ! 78 &
d93_smtp_from = 50 , ! 128 &
d93_smtp_subject = 50 , ! 178 &
d93_smtp_urgent = 1 , ! 1 &
d93_smtp_body = 820 , ! 999 &
d93_smtp_mode = 1 , !1000 H=HTML else PLAIN &
d93_smtp_align = 0 !
when error in !
open "csmis$dat:icsis_to_smtp_interface_100.dat" as #93 &
,organization indexed &
,map smtprequest &
,primary key d93_smtp_stamp_request duplicates &
,alternate key (d93_smtp_stamp_sent,d93_smtp_stamp_request) duplicates changes &
,access modify &
,allow modify !
find #93, key#1 nxeq "88881231595959", regardless ! set key of reference
error_handler% = 0 ! cool
use !
error_handler% = err ! oops
end when !
select error_handler% !
case 0 ! we've found something
case 11,155 ! EOF, FNF
goto main !
case else !
print "-e- "+ format_dt( wcsm_dt_stamp )+" status: "+ str$(error_handler%) +" during open-find-93"
goto main !
end select !
!
! get next request (come back here after sending the current message)
!
get_next_request:
when error in !
get #93 ! get w/lock
error_handler% = 0 ! cool
use !
error_handler% = err ! oops
select error_handler% !
case 19, 138, 154 ! locked
print "-w-locked record" !
print " request: "+ d93_smtp_stamp_request !
print " sent : "+ d93_smtp_stamp_sent !
print " to : "+ edit$(d93_smtp_to ,2) !
print " from : "+ edit$(d93_smtp_from ,2) !
print " subject: "+ edit$(d93_smtp_subject ,2) !
retry ! get next record
end select !
end when !
!
select error_handler% !
case 0 !
temp_to$ = edit$(d93_smtp_to ,2) !
temp_from$ = edit$(d93_smtp_from ,2) !
temp_from$ = "custodian" if temp_from$ = "" !
if pos(temp_from$,"@",1)=0 then ! if no node was given (then we need to patch)
if pos(edit$(temp_from$,32), "ESPPATS",1) > 0 then ! if this is for esppats
if pos(edit$(src_node$,32+2),"BELLICS",1) > 0 then ! if on the intenet
temp_from$ = temp_from$ +"@"+ src_node$ ! then use this node name
else ! else must be behind the firewall
temp_from$ = temp_from$ +"@bell.ca" ! so use the public email name
end if !
else !
temp_from$ = temp_from$ +"@"+ src_node$ !
end if !
end if !
temp_subj$ = edit$(d93_smtp_subject,128+8) !
temp_subj$ = "Msg: "+ format_dt( wcsm_dt_stamp ) if temp_subj$ = ""
temp_body$ = edit$(d93_smtp_body ,128) !
select d93_smtp_mode
case "H","h"
content_type$ = "text/html"
case else
content_type$ = "text/plain"
end select
select edit$(d93_smtp_urgent ,32) !
case "Y" !
temp_mime$ = &
"Subject: "+ temp_subj$ + cr + lf + &
"From: "+ temp_from$ + cr + lf + &
"To: "+ temp_to$ + cr + lf + &
"Date: "+ wcsm_get_mime_time + cr + lf + &
"Message-ID: <"+ wcsm_dt_stamp + wcsm_dt_stamp +">" + cr + lf + &
"MIME-Version: 1.0" + cr + lf + &
"Content-Type: "+ content_type$ + cr + lf + &
"X-Priority: 1" + cr + lf + &
"X-MSMail-Priority: High" + cr + lf + &
"Importance: high" + cr + lf + cr + lf
case else !
temp_mime$ = &
"Subject: "+ temp_subj$ + cr + lf + &
"From: "+ temp_from$ + cr + lf + &
"To: "+ temp_to$ + cr + lf + &
"Date: "+ wcsm_get_mime_time + cr + lf + &
"Message-ID: <"+ wcsm_dt_stamp + wcsm_dt_stamp +">" + cr + lf + &
"MIME-Version: 1.0" + cr + lf + &
"Content-Type: "+ content_type$ + cr + lf + cr + lf
end select !
case 11, 155 ! eof, rnf
goto main !
case else !
print "-e- "+ format_dt( wcsm_dt_stamp )+" status: "+ str$(error_handler%) +" during get-93"
goto main !
end select !
!
! <<< start a connection >>>
!
sendbuf$ = "" !
recvbuf$ = "" !
!
! <<< get some event flags for later >>>
!
if tcp_event_flag% = 0 then ! if not yet allocated
rc% = lib$get_EF( tcp_event_flag% ) ! get an event flag
if ((rc% and 7%) <> 1) then !
print "lib$get_EF-1 rc: ";str$(rc%) !
goto rc_exit !
end if !
end if !
!
! hardened code
! two event flags are used:
! 1. one event flag (tcp_event_flag%) is used to detect when data has arrived from the other end
! 2. a second event flag (timer_event_flag%) is used to determine when a no activity timer has expired
!
if timer_event_flag% = 0 then ! if not yet allocated
rc% = lib$get_EF( timer_event_flag% ) ! get another event flag
if ((rc% and 7%) <> 1) then !
print "lib$get_EF-2 rc: ";str$(rc%) !
goto rc_exit !
end if !
end if !
!
! have the system allocate a connection control block and save the address in ccb%
!
if ccb% = 0 then ! if not yet allocated
declare string constant k_stage1 = ">>> tel func: allocate" !
stage% = 1 !
print k_stage1 if debug% >= 1 !
rc% = tel_allocate_ccb( ccb%, k_recv_size_w, k_xmit_size_w ) ! allocate a ccb and then address in ccb%
gosub display_rc !
goto rc_exit if (rc% and 1%) <> 1% ! this may be too drastic ???
end if !
!
! <<< open a connection >>>
!
declare string constant k_stage3 = ">>> tel func: open" !
stage% = 3% !
print k_stage3 if debug% >= 1 !
src_node$ = edit$( WCSM_TrnLnm( "TCPIP_DOMAINNAME", "LNM$SYSTEM_TABLE" ),32+4+2)
dest_node$ = "127.0.0.1" !
dest_port$ = "25" !
!
if debug% >= 1 then !
print "-i- src node : ";src_node$ !
print "-i- dest node : ";dest_node$ !
print "-i- port : ";dest_port$ !
end if !
my_port_w% = integer(dest_port$) ! prep for open
!
! note: this isn't stated in the manual, but you'll get an error if timeout isn't >=20 or 0
!
rc% = tel_open_connection( &
ccb% ,! ccb-ptr &
,! ia (use IA or HOST, not both) &
dest_node$ ,! host (use IA or HOST, not both) &
,! cmd-rtn must leave blank for NONE &
tcp_event_flag% ,! efn &
,! ast-addr must leave blank for NONE &
my_port_w% ,! port (7=echo, 23=telnet , 25=smtp) &
20% ! timeout in seconds &
)
gosub display_rc !
if (rc% and 1%) <> 1% then !
goto close_connection_n_exit !
end if !
!
try% = 1 ! init to stage 1
goto wait_for_response !
!
! <<< send the data (loop) >>>
!
send_data_loop: !
declare string constant k_stage4 = ">>> tel func: send data" !
stage% = 4% !
print k_stage4 if debug% >= 1 !
print "-i- time: "+ format_dt( wcsm_dt_stamp ) +" -------------->>> doing try: "+ str$(try%) if debug% >= 1
select try% !
case 1 ! place-holder (initial wait for response)
goto wait_for_response !
case 2 ! log on to the specified SMTP server
msg$ = "HELO "+ src_node$ + cr + lf !
case 3 ! send MAIL FROM
msg$ = "MAIL FROM: <"+ temp_from$ +">" + cr + lf !
case 4 ! send RCPT TO
msg$ = "RCPT TO: <"+ temp_to$ +">" + cr + lf !
case 5 ! send DATA
msg$ = "DATA" + cr + lf !
case 6 ! send data line
my_date$ = date4$(0) ! dd-Mmm-yyyy
for i% = 1 to len(my_date$) !
if mid$(my_date$,i%,1) = "-" then !
mid$(my_date$,i%,1) = " " ! dd Mmm yyyy
end if !
next i% !
!
!
msg$ = temp_mime$ + ! &
temp_body$ + ! &
cr + lf +"."+ cr + lf !
case 7 ! send QUIT
msg$ = "QUIT"+ cr + lf !
case 8 !
if debug% >= 2 then !
print "-d- ====================================" !
print "-d- the SMTP comm process was successful" !
print "-d- ====================================" !
end if !
gosub close_telnet_connection !
when error in !
d93_smtp_stamp_sent = wcsm_dt_stamp !
update #93 !
error_handler% = 0 !
use !
error_handler% = err !
end when !
if error_handler% <> 0 then !
print "-e- error: "+ str$(error_handler%) +" during update-93"
sleep 2 !
end if !
goto get_next_request !
case else ! shouldn't ever happen...
print " (???) oops!" !
goto close_connection_n_exit !
end select !
sendbuf$ = msg$ !
sendbuf_w% = len(msg$) !
print "-d- xmit data>";msg$;"<" if debug% >= 2 !
rc% = tel_send_data ( ccb%, sendbuf$, sendbuf_w% ) !
gosub display_rc !
goto close_connection_n_exit if (rc% and 1%) <> 1% !
!
!----------------------------------------------------------------------------------------------------
! data has now been sent so we'll wait for an event flag
!----------------------------------------------------------------------------------------------------
wait_for_response:
read_miss% = 0 ! init
read_count% = 0 !
wrkg_buff$ = "" !
!
wait_for_response_loop:
declare string constant k_stage5 = ">>> tel func: wait"
stage% = 5%
print k_stage5 if debug% >= 1
!
! <<< arm a timer to expire 'x' time from now >>>
!
read_count% = read_count% + 1 !
select read_count% !
case 1 ! if first time thru...
junk$ = "0 00:00:05" ! then we will only wait 5 seconds
case else ! else..,
junk$ = "0 00:00:00.10" ! we will only wait 100 mS (read buf)
end select !
!
rc% = sys$bintim(junk$, DeltaQuad ) ! init delta time ('x' time from now)
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 >>>
!
print "-i- waiting for flag ";tcp_event_flag%; " or flag "; timer_event_flag%; " time: "+ format_dt( wcsm_dt_stamp ) &
if debug% >= 1
!
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%) !
gosub display_rc !
goto close_connection_n_exit if (rc% and 1%) <> 1% !
print "-i- waking from event some flag at time: "+ format_dt( wcsm_dt_stamp ) if debug% >= 1
!
! <<< cancel all timer requests (if any) >>>
!
print "-i- Calling $CanTim" if debug% >= 1
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 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 debug% >= 1 ! here is our EOL
!
! 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
if read_count% = 1 then
print "-e- oops, no response on read #1 (really bad)"
else
print "-i- no response on read #"+ str$(read_count%) if debug% >= 1
end if
read_miss% = read_miss% + 1 ! so up the read miss count
if read_miss% <= 1 then
goto wait_for_response_loop if read_miss% < 2 ! loop if less than 2
else !
goto read_exit !
end if !
else ! we've got TCP data so fall thru
end if !
!
! <<< receive the data >>>
!
declare string constant k_stage6 = ">>> tel func: recv data"
stage% = 6%
print k_stage6 if debug% >= 1
!
! read data from the TCP buffer
!
! Note: we get here via a test of TEL_GET_CCB to avoid polling with TEL_RECEIVE_DATA.
! See page 9-16 of the TCPware programmer's manual for details
!
rc% = tel_receive_data( ccb%, k_recv_size_w, recvbuf$, recvlen_w%) ! receive data <<<------***
select rc% !
case SS$_VCCLOSED, SS$_TIMEOUT, SS$_THIRDPARTY !
if try% = 7 then !
print "-w- connection closed unexpectedly ("+str$(rc%)+") during try: "+ str$(try%) if debug% >= 1
else !
print "-e- connection closed unexpectedly ("+str$(rc%)+") during try: "+ str$(try%)
end if !
goto read_exit !
case else !
gosub display_rc !
goto close_connection_n_exit if (rc% and 1%) <> 1% !
end select !
!
if debug% >= 2 then !
print "-d- recv data >"+ left$(recvbuf$, recvlen_w%);"<" !
print "-d- recv count: "+ str$(recvlen_w%) !
end if !
!
print "-i- read miss : "+ str$(read_miss%) if debug% >= 1 !
if recvlen_w% > 0 then ! we've got some data...
read_miss% = 0 ! ...so prep to continue (not a miss)
wrkg_buff$ = wrkg_buff$ + left$(recvbuf$, recvlen_w%) ! concat recv data into holding buffer
goto wait_for_response_loop ! loop back for more
end if !
!
if debug% >= 2 then !
print "-d- ============================================================" !
print "-d- wkg buffer len:"+str$(len(wrkg_buff$)) !
print "-d- wkg buffer>"; wrkg_buff$;"<" !
print "-d- try: "+ str$(try%) !
end if !
read_exit:
!
collapsed$ = edit$( wrkg_buff$, 128+32+16+8) ! cleanup for testing
select try% !
case 1 !
junk% = pos( collapsed$ , "220", 1) ! just opened the connection
goto fini if junk% <> 1 ! this is a demo so just exit on error
try% = try% + 1 !
goto send_data_loop !
case 2 ! HELO
junk% = pos( collapsed$ , "250", 1) ! pleased to meet you
goto fini if junk% <> 1 ! this is a demo so just exit on error
try% = try% + 1 !
goto send_data_loop !
case 3 ! MAIL FROM
junk% = pos( collapsed$ , "250", 1) ! delivered as
goto fini if junk% <> 1 ! this is a demo so just exit on error
try% = try% + 1 !
goto send_data_loop !
case 4 ! RCPT TO
junk% = pos( collapsed$ , "250", 1) ! delivered as
goto fini if junk% <> 1 ! this is a demo so just exit on error
try% = try% + 1 !
goto send_data_loop !
case 5 ! DATA
junk% = 0 !
junk% = 1 if pos( collapsed$ , "250", 1) = 1 !
junk% = 1 if pos( collapsed$ , "354", 1) = 1 !
goto fini if junk% <> 1 ! this is a demo so just exit on error
try% = try% + 1 !
goto send_data_loop !
case 6 ! data lines
junk% = pos( collapsed$ , "250", 1) ! delivered as
goto fini if junk% <> 1 ! this is a demo so just exit on error
try% = try% + 1 !
goto send_data_loop !
case 7 ! QUIT
junk% = pos( collapsed$ , "221", 1) ! delivered as
goto fini if junk% <> 1 ! this is a demo so just exit on error
try% = try% + 1 !
goto send_data_loop !
case else ! this should never happen
goto fini ! exit for now (dvlp)
end select !
!
! <<< close the connection >>>
!
close_connection_n_exit: !
gosub close_telnet_connection !
goto fini !
!
! <<< close telnet connection subroutine >>>
!
close_telnet_connection: !
declare string constant k_stage11 = ">>> tel func: close" !
stage% = 11
print k_stage11 if debug% >= 1 !
print "-i- Closing connection..." if debug% >= 1 !
rc% = tel_close_connection( ccb% ) ! this only closes my xmit...
gosub display_rc !
fail_safe% = 0 ! init fail safe counter
!
buffer_purge: !
print "-i- purging receive buffer <<<---***" if debug% >= 1 !
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% >= 1%
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 1 !
else ! some kind of error....
junk% = tel_abort_connection( ccb% ) ! don't take any chances
sleep 1 !
end if !
end select !
return !
!----------------------------------------------------------------------------------------------------
!
! <<< display return code after each call to the TELNET library >>>
!
display_rc:
if (rc% and 7%) <> 1% or ! if not -s- (success) &
debug% >= 1 ! or full debugging is enabled
then !
select stage% !
case 1
print k_stage1;
case 3
print k_stage3;
case 4
print k_stage4;
case 5
print k_stage5;
case 6
print k_stage6;
case 11
print k_stage11;
case else
print ">>> tel func: unknown: ";
end select
!
print " >>> "; !
select (rc% and 7%) !
case 0
print "-w-";
case 1
print "-s-";
case 2
print "-e-";
case 3
print "-i-";
case 4
print "-f-";
case else
print "-?-";
end select !
print " rc: ";str$(rc%) !
end if !
return !
!====================================================================================================
! <<< adios... >>>
!====================================================================================================
fini: !
rc% = 1 ! vms -s-
!
! rc% must be set up b4 this point (and must not be changed)
!
rc_exit:
!
! pre-exit clenaup (optional stuff but let's do it anyway)
!
print "-i- preparing to exit" !
gosub close_telnet_connection !
if ccb% <> 0% then !
junk% = tel_deallocate_ccb( ccb% ) !
print "-e- tel_deallocate_ccb rc: "+str$(junk%) if ((junk% and 7%) <> 1)
end if !
if tcp_event_flag% <> 0 then !
junk% = lib$free_EF( tcp_event_flag% ) ! free the event flag
print "-e- lib$free_EF-tcp rc: "+str$(junk%) if ((junk% and 7%) <> 1)
end if !
if timer_event_flag% <> 0 then
junk% = lib$free_EF( timer_event_flag% ) ! free the event flag
print "-e- lib$free_EF-timer rc: "+str$(junk%) if ((junk% and 7%) <> 1)
end if !
!
30000 end program rc% !
!
!========================================================================================================================
! external functions
!========================================================================================================================
31005 %include "[.fun]wcsm_get_mime_time.fun" !
! FUNCTION STRING wcsm_get_mime_time(string,string) !
!
31010 %include "[.fun]wcsm_trnlnm.fun"
! FUNCTION STRING WCSM_TRNLNM(LOGICAL_NAME, TABLE_NAME$)
!
31020 %include "[.fun]wcsm_dt_stamp.fun"
! FUNCTION STRING wcsm_dt_stamp
!
31030 function string format_dt(string inbound$) !
option type=explicit !
select len(inbound$) !
case 12 to 14 ! eg. CCYYMMDDhhmm or CCYYMMDDhhmmss
format_dt = left$(inbound$,8) +"."+ right$(inbound$,9) !
case 15 ! eg. CCYYMMDDhhmmsst
format_dt = left$(inbound$,8) +"."+ mid$(inbound$,9,6) + ! &
left$(inbound$,15) !
case else !
format_dt = inbound$ !
end select !
end function !
!
!======================================================================
! get timer bit vector
! (see OpenVMS system systevices documentation for "sys$wflor")
!
! notes: cluster event flags
! 0 00- 31
! 1 32- 63
! 2 64- 95
! 3 96-127
!======================================================================
31040 function long get_timer_bit_vector(long event_flag)
option type = explicit
declare long temp
!
select event_flag
case <= 31
temp = event_flag
case <= 63
temp = event_flag - 32
case <= 95
temp = event_flag - 64
case else
temp = event_flag -96
end select
!
select temp ! this code will avoid an integer overflow
case 31 ! need to set bit #31
! 33222222222211111111110000000000
! 10987654321098765432109876543210
get_timer_bit_vector = B"10000000000000000000000000000000"L ! so return this
case else !
get_timer_bit_vector = (2% ^ temp) ! else return this
end select
!
end function ! get_timer_bit_vector
!
Back to HomeNeil Rieck
Waterloo, Ontario, Canada.