OpenVMS Source Code Demos

demo_lock_dlm_102.bas

1000	%title	"DEMO_LOCK_DLM_xxx.BAS"
	%ident				  "version_102.1"			!
	declare string constant k_version	= "102.1"			!
	!========================================================================================================================
	! Title  : DEMO_LOCK_DLM_xxx.BAS
	! Author : Neil Rieck	(https://neilrieck.net)
	! Created: 00.04.03
	! Purpose: to demonstrate the use of the DISTRIBUTED LOCK MANAGER method to control access to a shared resource
	! Notes  : to see this program in action, run it three or more sessions each one started 2 seconds later in time
	!
	! Ver Who When   What
	! --- --- ------ --------------------------------------------------------------------------------------------------------
	! 100 NSR 000403 1. original work
	!     NSR 050901 2. modified to compile correctly without needing "[.inc]VMS_Externals.inc"
	! 101 NSR 051003 1. changed the $enqw calls to $enq (no wait)
	!		 2. simplified original example but now call $getlki to test the lock status (polling loop)
	! 102 NSR 051006 1. modified for use with event flags (see lexical: %method)
	!     NSR 051008 2. minor tweak in lexical logic
	!========================================================================================================================
	! calls:	$enq		enqueue		(async)
	!		$enqw		enqueue wait	(sync)
	!		$deq		dequeue
	!		$getlki		get lock info
	!
	! lock modes:	lck$m_nlmode	null
	!		lck$m_crmode	concurrent read		allows shared reading
	!		lck$m_cwmode	concurrent write	allows shared writing
	!		lck$m_prmode	protected read		allows shared read but no writers
	!		lck$m_pwmode	protected write		allows shared read but no other writers (other than self)
	!		lck$m_exmode	exclusive		allows no sharing with others
	!========================================================================================================================
	option type=explicit							! no kid stuff
	declare string constant k_program	= "DEMO_LOCK_DLM"
	!
	%include "starlet"	%from %library "sys$library:basic$starlet"	! system services
        %include "$ssdef"	%from %library "sys$library:basic$starlet"	! ss$
        %include "$lckdef"	%from %library "sys$library:basic$starlet"	! lck$
        %include "$lkidef"	%from %library "sys$library:basic$starlet"	! lki$
        %include "lib$routines"	%from %library "sys$library:basic$starlet"	! lib$
	!
	external long   function get_timer_bit_vector(long)			! required for used with SYS$WFLOR
	external string function wcsm_dt_stamp					! returns time in this format: ccyymmddhhmmss
	!
	declare long		rc%						,!						&
				debug%						,!						&
				loop_counter%		 			,!						&
				dlm_event_flag%					,! dlm event flag				&
				timer_event_flag%				,! timer event flag				&
				dlm_ef_state%					,!						&
				timer_ef_state%					,!						&
				mask%						,!						&
				junk%						,!						&
		basic$quadword	deltaQuad					,!						&
		string		junk$						 !
	!
	!	define stuff to be used during $enq and $deq
	!
	record lock_block_rec							! define a new data structure
		word	lock_condition					,	!						&
			reserved					,	!						&
		long	lock_ident					,	! lock id#					&
		byte	lock_value(16)					 	! (only required with flag: lck$m_valblk)
	end record lock_block_rec					 	!
	declare lock_block_rec lock_block				 	! declare a variable
	!
    %let %method=1%								! 1=event flag method, 0=poll method
    %if  %method=0% %then							! poll method -------------------------------------
	!
	!	define stuff to be used in a general purpose item list
	!
        record ItemRec
	    variant
		case
		    group one
			word Buf_Len						! buffer size (in bytes)
			word Code						! desired operation
			long Buf_Addr						! buffer address
			long Rtrn_Len_Addr					! addr of bytes returned
		    end group one
		case
		    group two
			long list_term						! mark end-of-list
		    end group two
	    end variant
        end record
	!
	!	define stuff to be used in testing the status of a queue lock
	!
	record LkiRec								! structure of Lki Record
	    ItemRec ItemVar(9)							! 0 -> 9 items
        end record LkiRec							!
	declare LkiRec	LkiVar							! declare a variable
	!
	!	define stuff to be used in testing the status of a queue lock
	!
	record LockStatusRec							! structure of a lock status record
	    byte	byte0							! LKI$B_STATE_RQMODE
	    byte	byte1							! LKI$B_STATE_GRMODE
	    byte	byte2							! LKI$B_STATE_QUEUE
	end record LockStatusRec						!
	declare LockStatusRec	LockStatus					! declare a variable
    %end %if									! -------------------------------------------------
	!
	!========================================================================================================================
	!	main
	!========================================================================================================================
	main:
	print k_program +"_"+ k_version						!
	print string$(len(k_program +"_"+ k_version), asc("="))			! what will the opimtizer do with this?
	debug% = 1								! this should be set by logical name translation
    %if  %method=0% %then							! poll method -------------------------------------
	print "-i-method = POLL"
    %else
	print "-i-method = EVENT FLAG"
    %end %if
	!
	!	allocate some event flags if not already done
	!	(this logic makes more sense in a loop or subroutine)
	!
	if dlm_event_flag% = 0 then						! if flag not yet allocated
	    rc% = lib$get_EF( dlm_event_flag% )					! get an event flag
	    print "-e- lib$get-EF-dlm rc: "+str$(rc%)	if ((rc% and 7%) <> 1)
	end if
	!
	if timer_event_flag% = 0 then						! if flag not yet allocated
	    rc% = lib$get_EF( timer_event_flag% )				! get an event flag
	    print "-e- lib$get-EF-timer rc: "+str$(rc%) if ((rc% and 7%) <> 1)
	end if
	!
	!	<<< request an exclusive lock on a named resource >>>
	!
	!	SYS$ENQ [efn] ,lkmode ,lksb ,[flags] ,[resnam] ,[parid] ,[astadr] ,[astprm] ,[blkast] ,[acmode] ,[rsdm_id]
	!
	print "-i-enq ex"
	rc% = sys$enq(	dlm_event_flag%		,! efn:							&
			lck$k_exmode		,! lkmode: exclusive					&
			lock_block		,! lksb:						&
						,! flags:						&
			"NEIL_DEMO_9876"	,! resname: name of the protected resource 		&
			,,,,,,,	)
	print "-e-enq ex rc: "+str$(rc%) if (rc% and 7%) <> 1%
	!
	!
    %if  %method=0% %then							! poll method -------------------------------------
	!
	!	<<< now test our lock status (because we might not have exclusive access) >>>
	!
	loop_counter% = 0							! init counter
	get_lock_status:
	LkiVar::ItemVar(0)::Buf_Len		= 3				! buffer size (in bytes)
	LkiVar::ItemVar(0)::Code		= lki$_state			! desired operation
        LkiVar::ItemVar(0)::Buf_Addr		= loc(LockStatus)		! buffer address
        LkiVar::ItemVar(0)::Rtrn_Len_Addr	= 0				!
        LkiVar::ItemVar(1)::list_term		= 0				! terminate the list
	!
	!	SYS$GETLKI [efn] ,lkidadr ,itmlst [,iosb] [,astadr] [,astprm] [,nullarg]
	!
	rc% = sys$getlki(						&
						,! efn:			&
	    lock_block::lock_ident		,! lkiadr:		&
	    LkiVar::ItemVar(0)::Buf_Len		,! itmlst		&
						,! iosb			&
	    ,,)
	print "-e-getlki rc: "+ str$(rc%)	if (rc% and 7%) <> 1%
	!
	print "-i-Requested: ";LockStatus::byte0				!
	print "-i-Granted  : ";LockStatus::byte1				!
	print "-i-Queue    : ";LockStatus::byte2				!
	if LockStatus::byte0 <> LockStatus::byte1 then
	    loop_counter% = loop_counter% + 1
	    print "-w- waiting for grant. Count: "+ str$(loop_counter%)
	    sleep 1
	    goto get_lock_status
	end if
    %else									! event flag method -------------------------------
	!
	!	<<< wait here until we get exclusive access via DLM (or we time out)
	!
	!	<<< arm a timer to expire 1 minute from now >>>
	!
	declare string constant	k_delay1000 = "0 00:01:00"			! delay time 1 minute from now
	rc% = sys$bintim(k_delay1000, DeltaQuad )				! init delta time ('x' time from now)
	print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 7%) <> 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 7%) <> 1%)		!
	!
	! note: for the SYS$WFLOR call to work, both event flags must be in the same event flag cluster.
	!	The first parameter (on of the flags) 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(  dlm_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 'DLM event flag' or the 'TIMER event flag' to change state >>>
	!
	print "-i-waiting for flag ";dlm_event_flag%;" or flag ";timer_event_flag%
	junk$ = wcsm_dt_stamp							! get snap shot of current time
	print "-i-sleep begin: ";left$(junk$,8)+"."+right$(junk$,9)		!
	rc% = sys$wflor( dlm_event_flag%, mask%)				! wait for a response from one of the event flags
	print "-e- sys$waitfr rc: "+ str$(rc%) if ((rc% and 7%) <> 1%)		!
	junk$ = wcsm_dt_stamp							! get snap shot of current time
	print "-i-sleep   end: ";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 7%) <> 1%)		!
	!
	!	which event flag is set? DLM or TIMER?
	!
	rc% = sys$readEF(dlm_event_flag%, junk%)				! test DLM event flag
	select rc%
	    case SS$_WASCLR
		dlm_ef_state% = 0
	    case SS$_WASSET
		dlm_ef_state% = 1
	    case else
		print "-e- sys$readef-dlm rc: "+ str$(rc%)
	end select
	print "-i-DLM-EF-State:";str$(dlm_ef_state%)	if debug% >= 1%		!
	!
	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%	!
	!
	!	at this point either the DLM-EF is set
	!	or the TIMER-EF is set
	!	or BOTH are set
	!
	if (  dlm_ef_state% = 0)						! if the DLM-EF didn't get set
	then									! oops
	    print "-e- Error, an exclusive lock on the resource was not received within 60 seconds"
	    goto dequeue							!
	end if
    %end %if									! -------------------------------------------------
	!
	print "-i-starting fake work (15 seconds)"
	sleep 15								! do some work
	print "-i-finished fake work"
	!
	!	remove "our interest" in this resource
	!
	!	SYS$DEQ [lkid] ,[valblk] ,[acmode] ,[flags]
	!
	dequeue:
	print "-i-deq"
	rc% = sys$deq(					&
	    lock_block::lock_ident	,! lkid:	&
					,! valblk:	&
					,! acmode:	&
	    LCK$M_DEQALL		 ! flags:	&
					)
	print "-e-deq rc: "+ str$(rc%)	if (rc% and 7%) <> 1%
	!
	!========================================================================================================================
	!	cleanup
	!	since we might want to pass rc% back to the END statement, don't use rc% here
	!========================================================================================================================
	cleanup:
	if dlm_event_flag% <> 0 then						! if dlm EF is allocated...
	    junk% = lib$free_EF( dlm_event_flag% )				! then free it
	    print "-e- lib$free-EF-dlm rc: "+str$(junk%) if ((junk% and 7%) <> 1)
	end if									!
	if timer_event_flag% <> 0 then						! if timer EF is allocated...
	    junk% = lib$free_EF( timer_event_flag% )				! then free it
	    print "-e- lib$free-EF-timer rc: "+str$(junk%) if ((junk% and 7%) <> 1)
	end if									!
	!
	!	that's all folks
	!
30000	print "adios..."
!~~~	end rc%									x pass rc% back to DCL
	end									! <<<---***
	!########################################################################################################################
	!
	!	external functions
	!
	!========================================================================================================================
	!	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
	!========================================================================================================================
32010	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
	!
	!========================================================================================================================
	!
32020	function string Wcsm_DT_Stamp
	!===================================================================================================================
	! Title  : Wcsm_DT_Stamp.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: deleted
	!===================================================================================================================
	option   type=explicit							! cuz tricks are for kids...
	!
	%include "starlet"	%from %library "sys$library:basic$starlet"	! system services
	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 Home
Neil Rieck
Waterloo, Ontario, Canada.