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 OpenVMS
Back to OpenVMS Demo Index
Back to Home
Neil Rieck
Kitchener - Waterloo - Cambridge, Ontario, Canada.