OpenVMS Source Code Demos

ADVOCATE_SERVER_103.BAS

1000	%TITLE "Advocate_server_xxx"
	%IDENT			    "Version_103.1"
	declare string constant k_version = "103.1"
	!=========================================================================================================================
	!1         2         3         4         5         6         7         8         9         0         1         2         3
	!0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
	!=========================================================================================================================
	! Title  : Advocate_server_xxx
	! Author : Neil S. Rieck
	! Purpose: Receives DCL commands from people with no privs and executes them on their behalf
	!=========================================================================================================================
	! History:
	!
	! Ver Who When   What
	! --- --- ------ -------------------------------------------------------------------------------------------------------
	! 100 NSR 010307 1. derived from alarm_server_126.bas (written many years ago)
	!		 2. many changes and additions
	! 101 NSR 010308 1. started adding two-way support
	!		 2. added a third mailbox (lck) which is only used to control client access to the tool
	! 102 NSR 030807 1. started STARLET renovation
	!		 2. program renovation
	! 103 NSR 070813 1. inlined a few functions for release to public domain
	!=========================================================================================================================
	! Overview:
	!
	!     +--------+     +---------+     +--------+
	!     | client +-----+ MBX:lck |     | server |
	!     |        |     +---------+     |        |
	!     |        |     +---------+     |        |
	!     |        +---->+ MBX:cmd +---->+--->+   |
	!     |        |     +---------+     |    |   |
	!     |        |     +---------+     |    |   |
	!     |        +<----+ MBX:rsp +<----+<---+   |
	!     +--------+     +---------+     +--------+
	!
	!=========================================================================================================================
	OPTION type = explicit							! cuz tricks are for kids
	!
	%include "starlet"	%from %library "sys$library:basic$starlet"	! system services
	%include "$ssdef"	%from %library "sys$library:basic$starlet"	! ss$
	%include "$iodef"	%from %library "sys$library:basic$starlet"	! io$
	%include "lib$routines"	%from %library "sys$library:basic$starlet"	! lib$
	%include "$libdef"	%from %library "sys$library:basic$starlet"	! eg. lib$_normal
	%include "$clidef"	%from %library "sys$library:basic$starlet"	! cli$
	!
	external long	ast_service_routine					 ! my AST service routine
	declare string constant k_program = "Advocate_server"
	declare string constant advocate_out$ = "csmis$tmp:advocate_outfile.txt"
	!
    %if %declared ( %basic$quadword_declared ) = 0 %then
        record basic$quadword
                long fill ( 2 )
        end record
    %let %basic$quadword_declared = 1
    %end %if
 	!
	!	/// I/O Status Block	///
	!
   %if %declared (%IOSBREC) = 0 %then
	record IosbRec								! structure of I/O Status Block
	    variant
		case
		    group one
			word		rc					! return code
			word		xfer_count				! transfer count
			long		long_0					! device specific info
		    end group one
		case
		    group two
			basic$quadword	quad_0					! this QUAD must be used in the call
		    end group two
	    end variant
	end record IosbRec
    %let %IOSBREC = 1
    %end %if
	!+
	!========================================
	!	Internal Declarations
	!========================================
	!-
	external string function WCSM_DT_Stamp					! home brewed code
	external string function WCSM_TrnLnm( string, string)
	!
	declare long	rc%				,			! Return Code (system status)	&
			csa%				,			! completion status address	&
			junk%				,			!				&
			flags%				,!			!				&
			count%				,			!				&
			response_sent%			,			!				&
		word	funct%				,			!				&
		string	junk$				,			!				&
			temp$				,			!				&
			temp2$
	!+
	!========================================
	! Misc Declarations
	!========================================
	!-
	map(xyz)string	dcl_command_line	= 255%
	!
	!	the next constant and map must be identical with the one in the AST
	!
	declare long constant k_ring_size	= 60%
	map(qio)IosbRec	qio_sb_recv					,	!				&
			qio_sb_xmit					,	!				&
		string	qio_buffer_recv		= 255%			,	! 				&
			qio_buffer_xmit		= 255%			,	!				&
			line$(k_ring_size)	= 255%			,	! ring buffer			&
		word	chan_recv%					,	!				&
			chan_xmit%					,	!				&
			chan_l%						,	!				&
		long	line_insert%					,	! insert pointer (subscript)	&
			line_remove%					,	! remove pointer (subscript)	&
			qio_rc%						,	!				&
			logging_flag%					,	!				&
			logging_flag_old%					!
	!+
	!========================================
	!	Main
	!========================================
	!-
2000	on error goto trap	
	margin #0, 132%
	print k_program +"_"+ k_version
	print string$(len(k_program +"_"+ k_version), asc("="))			! underline previous line
	!
	declare string constant mbx_name_lck = "CSMIS$ADVOCATE_LCK"
	declare string constant mbx_name_cmd = "CSMIS$ADVOCATE_CMD"
	declare string constant mbx_name_rsp = "CSMIS$ADVOCATE_RSP"
	!
	!	create the permanent mailbox (if it already exists, a new one won't be created but a channel will be opened to it)
	!
	print "-i-Creating MailBox: ";mbx_name_cmd
	rc% = sys$CreMbx(	1%			by value		! mbx=permanent				&
				,chan_recv%,,,,					! VMS will assign the channel number	&
				,mbx_name_cmd,					! mbx name				&
				)						!
	print "-e-sys$CreMbx-rc: ";rc%	if (rc% and 7%) <> 1
	print "-i-chan-r: ";str$(chan_recv%)
	!
	print "-i-Creating MailBox: ";mbx_name_rsp
	rc% = sys$CreMbx(	1%			by value		! mbx=permanent				&
				,chan_xmit%,,,,					! VMS will assign the channel number	&
				,mbx_name_rsp,					! mbx name				&
				)						!
	print "-i-sys$CreMbx-rc: ";rc%	if (rc% and 7%) <> 1
	print "-i-chan-x: ";str$(chan_xmit%)
	!
	print "-i-Creating MailBox: ";mbx_name_lck
	rc% = sys$CreMbx(	1%			by value		! mbx=permanent				&
				,chan_l%,,,,					! VMS will assign the channel number	&
				,mbx_name_lck,					! mbx name				&
				)						!
	print "-i-sys$CreMbx-rc: ";rc%	if (rc% and 7%) <> 1
	print "-i-chan-l: ";str$(chan_l%)
	rc% = sys$dassgn( chan_l% by value )					! now release this mail box
	print "-i-sys$dassgn-rc: ";rc%
	!
	!	purge mbx-read
	!
	print "-i-purge-mbx-r"
	qio_sb_recv::rc			= ss$_normal
	while qio_sb_recv::rc		= ss$_normal
	    map (QioPurge)      string  qio_purge$=80
	    qio_rc% = sys$qiow(							&
			    	,chan_recv%			by value	&
				,(io$_readvblk or io$m_now)	by value	&
				,qio_sb_recv::quad_0		by ref		&
				,,						&
				,qio_purge$			by ref		&
				,len( qio_purge$ )              by value	&
				,,,,						)
	    print "-e- $Qio-rc(1): ";qio_rc%	if (qio_rc% and 7%) <> 1
	    !
	    select qio_sb_recv::rc
	        case ss$_normal
	            print "Discarded-r = ";left$(qio_purge$, qio_sb_recv::xfer_count )
	        case ss$_EndOfFile
	        case else
	            print "-e-qiow-r-rc = ";qio_sb_recv::rc
	    end select
	next
	!
	!	purge mbx-write (xmit)
	!
	print "-i-purge-mbx-x"
	qio_sb_xmit::rc			= ss$_normal
	while qio_sb_xmit::rc		= ss$_normal
	    qio_rc% = sys$qiow( ,chan_xmit%			by value	&
				,(io$_readvblk or io$m_now)	by value	&
				,qio_sb_xmit::quad_0		by ref		&
				,,						&
				,qio_purge$			by ref		&
				,len( qio_purge$ )              by value	&
				,,,,						)
	    print "-e- $Qio-rc(2): ";rc%	if (rc% and 7%) <> 1
	    !
	    select qio_sb_xmit::rc
	        case ss$_normal
	           print "Discarded-x = ";left$(qio_purge$, qio_sb_xmit::xfer_count )
	        case ss$_EndOfFile
	        case else
	            print "-e-qiow-x-rc = ";qio_sb_xmit::rc
	    end select
	next
	!
	!	now raise the priority (so 'ast_service_routine' will work like an interrupt service routine)
	!
	!	Note: consider controlling priority from batch job that starts the program
	!
!~~~	print "Raising Priority to 9"
!~~~	rc% = sys$SetPri( ,,9%,)
!~~~	print "-e- rc: ";rc%		if (rc% and 7%) <> 1
	!
	!	do the first qio READ to start things off
	!
	!	SYS$QIO [efn] ,chan ,func ,[iosb] ,[astadr] ,[astprm] ,[p1] ,[p2] ,[p3] ,[p4] ,[p5] ,[p6] 
	!
	print "-i-Starting 1st qio"
	qio_rc% = sys$Qio(								! event flag			&
				,chan_recv%			by value		! channel			&
				,io$_readvblk			by value		! function			&
				,qio_sb_recv::quad_0		by ref			! i/o status			&
				,ast_service_routine		by ref			! ast address			&
				,							! ast parameter			&
				,qio_buffer_recv		by ref			! p1 buf address		&
				,len( qio_buffer_recv )		by value		! p2 buf length			&
				,,,,				)
	print "-e- $Qio-rc(3): ";qio_rc%	if (qio_rc% and 7%) <> 1
	!
	!	/// do this forever ///
	!
	logging_flag_old%	= -1%
	while 1%=1%
	    !
	    !	support logging verbage level
	    !
	    select edit$( WCSM_TrnLnm( "CSMIS$ADVOCATE_SERVER_VERBAGE", "LNM$SYSTEM_TABLE" ), 2%)
		case "2"
		    logging_flag% = 2%
		case "YES", "1"
		    logging_flag% = 1%
		case else
		    logging_flag% = 0%
	    end select
	    !
	    if logging_flag% <> logging_flag_old% then
		logging_flag_old% = logging_flag%
		print "-i-Verbage level now at: ";str$(logging_flag%)
	    end if
	    !
	    while line_insert% <> line_remove%					! if we have work to do
		if line_insert% <> line_remove% then				!
		    !
		    !	extract the data from the ring buffer
		    !	(and place it into my alarm buffer)
		    !
		    dcl_command_line	= edit$( line$( line_remove% ), 128%+4% )
		    !
		    !	advance the remove pointer NOW
		    !
		    select line_remove%
			case < k_ring_size
			    line_remove% = line_remove% + 1%
			case else
			    line_remove% = 0%			
		    end select
		    !
		    !	process the extracted string
		    !
		    junk$ = edit$(dcl_command_line,128%+32%)		! no trailing + upcase 
		    junk% = 0%						! default to reject
		    junk% = 1% if pos(junk$,"SHOW TIME"		,1%)=1%
		    junk% = 1% if pos(junk$,"SHOW QUEUE"		,1%)=1%
		    junk% = 1% if pos(junk$,"START/QUEUE"		,1%)=1%
		    junk% = 1% if pos(junk$,"STOP/QUEUE"		,1%)=1%
		    junk% = 1% if pos(junk$,"INITIALIZE/QUEUE"	,1%)=1%
		    junk% = 1% if pos(junk$,"DELETE/QUEUE"		,1%)=1%
		    junk% = 1% if pos(junk$,"PRINT/QUEUE"		,1%)=1%
		    !
		    if junk% = 0% then					!
			temp$ = "-e- dcl cmd rejected>"+junk$+"<"
			print temp$
			gosub send_response if junk$ <> ""
		    else
			print "-i- dcl cmd>";junk$;"<"
			!
			! LIB$SPAWN [command-string] [,input-file] [,output-file] [,flags] [,process-name]
			!	[,process-id] [,completion-status-address] [,byte-integer-event-flag-num] [,AST-address]
			!	[,varying-AST-argument] [,prompt-string] [,cli] [,table] 
			!
			! flags: CLI$M_NOWAIT, CLI$M_NOCLISYM, CLI$M_NOLOGNAM, CLI$M_NOKEYPAD, CLI$M_NOTIFY,
			!	 CLI$M_NOCONTROL, CLI$M_TRUSTED, CLI$M_AUTHPRIV, and CLI$M_SUBSYSTEM. 
			!
			flags% = CLI$M_NOCLISYM or CLI$M_NOLOGNAM or CLI$M_TRUSTED			! just fooling around
			rc% =  lib$spawn(junk$,,advocate_out$,flags%,,,csa%,,,,,,)
			print "-i- lib$spawn:"
			print "  rc : "+ str$(rc%) +" -"+ mid$("wseif???",(rc% and 7%)+1%, 1%) +"-"	! return code
			print "  csa: "+ str$(csa%)							! completion status address
			!
			!	this section of code is just exploring some future possibilities
			!
			response_sent% = 0%
			when error in
			    !
			    !	open the response file
			    !
			    open advocate_out$  for input as #1		&
				,organization sequential		&
				,recordtype any
			    count% = 0%
			    !
			    !	copy the ressponse file to the server's ".out" file
			    !
			    while 1
				linput #1, temp2$				! read a line
				temp2$ = edit$(temp2$, 128)			! no trailing white space
				count% = count% + 1%				!
				print "-i- resp-0 ";format$(count%,"###");">";temp2$;"<"
				while len(temp2$)>0%				!
				    temp$ = left$(temp2$,70%)			! slice-n-dice long lines
				    if len(temp$)>0 then			!					
					gosub send_response			! send temp$
					response_sent% = response_sent% + 1%	!
					print "-i- resp-1 ";format$(response_sent%,"###");">";temp2$
				    end if
				    junk$ = right$(temp2$,71%)			! scoop up the rest
				    junk$ = edit$(junk$,8)			! drop any leading white space
				    if len(junk$)>0 then			! if we've got something...
					temp2$ = "  "+ junk$			! ...then prefix with 2 spaces (continuation)
				    else
					temp2$ = ""				! else show us empty
				    end if
				next
			    next
			use
			    print "-e-err: ";str$(err);" while processing advocate_out$"	if err<>11%
			end when
			print "=========="
			close #1
			!
			when error in
			    while 1
				kill advocate_out$ 				! now delete all response files
			    next
			use
			end when
			if response_sent% = 0% then				! cuz not all DCL commands have a response
			    temp$ = "Done"
			    gosub send_response
			end if
		    end if
		    !
		end if
		!
	    next
	    !
	    call sys$hiber							! sleep until we receive another message
	    !
	next
	!----------------------------------------------------------------------------------------------------
	!	send response back to connected process
	!----------------------------------------------------------------------------------------------------
	send_response:
	print "-i- Starting qio write"
	temp$ = temp$ + cr								! cuz every line needs an EOL
	qio_buffer_xmit = temp$
	funct% = io$_writevblk or io$m_now or io$m_norswait
	qio_rc% = sys$Qio(								! event flag			&
				,chan_xmit%			by value		! channel			&
				,funct%				by value		! function			&
				,qio_sb_xmit::quad_0		by ref			! i/o status			&
				,							! ast address			&
				,							! ast parameter			&
				,qio_buffer_xmit		by ref			! p1 buf address		&
				,len( temp$ )			by value		! p2 buf length			&
				,,,,				)
	print "-e- $Qio-rc(4): ";qio_rc%	if (qio_rc% and 7%) <> 1
	return
	!
	!========================================
	! Trap (BASIC error handler)
	!
	! this will go to sys$output (sys$error)
	!========================================
20000	trap:
	print	cr + lf + "Line = "+ str$(erl) + &
		cr + lf + "Error= "+ str$(err) + &
		cr + lf + "Text = "+ ert$(err)
	resume fini							! fix stack + exit
	!========================================
	!	adios
	!========================================
	Fini:
32000	END								!
	!
	!########################################################################################################################
	!
	!===============================================================================================================
	! <<< ast_service_routine >>>
	!
	! param%: user defined parameter
	! gpr_0%: general purpose register 0
	! gpr_1%: general purpose register 1
	! pc%	: program counter
	! pcl%	: program status long word
	!
	! Note  : this routine works like an interrupt service routine so it should do as little processing as possible
	!===============================================================================================================
32100	sub ast_service_routine by ref (LONG param%, gpr_0%, gpr_1%, pc%, psl%)
	!
	OPTION type = explicit							! cuz tricks are for kids
	!
	%include "starlet"	%from %library "sys$library:basic$starlet"	! system services
	%include "$ssdef"	%from %library "sys$library:basic$starlet"	! ss$
	%include "$iodef"	%from %library "sys$library:basic$starlet"	! io$
	%include "lib$routines"	%from %library "sys$library:basic$starlet"	! lib$
	%include "$libdef"	%from %library "sys$library:basic$starlet"	! eg. lib$_normal
	!
	external long	ast_service_routine					 ! my AST service routine
	!
    %if %declared ( %basic$quadword_declared ) = 0 %then
        record basic$quadword
                long fill ( 2 )
        end record
    %let %basic$quadword_declared = 1
    %end %if
 	!
	!	/// I/O Status Block	///
	!
	%if %declared (%IOSBREC) = 0 %then
	record IosbRec								! structure of I/O Status Block
	    variant
		case
		    group one
			word		rc					! return code
			word		xfer_count				! transfer count
			long		long_0					! device specific info
		    end group one
		case
		    group two
			basic$quadword	quad_0					! this QUAD must be used in the call
		    end group two
	    end variant
	end record IosbRec
	%let %IOSBREC = 1
 	%end %if
	!
	!	the next constant and map must be identical with the one in MAIN
	!
	declare long constant k_ring_size	= 60%
	map(qio)IosbRec	qio_sb_recv					,	!				&
			qio_sb_xmit					,	!				&
		string	qio_buffer_recv		= 255%			,	! 				&
			qio_buffer_xmit		= 255%			,	!				&
			line$(k_ring_size)	= 255%			,	! ring buffer			&
		word	chan_recv%					,	!				&
			chan_xmit%					,	!				&
			chan_l%						,	!				&
		long	line_insert%					,	! insert pointer (subscript)	&
			line_remove%					,	! remove pointer (subscript)	&
			qio_rc%						,	!				&
			logging_flag%					,	!				&
			logging_flag_old%					!
	!
!~~~	print	"ast iosb_rc: "	+ str$( qio_sb_r::rc) + " iosb_bc: "	+ str$( qio_sb_recv::xfer_count )
	!
	!	erase old mapped string
	!	then copy over received data
	!
	line$( line_insert% ) = ""						! zap old text
	line$( line_insert% ) =	left$(	qio_buffer_recv, integer(qio_sb_recv::xfer_count)	)
	!
	! Anomaly #3:
	! There is a <cr> in the middle of this mapped string so remove it before printing (or the trailing blanks will
	! overwrite your text and make it disappear)
	!
!~~~	print	"ast buf: "+ edit$( line$( line_insert% ), 128%+4%)
	!
	!	move the insertion pointer (main will try to catch up by advancing the removal pointer)
	!
	select line_insert%
	    case < k_ring_size
		line_insert% = line_insert% + 1%
	    case else
		line_insert% = 0%
	end select
	!
	!	SYS$QIO [efn] ,chan ,func ,[iosb] ,[astadr] ,[astprm] ,[p1] ,[p2] ,[p3] ,[p4] ,[p5] ,[p6] 
	!
	qio_rc% = sys$Qio(								! event flag			&
				,chan_recv%			by value		! channel			&
				,io$_readvblk			by value		! function			&
				,qio_sb_recv::quad_0		by ref			! i/o status			&
				,ast_service_routine		by ref			! ast address			&
				,							! ast parameter			&
				,qio_buffer_recv		by ref			! p1 buf address		&
				,len( qio_buffer_recv )		by value		! p2 buf length			&
				,,,,				)
	print "-e- $Qio-rc(5): ";qio_rc%	if (qio_rc% and 7%) <> 1
	!
	! BASIC Anomaly #1.b (above)
	! ------------------
	! The QIO system call expects to pass the address of the AST service routine my value which is not the same as by REF
	!
	!	the upper half of this program may be hybernating so wake it up
	!
	call sys$wake(,)							! wake up main
	!
	subend									! that's all
	!
32200   function string WCSM_TrnLnm ( string logical_name$, table_name$ )
	!========================================================================================================================
	! Title  : wcsm_trnlnm.fun
	! Author : Neil S. Rieck
	! Purpose: an external function to translate logical names
	! Notes  : 1. all our programs call this function so optimizations here will speed up the whole system
	!	 : 2. use LIB$TRNLNM if speed isn't important
	! History:
	! 100 NSR 910911 1. original work
	!     NSR 940420 2. changed mapsize from 31 to 255
	!     NSR 000208 3. modified for use with 'starlet'
	!     NSR 021019 4. optimizations
	!     NSR 040516 5. now only do SUPERVISOR mode translations							bf_100.5
	!     NSR 040519 6. returned this program to its previous functionality
	!========================================================================================================================
	! Notes  :
	!
	! 1. please include the next line near the top of your source program (after 'option type=explicit')
	!
	!	external string function WCSM_TrnLnm (string, string)
	!
	! 2. please include the next 2 lines near the bottom of of your source program (after 'END' of the main module)
	!
	!	%include "[.fun]wcsm_trnlnm.fun"
	!!	! function string WCSM_TrnLnm ( logical_name$, table_name$ )
	!
	!========================================================================================================================
	option	type=explicit							! cuz tricks are for kids...
	!
!~~~	%include "[.inc]vms_externals.inc"					x calls many modules from starlet
	%include "starlet"	%from %library "sys$library:basic$starlet"      ! system services
	%include "$ssdef"	%from %library "sys$library:basic$starlet"      ! ss$
	%include "$lnmdef"	%from %library "sys$library:basic$starlet"      ! lnm$
	%include "$psldef"	%from %library "sys$library:basic$starlet"      ! psl$
	%include "[.inc]vms_structures.inc"					! IosbRec etc.
	!
	declare long  constant	MapSize%	= 255
	!
	!	<<< declare variables >>>
	!
	map(WCSM_TrnLnm)string	Equiv_Name$	= MapSize%
	declare 	long	sys_status		,			! for return codes	&
				bytes_returned%		,			! for system calls	&
				my_attributes%		,			! ''			&
			string	temp$			,			!			&
			byte	access_mode%	 				!
	!
	declare	ItemRec	LogLst(2)						! 3 items (0-2)
	!
	!==================================================
	! clean up data (before table fill)
	!==================================================
	!
	logical_name$	= edit$(logical_name$, 32+4+2)
	table_name$	= edit$(table_name$,   32+4+2)
!~~~	access_mode%	= PSL$C_SUPER						x					bf_100.5
	!
	!==================================================
	! prep for call (fill in table)
	!==================================================
	!
	my_attributes% = LNM$M_TERMINAL
	!
	LogLst(0%)::BuffLen		= 4%					! 4 bytes=long
	LogLst(0%)::ItemCode		= lnm$_Attributes			! desired code
	LogLst(0%)::BuffAddr		= loc(my_attributes%)			!
	LogLst(0%)::RtnLenAdr		= 0%					! don't care
	!
	LogLst(1%)::BuffLen		= MapSize%				! from map statement
	LogLst(1%)::ItemCode		= lnm$_String				! desired code
	LogLst(1%)::BuffAddr		= loc(Equiv_Name$)			! address of string variable
	LogLst(1%)::RtnLenAdr		= loc(Bytes_Returned%)			! address of length variable
	!
	LogLst(2%)::List_Terminator	= 0%					! end of list
	!
	!	this is it folks, the big Kahoona...
	!
	sys_status = sys$trnlnm(		,				! attributes					&
				table_name$	,				!						&
				logical_name$	,				!						&
						,				!				bf_105.6	&
				LogLst()	)				!
	!
	select sys_status
	    case ss$_nolognam
		temp$ = ""							! make sure this is clear
	    case ss$_normal
		temp$ = left$(Equiv_Name$, bytes_returned%)
	    case else								! paranoia, should never happen
		temp$ = "-e-SYSERR_" + str$(sys_status)				!
		print	temp$ + bel + " In 'WCSM_TrnLnm'"			!
		sleep 2%							!
	end select
	!
	!	copy data back to function and return to caller
	!
	WCSM_TrnLnm = temp$
	!
	end function
	!
32300	function string Wcsm_DT_Stamp
	!===================================================================================================================
	! Title  : Wcsm_DT_Stamp_100?.inc
	! Author : Neil S. Rieck
	! Purpose: an external function to return a y2k compliant system time in the form ccyymmddhhmmss (14 chars)
	! Notes  : all our programs call this function so optimizations here will speed up the whole system
	! History:
	! 100a NSR 911229 1. original work
	!      NSR 940423 2. changed 'ON ERROR' to 'WHEN ERROR'
	! 100b NSR 961108 1. cleaned up
	! 100c NSR 961108 1. optimized
	! 100d NSR ?????? 1. optimized
	! 100e NSR 980618 1. optimized
	!		  2. added XX to month names so adding a skew wouldn't be necessary
	!		  3. replaced left hand mid$ with tens mapping
	! 100f NSR 980619 1. optimized
	!		  2. added some code so I could remove the call to RSET (this may increase the size of both $PDATA
	!		     and $CODE but might reduce execution time by avoiding one call to the BASIC RTL. Only
	!		     benchmarking will determine wether this change is better or worse)
	!===================================================================================================================
	! Usage:
	!
	! 1. please include the next line near the top of your source
	!    program (after 'option type=explicit' )
	!
	!	external string function Wcsm_DT_Stamp (string, long)
	!
	! 2. please include the next 2 lines near the bottom of of your
	!    source program (after 'END' of the main module)
	!
	!	%include "[.fun]wcsm_dt_stamp.fun"
	!!	! function string Wcsm_DT_Stamp
	!===================================================================================================================
	option   type=explicit							! cuz tricks are for kids...
	!
	external long function sys$asctim
	!
	declare  long sys_status
	!
	!	this map is required for the call to sys$asctim (format: 19-JUN-1998 23:59:59.1)
	!
	map (WcsmDTStamp0)	string	Sys_buf_22	= 22
	map (WcsmDTStamp0)	string	Sys_day		=  2,	!	&
					Sys_dash1	=  1,	!-	&
					Sys_month	=  3,	!	&
					Sys_dash2	=  1,	!-	&
					Sys_year	=  4,	!	&
					Sys_space	=  1,	!	&
					Sys_Hour	=  2,	!	&
					Sys_colon1	=  1,	!:	&
					Sys_Minute	=  2,	!	&
					Sys_colon2	=  1,	!:	&
					Sys_Second	=  2,	!	&
					Sys_period	=  1,	!.	&
					Sys_Tenth	=  1	!
	!
	!	map for Wcsm date (output)
	!
	map (WcsmDTStamp1)	string	Wcsm_buf_14	= 14	!
	map (WcsmDTStamp1)	string	Wcsm_year	=  4,	!	&
					Wcsm_month	=  2,	!	&
					Wcsm_day	=  2,	!	&
					Wcsm_Hour	=  2,	!	&
					Wcsm_Minute	=  2,	!	&
					Wcsm_Second	=  2
	map (WcsmDTStamp1)	string	Wcsm_year	=  4,	!	&
					Wcsm_month_tens	=  1,	!	&
					Wcsm_month_ones	=  1,	!	&
					Wcsm_day_tens	=  1,	!	&
					Wcsm_day_ones	=  1,	!	&
					Wcsm_Hour	=  2,	!	&
					Wcsm_Minute	=  2,	!	&
					Wcsm_Second	=  2
	!
	!	string constants
	!					  00000000011111111112222222222333333333
	!					  12345678901234567890123456789012345678
	declare string constant k_month_names$ = "XXJANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
	!					  ||
	!					  ++-- so I don't have to provide an offset in pos()
	declare string constant my_space = '32'C
	!
	!	<<< function 'code' starts here >>>
	!
	when error in
		!
		sys_status = sys$asctim(,Sys_buf_22,,)				! get ASCII time into sys_buf_22
!~~~		if (sys_status and 7%) <> 1% then cause error 11		x  not required - call will never fail
		!
		!	transfer data from one map to the other
		!	
		Wcsm_year	= Sys_year					!
!~~~	rset	Wcsm_month	= str$( pos(k_month_names$,Sys_Month,1%) / 3%)	x					bf_100f
		Wcsm_day	= Sys_day					!
		Wcsm_hour	= Sys_hour					!
		Wcsm_minute	= Sys_minute					!
		Wcsm_second	= Sys_second					!
		!
		declare long temp%						!					bf_100f
		temp% = pos(k_month_names$,Sys_Month,1%) / 3%			! compute month number			bf_100f
		if temp% < 10% then						! if less than 10...			bf_100f
		    Wcsm_month_ones	= str$(temp%)				! ...then this goes into ONES		bf_100f
		    Wcsm_month_tens	= "0"					! ...and this goes into TENS		bf_100f
		else								! else >= 10				bf_100f
		    Wcsm_month		= str$(temp%)				!					bf_100f
		end if
		!
		!	make sure there are no spaces in the TENS area of our mapped variables (pad with '0' if necessary)
		!
!~~~		Wcsm_month_tens = "0"	if Wcsm_month_tens	= my_space	x disabled - see above code		bf_100f
		Wcsm_day_tens	= "0"	if Wcsm_day_tens	= my_space	!
		!
		!	now pass result back to caller
		!
		Wcsm_DT_Stamp = Wcsm_Buf_14					! this is it folks
	use
		Wcsm_DT_Stamp = ""						! error so return blank
	end when
	!
	END Function
	!========================================================================================================================

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