OpenVMS Source-Code Demos

DECNET_TASK_C.BAS

1000	%title "decnet_task_c_xxx"
	%ident			    "Version_101.1"				! <<<---+---
	declare string constant k_version = "101.1"			,	! <<<---+					&
				k_program = "DECnet Task Demo (Client)"		!
	!=========================================================================================================================
	! Title  : decnet_task_c_xxx (client)
	! Author : Neil S. Rieck
	! Purpose: Starts a similar server task on a remote node
	! Caveat : This is a quick hack for demo purposes only (for my buddies on comp.os.vms)
	!=========================================================================================================================
	! History:
	!
	! Ver Who When   What
	! --- --- ------ -------------------------------------------------------------------------------------------------------
	! 100 NSR 110924 1. original program (using RMS calls like sys$open, sys$read, sys$write)
	! 101 NSR 110925 1. now bypass RMS (using calls like sys$assign and sys$qio)
	!=========================================================================================================================
	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 "lib$routines"	%from %library "sys$library:basic$starlet"	! lib$
	%include "$libdef"	%from %library "sys$library:basic$starlet"	! lib$_normal
	%include "$iodef"	%from %library "sys$library:basic$starlet"	! io$
	!
%if %declared (%IOSBREC) = 0 %then
	record IosbRec								! structure of I/O Status Block
	    variant
		case
		    group one							! this variation is used with I/O transfers
			word		rc					! return code
			word		xfer_count				! transfer count
			long		long_0					! device specific info
		    end group one
		case
		    group two							! this variation is used to satisfy the compiler
			basic$quadword	quad_0					! this QUAD must be used in the call
		    end group two
		case
		    group three							! this variation is used in $SNDJBC + $SNDJBCW
			long		job_status				! job status
			long		long_3					! device specific info
		    end group three
	    end variant
	end record IosbRec
%let %IOSBREC = 1
%end %if
	!
	external long   function get_timer_bit_vector(long)			! required for used with SYS$WFLOR
	external string	function wcsm_dt_stamp					! returns current time: ccyymmddhhmmss
	!
	!=======================================================================
	!	Internal Declarations
	!=======================================================================
	declare long	rc%				,			! Return Code (system status)	&
			junk%				,			!				&
			count_r%			,			!				&
			count_w%			,			!				&
			qio_ef%				,			! event flag(s)			&
			timer_ef%			,			!				&
			timer_ef_state%			,			!				&
			qio_ef_state%			,			!				&
			mask%				,			!				&
		word	funct%				,			!				&
			io_chan%			,			!				&
			funct_bits_xmit			,			!				&
			funct_bits_recv			,			!				&
		string	junk$				,			!				&
			yada$				,			!				&
			my_file$			,			!				&
		IosbRec	iosb_xmit			,			!				&
		IosbRec	iosb_recv			,			!				&
		basic$quadword	DeltaQuad					!
	declare word constant b256_size = 256					!
	map(b256)	string b256$ = b256_size				!
	!=======================================================================
	!	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
	!
	!	"decnet_demo_s" is the name of my DCL server script
	!	"decnet_task_s" is the name of a DCL script which runs my BASIC app
	!
!~~	my_file$ = 'kawc15"neil hiddenpass"::"task=decnet_demo_s"'		x strange but true
	my_file$ = 'kawc15"neil hiddenpass"::"task=decnet_task_s"'		! strange but true
	!
	rc% = sys$assign( my_file$, io_chan%,,)					! assign an i/o channel
	if (rc% and 7%) <> 1% then
	    print "-e- sys$assign: "+str$(rc%)
	    goto fini_rc
	end if
	!
	rc% = lib$get_EF(qio_ef%)						! get an event flag
	if (rc% and 7%) <> 1% then
	    print "-e- lib$get_ef (1): "+str$(rc%)
	    goto fini_rc
	end if
	!
	rc% = lib$get_EF(timer_ef%)						! get an event flag
	if (rc% and 7%) <> 1% then
	    print "-e- lib$get_ef (1): "+str$(rc%)
	    goto fini_rc
	end if
	!-----------------------------------------------------------------------
	!	send something
	!-----------------------------------------------------------------------
	count_w% = 1								!
	xmit_loop:								!
	yada$ = "this is a test. Pass #"+ str$(count_w%)			!
	b256$ = yada$								!
	!
	!	<<< xmit data >>>
	!
	!	SYS$QIO [efn] ,chan ,func ,[iosb] ,[astadr] ,[astprm] ,[p1] ,[p2] ,[p3] ,[p4] ,[p5] ,[p6]
	!
	funct_bits_xmit = IO$_WRITEVBLK
	!
	print "-i- calling sys$qio (write "+str$(count_w%) +")"
	rc% = sys$qio(	qio_ef%			by value,	! efn		&
			io_chan%		by value,	! chan		&
			funct_bits_xmit		by value,	! func		&
			iosb_xmit::quad_0	by ref,		! iosb		&
						,		! ast addr	&
						,		! ast param	&
			b256$			by ref,		! p1=buf addr	&
			len(yada$)		by value,	! p2=buf size	&
						,		! p3=ignored	&
						,		! p4=cr spec	&
						,		! p5=N/A	&
							)	! p6=N/A
	!
	if (rc% and 7%) <> 1% then                                              !
            print "-e- sys$qio rc: ";str$(rc%)					!
            goto fini_rc							! adios...
	else									!
            print "-i- sys$qio rc: ";str$(rc%)					!
	end if									!
	!
	!	since we didn't use $QIOW (on purpose), arm timer then wait for the one of the event flags
	!
	rc% = sys$bintim("0 00:00:10", DeltaQuad )				! init delta time (10 seconds from now)
	print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	rc% = sys$setimr(timer_ef%, 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(  qio_ef%)			! insert vector 1 into mask
	mask% = mask% or	get_timer_bit_vector(timer_ef%)			! insert vector 2 into mask
	!
	!	<<< wait for either the 'QIO event flag' or the 'TIMER event flag' to change state >>>
	!
	junk$ = wcsm_dt_stamp							! get snap shot of current time
	print "-i- waiting for flag ";qio_ef%;" or flag ";timer_ef%;" time: ";left$(junk$,8)+"."+right$(junk$,9)
	!
	rc% = sys$wflor( qio_ef%, mask%)					! wait for a response from one of two flags
	print "-e- sys$waitfr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	junk$ = wcsm_dt_stamp							! get snap shot of current time
	print "-i- waking from event some flag at time: ";left$(junk$,8)+"."+right$(junk$,9)
	!
	!	<<< 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? QIO or TIMER?
	!
	rc% = sys$readEF(qio_ef%, junk%)					! test QIO event flag
	select rc%								!
	    case    SS$_WASCLR							!
		qio_ef_state% = 0						!
	    case    SS$_WASSET							!
		qio_ef_state% = 1						!
	    case else								!
		print "-e- sys$readef-qio rc: "+ str$(rc%)			!
	end select								!
	print "-i- QIO-EF-State: ";str$(qio_ef_state%);" ";			! first line half (no <cr>)
	!
	rc% = sys$readEF(timer_ef%, 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%)			! second line half
	!
	!	at this point either the QIO-EF or the TIMER-EF could be set
	!
	if (timer_ef_state% = 1)	and					! if the the TIMER-EF expired		&
	   (  qio_ef_state% = 0)						! and the QIO-EF didn't...
	then									! then the I/O didn't finish
	   print "-w- oops, the qio seems hung (1)"				!
	   junk% = sys$cancel(io_chan%)						!
	   goto fini								!
	else									! we've got data so fall thru
	   if (iosb_xmit::rc and 7%) <> 1 then					!
		print "-e- the qio failed with status code: "+ str$(iosb_xmit::rc) +" ("+ str$(iosb_xmit::rc and 7%) +")"
	   else									!
		print "-i- the qio completed properly"				!
	   end if								!
	end if									!
	!-----------------------------------------------------------------------
	!	receive something
	!-----------------------------------------------------------------------
	count_r% = 1								!
	recv_loop:								!
	!
	!
	!	<<< receive data >>>
	!
	!	SYS$QIO [efn] ,chan ,func ,[iosb] ,[astadr] ,[astprm] ,[p1] ,[p2] ,[p3] ,[p4] ,[p5] ,[p6]
	!
	funct_bits_recv = IO$_READVBLK
	!
	print "-i- calling sys$qio (read "+str$(count_r%) +")"
	rc% = sys$qio(	qio_ef%			by value,	! efn		&
			io_chan%		by value,	! chan		&
			funct_bits_recv		by value,	! func		&
			iosb_recv::quad_0	by ref,		! iosb		&
						,		! ast addr	&
						,		! ast param	&
			b256$			by ref,		! p1=buf addr	&
			b256_size		by value,	! p2=buf size	&
						,		! p3=ignored	&
						,		! p4=cr spec	&
						,		! p5=N/A	&
							)	! p6=N/A
	!
	if (rc% and 7%) <> 1% then                                              !
            print "-e- sys$qio rc: ";str$(rc%)					!
            goto fini_rc							! adios...
	else									!
            print "-i- sys$qio rc: ";str$(rc%)					!
	end if									!
	!
	!	since we didn't use $QIOW (on purpose), arm timer then wait for the one of the event flags
	!
	rc% = sys$bintim("0 00:00:02", DeltaQuad )				! init delta time (2 sec from now)
	print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	rc% = sys$setimr(timer_ef%, 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(  qio_ef%)			! insert vector 1 into mask
	mask% = mask% or	get_timer_bit_vector(timer_ef%)			! insert vector 2 into mask
	!
	!	<<< wait for either the 'QIO event flag' or the 'TIMER event flag' to change state >>>
	!
	junk$ = wcsm_dt_stamp							! get snap shot of current time
	print "-i- waiting for flag ";qio_ef%;" or flag ";timer_ef%;" time: ";left$(junk$,8)+"."+right$(junk$,9)
	!
	rc% = sys$wflor( qio_ef%, mask%)					! wait for a response from one of two flags
	print "-e- sys$waitfr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%)		!
	junk$ = wcsm_dt_stamp							! get snap shot of current time
	print "-i- waking from event some flag at time: ";left$(junk$,8)+"."+right$(junk$,9)
	!
	!	<<< 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? QIO or TIMER?
	!
	rc% = sys$readEF(qio_ef%, junk%)					! test QIO event flag
	select rc%								!
	    case    SS$_WASCLR							!
		qio_ef_state% = 0						!
	    case    SS$_WASSET							!
		qio_ef_state% = 1						!
	    case else								!
		print "-e- sys$readef-qio rc: "+ str$(rc%)			!
	end select								!
	print "-i- QIO-EF-State: ";str$(qio_ef_state%);" ";			! first line half (no <cr>)
	!
	rc% = sys$readEF(timer_ef%, 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%)			! second line half
	!
	!	at this point either the QIO-EF or the TIMER-EF could be set
	!
	if (timer_ef_state% = 1)	and					! if the the TIMER-EF expired		&
	   (  qio_ef_state% = 0)						! and the QIO-EF didn't...
	then									! then the I/O didn't finish
	   print "-w- oops, the qio seems hung (2)"				!
	   junk% = sys$cancel(io_chan%)						!
	   goto fini								!
	else									! we've got data so fall thru
	   if (iosb_recv::rc and 7%) <> 1 then					!
		print "-e- the qio failed with status code: "+ str$(iosb_recv::rc) +" ("+ str$(iosb_recv::rc and 7%) +")"
	   else									!
		print "-i- the qio completed properly"				!
		print "-i- RECV> "+ left$(b256$, iosb_recv::xfer_count)		!
	   end if								!
	end if									!
	!
	print "--------------------------------"				! end of send-recv pair
	count_w% = count_w% + 1							!
	if count_w% <= 5 then							! have we sent enough?
	    goto xmit_loop							!
	end if									!
	print "-i- enough messages sent, time to exit normally"
	!
	!	don't corrupt rc% after this point
	!
	junk% = sys$cancel(io_chan%)						!
	junk% = sys$dassgn(io_chan%)						!
	!
	goto fini								! adios
	!
	!=======================================================================
	! 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:
	rc% = 1									! VMS-S-
	goto final_exit
	!
	!	rc% must be set up b4 this point
	!
	fini_rc:
	!
	final_exit:
32000	END program rc%								!
	!
	!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
	!
	!	inline external functions and sub programs
	!
	!======================================================================
	!	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
	!======================================================================
32100	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
	!
32110	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)
	!      NSR 101007 3. now use definitions from starlet
	!		  4. renamed the maps just incase
	!===================================================================================================================
	option   type=explicit							! cuz tricks are for kids...
	!
	%include "starlet" %from %library "sys$library:basic$starlet"           !
	!
	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