OpenVMS Source Code Demos
demo_lock_dlm_103.bas
1000 %title "DEMO_LOCK_DLM_xxx.BAS"
%ident "version_103.2" !
declare string constant k_version = "103.2" !
!========================================================================================================================
! 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
! 103 NSR 051114 1. added support for a system-wide lock (requires priv: SYSLCK) bf_103.1
! 2. added code to view OpenVMS error text bf_103.2
!========================================================================================================================
! 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
!
map (ErrorMsg) string vms_error_msg_buf = 256 ! for VMS error text
declare word vms_error_msg_len
!
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: &
lck$m_system ,! flags: system-wide lock bf_103.1 &
"NEIL_DEMO_9876" ,! resname: name of the protected resource &
,,,,,,, )
!
if (rc% and 7%) <> 1% then ! if not success
print "-e-enq ex rc: "+ str$(rc%) !
junk% = sys$getmsg(rc%, vms_error_msg_len, vms_error_msg_buf, 15%,) ! bf_103.2
if ((junk% and 7%) = 1) then !
print left$(vms_error_msg_buf, vms_error_msg_len) ! display possible priv problem
end if !
goto cleanup !
end if !
!
!
%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
!
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 HomeNeil Rieck
Waterloo, Ontario, Canada.