OpenVMS Source-Code Demos

ICSIS_TO_POP3_INTERFACE.BAS

1000	%title "ICSIS_TO_POP3_INTERFACE_100"
 	%ident			    "version_102.1"				! <<<---***
	declare string constant k_version = "102.1"			,	!						&
				k_program = "ICSIS_TO_POP3_INTERFACE"		!
	!=========================================================================================================================
	! Title  : ICSIS_to_POP3_INTERFACE_xxx.BAS				!
	! Author : Neil Rieck
	! Purpose: reading mail messages stored in an POP3 server on port 110
	! 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 program (with hard coded test messages)
	!	  090427 2. added support for more POP3 verbs
	!		 3. added more code for data extraction
	! 101 NSR 090510 1. tweaked before placing in public domain
	! 102 NSR 090510 1. tweaked for Bell use
	!=========================================================================================================================
	option type = explicit							! no kid stuff...
	set no prompt								!
	!
	!	constants
	!
	declare word constant k_recv_size_w	= 4096				!
	declare word constant k_xmit_size_w	= 1024				!
	declare long constant k_list_size	= 100				!
	!
	!	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					!
	!
	map (neil) long icsis_debug%						! this map also appears in the sub proc
	declare	long	rc%							,! return code				&
			i%							,! 					&
			list%							,!					&
			ptr%							,!					&
			x%							,!					&
			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		&
			dead_air_test%						,!					&
			try%							,!					&
			read_miss%						,!					&
			junk%							,!					&
			junk2%							,!					&
			channel_open%						,!					&
			cr%							,!					&
			lf%							,!					&
			start%							,!					&
			end1%							,!					&
			end2%							,!					&
			request_coldstart%					,!					&
			fail_safe%						,!					&
			error_handler%						,! when error test			&
			buff_len%						,! total len of buff			&
			read_only%						,! open read only			&
			buff_start% 						,! start of mlr				&
			buff_end%   						,! end of mlr				&
			buff_next_start% 					,! start of mlr				&
			buff_next_end%   					,! end of mlr				&
			field_name%						,! count fields				&
			file108_open%						,!					&
			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$							,!					&
			msg_num$						,!					&
			my_date$						,!					&
			default_dir$						,! default dir				&
			wrkg_buff$						,! working buffer			&
			collapsed$						,! collapsed buffer			&
			choice$ 						,! pick a command			&
			list$(k_list_size)					,!					&
	basic$QuadWord	DeltaQuad						 ! for sys$bintim etc.
	!
	declare rfa rfa96							!
	!
	map(POP3)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
	!
	!====================================================================================================
	!	main
	!====================================================================================================
	main:
	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 )				!
	icsis_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_POP3_DEBUG)"
	    print "Debug Menu:"							!
	    print " 0 = only errors"						!
	    print " 1 = errors + informationals"				!
	    print " 2 = full"							!
	    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_POP3_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								!
	    icsis_debug% = integer(temp$)					!
	use									!
	    icsis_debug% = 0							!
	end when								!
	print "-i- program Started with a Debug Level of "; icsis_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)			!
	!
	!====================================================================================================
	!
	!	<<< restart connection >>>
	!
	restart_connection:							!
	dead_air_test%		= 0						!
	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									!
	!
	! Implementation notes for lexical %hardened
	!
	! 0: original code
	!    only one event flag (tcp_event_flag%) is used to detect when data has arrived from the other end
	! 1: 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
	!
    %let %hardened=1%								! 0=original code, 1=hardened code
    %if  %hardened=1% %then							! hardened code -----------------------------------
	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									!
    %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 icsis_debug% >= 2	!
	    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 icsis_debug% >= 2		!
	src_node$  = edit$( WCSM_TrnLnm( "TCPIP_DOMAINNAME", "LNM$SYSTEM_TABLE" ),32+4+2)
	dest_node$ =	"127.0.0.1"						!
	dest_port$ =	"110"							!
        !
	print "-i- src  node : ";src_node$					!
	print "-i- dest node : ";dest_node$					!
	print "-i- port      : ";dest_port$					!
	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, 110=pop3)	&
		20%								 ! timeout in seconds				&
	)
	gosub display_rc							!
	if (rc% and 1%) <> 1% then						!
	    goto close_connection						!
	end if									!
	channel_open% = 1							!
	!
	try% = 1								! init to stage 1 (nothing to send...
	goto wait_for_response							! ...so just wait for the open message)
	!
	!	<<< send the data (loop) >>>
	!
	send_data_loop:								!
	declare string constant k_stage4 = ">>> tel func: send data"		!
	stage% = 4%								!
	print k_stage4				if icsis_debug% >= 2		!
	print "-i- time: "+ format_dt( wcsm_dt_stamp ) +" -------------->>> doing try: "+ str$(try%)
	select try%								!
	   case 1								! place-holder (initial wait for response)
		goto wait_for_response						!
	   case 2								! send user
		msg$	= "USER esppats" + cr + lf				!
	   case 3								! send password
		msg$	= "PASS whatever" + cr + lf				!
	   case 4								! send STAT
		msg$	= "STAT" + cr + lf					! this command isn't very useful
		try%	= try% + 1						! prep for next step
		goto send_data_loop						!
	   case 5								! send LIST
		msg$	= "LIST" + cr + lf					!
	   case 6								! RETR
		ptr% = ptr% + 1							!
		if ptr% > list% then						! if done
		    try% = 99							! then prep for QUIT
		    goto send_data_loop						!
		else								!
		    !   <<< Example data >>>
		    !	+OK 6 messages (5334 octets)
		    !	1 889
		    !	2 889
		    !	3 889
		    !	4 889
		    !	5 889
		    !	6 889
		    junk% = pos(list$(ptr%)," ",0)				! look for first <sp>
		    if junk% <= 1 then						! this should never happen
			print "-e- logic error 123 so exiting"			!
		    else							!
			msg_num$ = left$(list$(ptr%), junk%-1)			! extract message number
		    end if							!
		    msg$ = "RETR "+ msg_num$ +				cr + lf	!
		end if								!
	   case 7								! delete messages
		try% = 6							!
		goto send_data_loop						! <<<< do not delete just now
		msg$ = "DELE "+ junk$ +					cr + lf	!
	   case 8								! delete messages
		try% = 99							!
		goto send_data_loop						!
	   case 99								! delete messages
		msg$ = "QUIT"+						cr + lf	!
	   case 100								!
		print "==================================="			!
		print "the POP3 comm process was successul"			!
		print "==================================="			!
		goto close_connection						!
	   case else								! shouldn't ever happen...
		print " (???) oops!"						!
		goto close_connection						!
	end select								!
	sendbuf$	= msg$							!
	sendbuf_w%	= len(msg$)						!
	print "-i- xmit data>";msg$;"<"	if icsis_debug% >= 1			!
	rc% = tel_send_data ( ccb%, sendbuf$, sendbuf_w% )			!
	gosub display_rc							!
	goto close_connection if (rc% and 1%) <> 1%				!
	!
	!----------------------------------------------------------------------------------------------------
	!	data has now been sent so we'll wait for an event flag
	!----------------------------------------------------------------------------------------------------
	wait_for_response:
	declare string constant k_stage5 = ">>> tel func: wait"
	stage% = 5%
	print k_stage5				if icsis_debug% >= 2
    %if  %hardened=0% %then								! original code ---------------------------
	!
	!	<<< wait for the TCP event flag to change state >>>
	!
	if icsis_debug% >= 1 then							!
	    print "-i- waiting for flag ";tcp_event_flag%;" at time: "+ format_dt( wcsm_dt_stamp )
	end if										!
	rc% = sys$waitfr( tcp_event_flag% )						! wait for a response from a single flag
	gosub display_rc								!
	goto close_connection if (rc% and 1%) <> 1%					!
	if icsis_debug% >= 1 then							!
	    print "-i- waking from event flag "+ str$(tcp_event_flag%) +" at time: "+ format_dt( wcsm_dt_stamp )
	end if										!
    %else										! hardened code ---------------------------
	!
	!	<<< arm a timer to expire 'x' time from now >>>
	!
	declare string constant	k_delay010 = "0 00:00:10"				! set delay time 10 seconds from now
	rc% = sys$bintim(k_delay010, 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 )
	!
	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 if (rc% and 1%) <> 1%					!
	if icsis_debug% >= 1 then							!
	    print "-i- waking from event some flag at time: "+ format_dt( wcsm_dt_stamp )
	end if										!
	!
	!	<<< cancel all timer requests (if any) >>>
	!
	print "-i- Calling $CanTim"							!
	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 icsis_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 icsis_debug% >= 1		!
	!
	!	at this point either the TCP-EF or the TIMER-EF could be set
	!
	if (timer_ef_state% = 1)	and						! if the TIMER-EF is set		&
	   (  tcp_ef_state% = 0)							! and the TCP-EF is clear
	then										! then something timed out
	    select dead_air_test%							!
		case 0									! if not doing a dead air test
		    print "-i- starting dead-air test"					!
		    dead_air_test% = dead_air_test% + 1					! ...then arm the test
		    goto send_data_loop							! ...now send a key stroke to View-1
		case else
		    print "-e- ALERT: the dead-air test has failed. Starting a new connection cycle"
		    goto close_connection						! but need to disconnect first
	    end select
	else										! we've got TCP data so fall thru
	end if
    %end %if										! hardened code ---------------------------
	!
	!	<<< receive the data >>>
	!
	declare string constant k_stage6 = ">>> tel func: recv data"
	stage% = 6%
	print k_stage6					if icsis_debug% >= 2
	!
	read_miss% = 0%									! init
	wrkg_buff$ = ""									!
	buff_len% = 0%									!
	!
	!	<<< read loop >>>
	!
	read_loop:
    %let %method=3%									! we want method 3		bf_120.9
    %if %method<1% %then
	lexical %method value too low							! abort compile if too low
    %end %if
    %if %method>3% %then
	lexical %method value too high							! abort compile if too high
    %end %if
    %if  %method=1% %then								! using polling method (original code)
	junk% = 1									! start a read
    %end %if										!
    %if  %method=2% %then								! avoid polling via TEL_GET_CCB	   bf_120.7
	!
	!	peek into the interface to see if any data is waiting in the receive buffer
	!
	!	Note: this technique may not be reliable since we've recently seen conditions where the event flag remains set
	!	even though 'bytes waiting' is set to zero. (Could this happen when an EOL character is stuck in the interface?)
	!
	rc% = tel_get_ccb( ccb%, CCB_RCVBCNT, received_bytes_waiting_w% )		!				   bf_120.7
	gosub display_rc								!
	print "-i- ccbRcvbcnt: "+str$(received_bytes_waiting_w%) if icsis_debug% >= 1	!
	junk% = received_bytes_waiting_w% 						!
   %end %if
   %if  %method=3% %then								! avoid polling via SYS$ReadEF
	!
	!	Note: since the event flag will be set when ever data is available, this is probably the best technique to
	!	use other than polling via the call to TEL_READ_DATA
	!
	rc% = sys$readEF(tcp_event_flag%, junk%)					! test TCP event flag		bf_120.9
	select rc%
	    case SS$_WASCLR
		tcp_ef_state% = 0							! data not available
	    case SS$_WASSET
		tcp_ef_state% = 1							! data is available
	    case else
		print "-e- sys$readef-tcp rc: "+ str$(rc%)
	end select
	junk% = tcp_ef_state%								!
    %end %if
	select junk%									! any data available?
	    case 0									! no...
		recvlen_w%	= 0							! indicate that no data was received
	    case else									! yes...
		!
		!  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			!				bf_123.1
			print "-w- connection closed unexpectedly ("+str$(rc%)+")"	!
			goto close_connection						! cleanup etc.
		    case else								!
			gosub display_rc						!
			goto close_connection if (rc% and 1%) <> 1%			!
		end select								!
		!
		if icsis_debug% >= 2 then						!
		    print "-i- recv data >"+ left$(recvbuf$, recvlen_w%);"<"		!
		    print "-i- recv count: "+ str$(recvlen_w%)				!
		end if									!
	end select									!
	!
	print "-i- read miss : "+ str$(read_miss%) if icsis_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 read_loop								! loop back for more
	else										! we didn't get any data...
		read_miss% = read_miss% + 1%						! so up the read miss count
		sleep 1									! kill some time
		goto read_loop if read_miss% <= 1					! loop if less than 2 seconds
	end if										!
	!
	if icsis_debug% >= 1 then							!
	    print "-i- ============================================================"	!
	    print "-i- wkg buffer len:"+str$(len(wrkg_buff$))				!
	    print "-i- wkg buffer>"; wrkg_buff$;"<"					!
	    print "-i- try: "+ str$(try%)						!
	    print "-i- ============================================================"	!
	end if										!
	!
	collapsed$ = edit$( wrkg_buff$, 128+32+16+8)				! cleanup for testing
	junk% = pos( collapsed$ , "-ERR", 1)					!
	goto fini	if junk% = 1						! this is a demo so just exit on error
	!
	select try%								!
	    case 1								!
		goto fini	if len(collapsed$) = 0				! this is a demo so just exit on error
		try% = try% + 1							!
		goto send_data_loop						!
	    case 2								! USER
		junk% = pos( collapsed$ , "+OK", 1)				!
		goto fini	if junk% <> 1					! this is a demo so just exit on error
		try% = try% + 1							!
		goto send_data_loop						!
	    case 3								! PASS
		junk% = pos( collapsed$ , "+OK", 1)				!
		goto fini	if junk% <> 1					! this is a demo so just exit on error
		try% = try% + 1							!
		goto send_data_loop						!
	    case 4								! STAT
		junk% = pos( collapsed$ , "+OK", 1)				!
		goto fini	if junk% <> 1					! this is a demo so just exit on error
		try% = try% + 1							!
		goto send_data_loop						!
	    case 5								! LIST
		junk% = pos( collapsed$ , "+OK", 1)				!
		goto fini	if junk% <> 1					! this is a demo so just exit on error
		!
		list%	= 0							! init line counter
		start%	= 0							! init starting position
		scan_more5:							!
		cr%	= pos(wrkg_buff$, cr, start%+1)				! find position of <cr> (usually is first)
		lf%	= pos(wrkg_buff$, lf, start%+1)				! find position of <lf> (usually is second)
		if cr% > 0 and lf% > 0 then					! if we've got a pair
		    end1% = min(cr%,lf%)					!
		    end2% = max(cr%,lf%)					!
		else								!
		    end1% = 0							! init
		    end1% = cr%	if cr% > 0					!
		    end1% = lf%	if lf% > 0					!
		    end2% = end1%						!
		end if								!
		if end1% > 0 then						!
		    goto no_more_room	if list% >= k_list_size			!
		    junk$	= seg$(wrkg_buff$, start%+1, end1%-1)		!
		    if junk$ <> "." then					! if not end-of-list indicator
			list% = list% + 1					! prep for insert
		 	list$(list%) = seg$(wrkg_buff$, start%+1, end1%-1)	!
		    end if							!
		    start% = end2%						!
		    goto scan_more5						!
		end if								!
		no_more_room:							!
		print "-i- dumping contents of message list"			!
		for ptr% = 1 to list%						!
		    print "-i-debug Line: "+ str$(ptr%) + " len: "+ str$(len(list$(ptr%))) +" msg: "+ list$(ptr%)
		next ptr%							!
		select list%							!
		    case <= 1							! line #1 = "+OK x messages (xxx octects)"
			try% = 99						! prep for QUIT
		    case else							!
			ptr% = 1						!
			try% = try% + 1						! prep for RETR
		end select							!
		goto send_data_loop						!
	    case 6								! RETR
		junk% = pos( collapsed$ , "+OK", 1)				!
		goto fini	if junk% <> 1					! this is a demo so just exit on error
		print "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
		print "1>"+ wrkg_buff$			+"<2"			!
		!
		!	prep to discard the first line
		!
		cr%	= pos(wrkg_buff$, cr, start%+1)				! find position of <cr> (usually is first)
		lf%	= pos(wrkg_buff$, lf, start%+1)				! find position of <lf> (usually is second)
		if cr% > 0 and lf% > 0 then					! if we've got a pair
		    end1% = min(cr%,lf%)					!
		    end2% = max(cr%,lf%)					!
		else								!
		    end1% = 0							! init
		    end1% = cr%	if cr% > 0					!
		    end1% = lf%	if lf% > 0					!
		    end2% = end1%						!
		end if								!
		print "3>"+ right$(wrkg_buff$,end2%+1)	+"<4"			!
		print "%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%"
		try% = try% + 1							!
		goto send_data_loop						!
	    case 7								! DELE
		junk% = pos( collapsed$ , "+OK", 1)				!
		goto fini	if junk% <> 1					! this is a demo so just exit on error
		try% = try% + 1							!
		goto send_data_loop						!
	    case 99								! QUIT
		junk% = pos( collapsed$ , "+OK", 1)				!
		goto fini	if junk% <> 1					! this is a demo so just exit on error
		try% = try% + 1							!
		goto send_data_loop						!
	    case else								!
		goto fini							! exit for now (dvlp)
	end select								!
	!
	!	<<< close the connection >>>
	!
	close_connection:							!
	gosub close_telnet_connection						!
	goto fini								!
	!
	!	<<< close telnet connection subroutine >>>
	!
	close_telnet_connection:						!
	return if channel_open% = 0						!
	declare string constant k_stage11 = ">>> tel func: close"		!
	stage% = 11%								!
	print k_stage11			if icsis_debug% >= 2			!
	print "Closing connection..."						!
	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 icsis_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 icsis_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				bf_125.4
		    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		bf_122.8
		    sleep 5							!					bf_122.8
		else								! some kind of error....
		    junk% = tel_abort_connection( ccb% )			! don't take any chances
		    sleep 1							!
		end if								!
	end select								!
	channel_open% = 0							!
	return									!
	!----------------------------------------------------------------------------------------------------
	!
	!	<<< display return code after each call to the TELNET library >>>
	!
	display_rc:
	if (rc% and 7%) <> 1%	or						! if not -s- (success)		&
	   icsis_debug% >= 1%							! or 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 "Oops: ";
		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)
	!
	gosub close_telnet_connection						!					bf_122.5
	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  %hardened=1% %then							! hardened code ---------------------------
	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									!
    %end %if									! -----------------------------------------
	!
30000	end program rc%
	!
        !========================================================================================================================
	!	external functions
	!========================================================================================================================
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
	!
	!####################################################################################################
	!
	!	KAWC09::Neil> telnet 127.0.0.1 110
	!	%TCPWARE_TELNET-I-TRYING, trying localhost,pop3 (127.0.0.1,110) ...
	!	%TCPWARE_TELNET-I-ESCCHR, escape (attention) character is "^\"
	!	USER esppats
	!	+OK Password required for "esppats"
	!	PASS whatever
	!	+OK Username/password combination ok
	!	STAT
	!	+OK 2 478
	!	LIST
	!	+OK 2 messages (478 octets)
	!	1 239
	!	2 239
	!	.
	!	RETR 1
	!	+OK 239 octets
	!	Date: 27-APR-2009 13:22:14.89
	!	From: <neil@kawc09>
	!	Subject: this is a test
	!	Cc:
	!	To: ESPPATS
	!	X-VMS-From: KAWC09::NEIL
	!	X-POP3-Server: kawc09.on.bell.ca TCPware(R) POP3 V5.8-2
	!	X-POP3-ID: 2009-04-27.13:27:57.0
	!
	!	this is test 1
	!
	!	.
	!	DELE 1
	!	+OK Message 1 has been deleted.
	!	STAT
	!	+OK 1 239
	!	LIST
	!	+OK 1 messages (239 octets)
	!	2 239
	!	.
	!	DELE 2
	!	+OK Message 2 has been deleted.
	!	STAT
	!	+OK 0 0
	!	LIST
	!	+OK 0 messages (0 octets)
	!	.
	!
	!----------------------------------------------------------------------------------------------------
	!	KAWC09::Neil> telnet 127.0.0.1 110
	!	%TCPWARE_TELNET-I-TRYING, trying localhost,pop3 (127.0.0.1,110) ...
	!	%TCPWARE_TELNET-I-ESCCHR, escape (attention) character is "^\"
	!	+OK TCPware(R) POP3 server V5.8-2 at kawc09.on.bell.ca, up since 2009-04-27 12:22:43
	!	USER esppats
	!	+OK Password required for "esppats"
	!	PASS whatever
	!	+OK Username/password combination ok
	!	LIST
	!	+OK 2 messages (466 octets)
	!	1 233
	!	2 233
	!	.
	!

Back to OpenVMS
Back to OpenVMS Demo Index
Back to Home
Neil Rieck
Kitchener - Waterloo - Cambridge, Ontario, Canada.