OpenVMS Source Code Demos
TWO_TIMER_DEMO.BAS
1000 %title "two_timer_demo_xxx" !
%ident "version_101.1" ! <<<---+
declare string constant k_version = "101.1" , ! <<<---+ &
k_program = "two_timer_demo" !
!=======================================================================
! title : timer_demo_xxx.bas
! author : Neil Rieck ( http://neilrieck.net/ )
! created: 2004.01.01
!=======================================================================
option type = explicit ! no kid stuff...
set no prompt !
!
! 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$
!
! home brewed functions
!
external long function get_timer_bit_vector(long) ! required for used with SYS$WFLOR
!
declare long rc% , ! return code &
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 &
junk% , ! &
basic$QuadWord DeltaQuad ! for sys$bintim etc.
!
!=======================================================================
! main
!=======================================================================
main:
margin #0, 132 ! width for the log file
print k_program +"_"+ k_version !
print string$(len(k_program +"_"+ k_version), asc("=")) ! underline (how will this optimize?)
!
! <<< 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 !
!
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 !
!
! <<< arm a timer to expire 'x' time from now >>>
!
print "-i- arming timer-1 (timer) for 10 seconds 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%) !
!
! <<< use a second timer to simulate some sort of TCP timeout >
!
print "-i- arming timer-2 (fake tcp) for 20 seconds from now" !
declare string constant k_delay020 = "0 00:00:20" ! set delay time 20 seconds from now
rc% = sys$bintim(k_delay020, DeltaQuad ) ! init delta time ('x' time from now)
print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
rc% = sys$setimr(tcp_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 event flag "+ str$(tcp_event_flag%) +" or event flag "+ str$(timer_event_flag%)
!
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%) !
!
! <<< 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%) !
tcp_ef_state% = 0 !
end select !
print "-i- TCP EF State : ";str$(tcp_ef_state%) !
!
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%) !
timer_ef_state% = 0 !
end select !
print "-i- Timer EF State: ";str$(timer_ef_state%) !
!
! at this point either the TCP-EF or the TIMER-EF should 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
print "-i-the tcp event timed out (so do something)" !
end if !
!
! here is an alternate way to test all bits quickly
!
junk% = (timer_ef_state% * 2) + tcp_ef_state% ! produce a weighted number
select junk% !
case 0 !
print "no event flags (something went wrong)" !
case 1 !
print "tcp event only (timer event cancelled)" !
case 2 !
print "timer event only (tcp timed out)" !
case 3 !
print "both timer + tcp events (this is possible)" !
end select !
!====================================================================================================
! <<< adios... >>>
!====================================================================================================
fini:
rc% = 1 ! vms -s-
!
! rc% must be set up b4 this point (and must not be changed)
!
rc_exit:
30000 end program rc% !
!#######################################################################
!
! <<< 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
!======================================================================
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
!
!#######################################################################
Back to HomeNeil Rieck
Waterloo, Ontario, Canada.