Tcl Source Code

	#ifdef TMR_RES_TOLERANCE
	    /* consider timer resolution tolerance (avoid busy wait) */
	    timeOffs -= ((timeOffs <= 1000000) ? timeOffs : 1000000) *
				TMR_RES_TOLERANCE / 100;
	#endif

	if (timeOffs > 0) {
	    blockTime.sec = 0;
	    if (timeOffs >= 1000000) {
		/*
		 * Note we use monotonic time by all wait functions, so to
		 * avoid too long wait by the absolute timers (to be able
		 * to trigger it) if time jumped to the expected time, just
		 * let block for maximal 1s if absolute timers available.
		 */
		if (tsdPtr->absTimerList) {
		    /* we've some absolute timers - won't wait longer as 1s. */
		    timeOffs = 1000000;
		}
		blockTime.sec = (long) (timeOffs / 1000000);
		blockTime.usec = (unsigned long)(timeOffs % 1000000);
	    } else {
		blockTime.sec = 0;
		blockTime.usec = (unsigned long)timeOffs;
	    }
	} else {
	    blockTime.sec = 0;
	    blockTime.usec = 0;
	}
	
    } else {
	return;

	) {
	    iPtr->limit.granularityTicker = 0;
	    if (Tcl_LimitCheck(interp) != TCL_OK) {
		return TCL_ERROR;
	    }
	}
	diff = endTime - now;
	if (absolute && diff >= 1000000) {
	    /*
	     * Note by absolute sleep we should avoid too long waits, to be
	     * able to process further if time jumped to the expected time, so
	     * just let wait maximal 1 second.
	     */
	    diff = 1000000;
	}
	if (iPtr->limit.timeEvent == NULL || diff < limOffs) {
	    if (diff > 0) {
		TclpUSleep(diff);
		if (!absolute) {
		    now = TclpGetUTimeMonotonic();
		} else {
		    now = TclpGetMicroseconds();

	    after $l [list lappend l "ev:$l"]
	}
	set l {}
	vwait done
	set l
    } \
    -result {ev:0 ev:0.1 ev:0.25 ev:0.5 ev:0.75 ev:1}

# -----------------------------------------------------------------------------
# 
# timer-20.x --
# 
#    Following test-cases cover event-driven functionality during time-jump's
#
#    Note: on some platforms it is only possible if the user has corresponding
#          privileges to change system date and time.
#
# Ex.:  sudo LD_LIBRARY_PATH=. ./tclsh ../tests/timer.test -match timer-20.*
# -----------------------------------------------------------------------------

proc timejump {args} {
  set tnow [clock clicks]
  set tm [clock format [clock add [clock seconds] {*}$args] -format %H:%M:%S]
  #puts -nonewline "***[format \[%04X\] [pid]]*** jump to $tm ($args) "
  if {$::tcl_platform(platform) eq "windows"} {
    exec $::env(COMSPEC) /c time $tm
  } else {
    exec date +%T -s $tm
  }
  #puts "***[format \[%04X\] [pid]]*** [clock format [clock seconds] -format {%Y-%m-%d %H:%M:%S}] =="
}

testConstraint ChangeTimePrivilege [expr {![catch { timejump 0 minutes }]}]
testConstraint NewVWaitAfter	   [expr {![catch { vwait 0 nothing }]}]

# provide monotonic command, if "clock monotonic" not available (old core):
if {![catch {::tcl::clock::monotonic}]} {
  namespace inscope ::tcl::clock {namespace export monotonic}
  namespace import ::tcl::clock::monotonic
} else {
  proc monotonic {} {
    variable tickFactor
    # warming-up:
    clock clicks; clock microseconds
    # calc tick2usec factor:
    set tick [::tcl::clock::clicks]; set usec [::tcl::clock::microseconds]
    after 100
    set tickFactor [expr {double([::tcl::clock::clicks] - $tick) / ([::tcl::clock::microseconds] - $usec)}]
    proc monotonic {} {
      variable tickFactor
      expr {wide([::tcl::clock::clicks] / $tickFactor)} 
    }
    monotonic
  }
}
# asynchronous function doing 3 time jumps (+1 min, +1 min, -2 minutes) in 250-ms:
proc delayedtimejump {delay {async 1} {startms {}}} {
  # async code (executed in separate process):
  if {$async} {
    set code ""
    foreach pr {timejump delayedtimejump} {
	append code [list proc $pr [info args $pr] [info body $pr]] \n
    }
    append code "delayedtimejump $delay 0 [::tcl::clock::milliseconds]"
    exec [info nameofexecutable] << $code &
    return
  }
  # time-jumps (1st in 250-ms, 2nd and 3rd in given delay):
  set delay1 250
  if {$startms ne {}} {
     set delay1 [expr {250 - ([::tcl::clock::milliseconds] - $startms)}]
     if {$delay1 < 0} { set delay1 0 }
  }
  after $delay1; timejump +1 minutes
  after $delay; timejump +1 minutes
  after $delay; timejump -2 minutes
}

proc test-timer-with-jump {code maxCount expMT {maxOffs 100}} {
    set mitm [set sttm [clock seconds]]
    set stmt [monotonic]
    set expMT [expr {$expMT * 1000}]
    set maxOffs [expr {$maxOffs * 1000}]
    set res {}
    set jumped 0
    for {set i 0} {$i < $maxCount} {incr i} {
	set rt [::tcl::clock::microseconds]
	set mt [monotonic]
	# execute:
	if 1 $code
	# verify monotonic time:
	set mt [expr {[monotonic] - $mt}]
	set rt [expr {[::tcl::clock::microseconds] - $rt}]
	# give +/- 100-ms for some slow or busy systems:
	if {$mt < $expMT - $maxOffs || $mt > $expMT + $maxOffs} {
	  lappend res "$i. too large discrepancy mt: $mt ~ $expMT (rt: $rt)"
	} else {
	  #lappend res "$i. debug, # mt: $mt, rt: $rt"
	}
	# be sure we are in the future and then comming back:
	if {$jumped > 2} break; # we are already back
	if {[clock seconds] - $mitm > 30 || [clock seconds] - $mitm < -30} {
	   set mitm [clock seconds]
	   incr jumped
	}
    }
    # wait for time-jump back (from the future):
    set future [clock add $sttm +30 seconds]
    set aftto [after 10000 {set tout 1}]
    while {[clock seconds] >= $future} {
	if {[vwait 100 tout]} {
	   error "unexpected case: too long wait for time-reset."
	}
    }
    after cancel $aftto
    after 10
    # result:
    if {[llength $res]} {
      return [join $res \n]
    }
    return $jumped
}

test timer-20.1 {time jump: after relative} {ChangeTimePrivilege} {
    delayedtimejump 250; # delayed time jump in 250-ms
    test-timer-with-jump {
	after 150 {set x 1}; vwait x
    } 20 150
} 3

test timer-20.2 {time jump: vwait timeout} {ChangeTimePrivilege NewVWaitAfter} {
    delayedtimejump 250; # delayed time jump in 250-ms
    test-timer-with-jump {
	vwait -timer 150 nothing; # we want listen timer only
    } 20 150
} 3

test timer-20.3 {time jump: simple sleep} {ChangeTimePrivilege} {
    delayedtimejump 250; # delayed time jump in 250-ms
    test-timer-with-jump {
	after 150
    } 20 150
} 3


# Increase delay between time-jumps (1.5s) for possible retarded reaction of 
# the notifier by absolute timers (retarded recognition of the time-jump so
# the time can jump again (also backwards) without recognition.
# Note also we cannot test absolute timers by the backwards time-jump.

test timer-20.4 {time jump: after absolute time - "after at real-time code"} {ChangeTimePrivilege NewVWaitAfter} {
    set sttm [clock seconds]
    set i 0
    foreach tm [list \
      [clock add $sttm +1 minute -2 second] \
      [clock add $sttm +2 minute -2 second] \
    ] {
      after at $tm [list set x$i 1]
      incr i
    }
    delayedtimejump 1500; # delayed time jump in 1.5s
    test-timer-with-jump {
    	# we want listen timer only:
	if {![vwait -timer 10000 x$i]} {
	   error "too long wait for \"x$i\" (should be maximal 1 second)"
	}
    } 2 250 3000; # max 3 seconds difference (compared to 1 minute)
} 2

test timer-20.5 {time jump: sleep to absolute time - "after at real-time"} {ChangeTimePrivilege NewVWaitAfter} {
    set sttm [clock seconds]
    set offsLst [list \
      [clock add $sttm +1 minute] \
      [clock add $sttm +2 minute] \
    ]
    delayedtimejump 1500; # delayed time jump in 1.5s
    test-timer-with-jump {
	upvar offsLst offsLst
	after at [lindex $offsLst $i]
    } 2 250 3000; # max 3 seconds difference (compared to 1 minute)
} 2

# cleanup
::tcltest::cleanupTests
return

# Local Variables:
# mode: tcl