merge 8.5 (timing issue avoidance, skip test in runtime feature)

2 files changed, 105 insertions, 56 deletions

diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index c98cf0b..e5dbdfe 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -1986,15 +1986,20 @@ proc tcltest::test {name description args} {
     if {[set cmd [uplevel 1 {namespace which SetupTest}]] ne ""} {
 	set setup [list $cmd $setup]
     }
+    set processTest 1
     set code [catch {uplevel 1 $setup} setupMsg]
     if {$code == 1} {
 	set errorInfo(setup) $::errorInfo
 	set errorCodeRes(setup) $::errorCode
+	if {$errorCodeRes(setup) eq "BYPASS-SKIPPED-TEST"} {
+	    _noticeSkipped $name $setupMsg
+	    set processTest [set code 0]
+	}
     }
     set setupFailure [expr {$code != 0}]
 
     # Only run the test body if the setup was successful
-    if {!$setupFailure} {
+    if {$processTest && !$setupFailure} {
 
 	# Register startup time
 	if {[IsVerbose msec] || [IsVerbose usec]} {
@@ -2017,16 +2022,20 @@ proc tcltest::test {name description args} {
 	if {$returnCode == 1} {
 	    set errorInfo(body) $::errorInfo
 	    set errorCodeRes(body) $::errorCode
+	    if {$errorCodeRes(body) eq "BYPASS-SKIPPED-TEST"} {
+		_noticeSkipped $name $actualAnswer
+		set processTest [set returnCode 0]
+	    }
 	}
     }
 
     # check if the return code matched the expected return code
     set codeFailure 0
-    if {!$setupFailure && ($returnCode ni $returnCodes)} {
+    if {$processTest && !$setupFailure && ($returnCode ni $returnCodes)} {
 	set codeFailure 1
     }
     set errorCodeFailure 0
-    if {!$setupFailure && !$codeFailure && $returnCode == 1 && \
+    if {$processTest && !$setupFailure && !$codeFailure && $returnCode == 1 && \
                 ![string match $errorCode $errorCodeRes(body)]} {
 	set errorCodeFailure 1
     }
@@ -2035,7 +2044,7 @@ proc tcltest::test {name description args} {
     # them.  If the comparison fails, then so did the test.
     set outputFailure 0
     variable outData
-    if {[info exists output] && !$codeFailure} {
+    if {$processTest && [info exists output] && !$codeFailure} {
 	if {[set outputCompare [catch {
 	    CompareStrings $outData $output $match
 	} outputMatch]] == 0} {
@@ -2047,7 +2056,7 @@ proc tcltest::test {name description args} {
 
     set errorFailure 0
     variable errData
-    if {[info exists errorOutput] && !$codeFailure} {
+    if {$processTest && [info exists errorOutput] && !$codeFailure} {
 	if {[set errorCompare [catch {
 	    CompareStrings $errData $errorOutput $match
 	} errorMatch]] == 0} {
@@ -2059,7 +2068,9 @@ proc tcltest::test {name description args} {
 
     # check if the answer matched the expected answer
     # Only check if we ran the body of the test (no setup failure)
-    if {$setupFailure || $codeFailure} {
+    if {!$processTest} {
+    	set scriptFailure 0
+    } elseif {$setupFailure || $codeFailure} {
 	set scriptFailure 0
     } elseif {[set scriptCompare [catch {
 	CompareStrings $actualAnswer $result $match
@@ -2123,6 +2134,12 @@ proc tcltest::test {name description args} {
 	}
     }
 
+    # if skipped, it is safe to return here
+    if {!$processTest} {
+	incr testLevel -1
+	return
+    }
+
     # if we didn't experience any failures, then we passed
     variable numTests
     if {!($setupFailure || $cleanupFailure || $coreFailure
@@ -2183,7 +2200,7 @@ proc tcltest::test {name description args} {
 	    puts [outputChannel] "---- errorCode(setup): $errorCodeRes(setup)"
 	}
     }
-    if {$scriptFailure} {
+    if {$processTest && $scriptFailure} {
 	if {$scriptCompare} {
 	    puts [outputChannel] "---- Error testing result: $scriptMatch"
 	} else {
@@ -2250,6 +2267,32 @@ proc tcltest::test {name description args} {
     return
 }
 
+# Skip --
+#
+# Skips a running test and add a reason to skipped "constraints". Can be used
+# to conditional intended abort of the test.
+#
+# Side Effects:  Maintains tally of total tests seen and tests skipped.
+#
+proc tcltest::Skip {reason} {
+    return -code error -errorcode BYPASS-SKIPPED-TEST $reason
+}
+
+proc tcltest::_noticeSkipped {name reason} {
+    variable testLevel
+    variable numTests
+
+    if {[IsVerbose skip]} {
+	puts [outputChannel] "++++ $name SKIPPED: $reason"
+    }
+
+    if {$testLevel == 1} {
+	incr numTests(Skipped)
+	AddToSkippedBecause $reason
+    }
+}
+
+
 # Skipped --
 #
 # Given a test name and it constraints, returns a boolean indicating
@@ -2330,14 +2373,7 @@ proc tcltest::Skipped {name constraints} {
 	}
 
 	if {!$doTest} {
-	    if {[IsVerbose skip]} {
-		puts [outputChannel] "++++ $name SKIPPED: $constraints"
-	    }
-
-	    if {$testLevel == 1} {
-		incr numTests(Skipped)
-		AddToSkippedBecause $constraints
-	    }
+	    _noticeSkipped $name $constraints
 	    return 1
 	}
     }
diff --git a/tests/clock.test b/tests/clock.test
index 8d73bf2..6323a63 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -32,6 +32,10 @@ testConstraint detroit \
 testConstraint y2038 \
     [expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}]
 
+if {[namespace which -command ::tcl::unsupported::timerate] ne ""} {
+    namespace import ::tcl::unsupported::timerate
+}
+
 # TEST PLAN
 
 # clock-1:
@@ -250,17 +254,6 @@ proc ::testClock::registry { cmd path key } {
     return [dict get $reg $path $key]
 }
 
-proc timeWithinDuration {duration start end} {
-    regexp {([\d.]+)(s|ms|us)} $duration -> duration unit
-    if {[llength $start] > 1} { set start [expr "([join $start +])/[llength $start]"] }
-    if {[llength $end] > 1} { set end [expr "([join $end +])/[llength $end]"] }
-    set delta [expr {$end - $start}]
-    expr {
-	  ($delta > 0) && ($delta <= $duration) ?
-	  "ok" :
-	  "test should have taken 0-$duration $unit, actually took $delta"}
-}
-
 
 # Test some of the basics of [clock format]
 
@@ -35451,22 +35444,36 @@ test clock-33.4a {clock milliseconds} {
     concat {}
 } {}
 test clock-33.5 {clock clicks tests, millisecond timing test} {
-    set start [set end {}]
-    lassign [time {
-	lappend start [clock clicks -milli]
-	after 1 {lappend end [clock clicks -milli]}
-	vwait end
-    } 5] tm
-    timeWithinDuration [expr {int($tm/1000 + 1)}]ms $start $end
+    # This test can fail on a system that is so heavily loaded that
+    # the test takes >60 ms to run.
+    if {[lindex [timerate {
+	set start [clock clicks -milli]
+	timerate {} 10; # short but precise busy wait
+	set end [clock clicks -milli]
+    } 1 1] 0] > 60000} {
+	::tcltest::Skip "timing issue"
+    }
+    # 60 msecs seems to be the max time slice under Windows 95/98
+    expr {
+	  ($end > $start) && (($end - $start) <= 60) ?
+	  "ok" : 
+	  "test should have taken 0-60 ms, actually took [expr $end - $start]"}
 } {ok}
 test clock-33.5a {clock tests, millisecond timing test} {
-    set start [set end {}]
-    lassign [time {
-	lappend start [clock milliseconds]
-	after 1 {lappend end [clock milliseconds]}
-	vwait end
-    } 5] tm
-    timeWithinDuration [expr {int($tm/1000 + 1)}]ms $start $end
+    # This test can fail on a system that is so heavily loaded that
+    # the test takes >60 ms to run.
+    if {[lindex [timerate {
+	set start [clock milliseconds]
+	timerate {} 10; # short but precise busy wait
+	set end [clock milliseconds]
+    } 1 1] 0] > 60000} {
+	::tcltest::Skip "timing issue"
+    }
+    # 60 msecs seems to be the max time slice under Windows 95/98
+    expr {
+	  ($end > $start) && (($end - $start) <= 60) ?
+	  "ok" : 
+	  "test should have taken 0-60 ms, actually took [expr $end - $start]"}
 } {ok}
 test clock-33.6 {clock clicks, milli with too much abbreviation} {
     list [catch { clock clicks ? } msg] $msg
@@ -35476,23 +35483,29 @@ test clock-33.7 {clock clicks, milli with too much abbreviation} {
 } {1 {ambiguous option "-": must be -milliseconds or -microseconds}}
 
 test clock-33.8 {clock clicks test, microsecond timing test} {
-    set start [set end {}]
-    lassign [time {
-	lappend start [clock clicks -micro]
-	after 1 {lappend end [clock clicks -micro]}
-	vwait end
-    } 5] tm
-    timeWithinDuration [expr {int($tm + 10)}]us $start $end
-} {ok}
+    # This test can fail on a system that is so heavily loaded that
+    # the test takes >60 ms to run.
+    if {[lindex [timerate {
+	set start [clock clicks -micro]
+	timerate {} 10; # short but precise busy wait
+	set end [clock clicks -micro]
+    } 1 1] 0] > 60000} {
+	::tcltest::Skip "timing issue"
+    }
+    expr {($end > $start) && (($end - $start) <= 60000)}
+} {1}
 test clock-33.8a {clock test, microsecond timing test} {
-    set start [set end {}]
-    lassign [time {
-	lappend start [clock microseconds]
-	after 1 {lappend end [clock microseconds]}
-	vwait end
-    } 5] tm
-    timeWithinDuration [expr {int($tm + 10)}]us $start $end
-} {ok}
+    # This test can fail on a system that is so heavily loaded that
+    # the test takes >60 ms to run.
+    if {[lindex [timerate {
+	set start [clock microseconds]
+	timerate {} 10; # short but precise busy wait
+	set end [clock microseconds]
+    } 1 1] 0] > 60000} {
+	::tcltest::Skip "timing issue"
+    }
+    expr {($end > $start) && (($end - $start) <= 60000)}
+} {1}
 
 test clock-33.9 {clock clicks test, millis align with seconds} {
     set t1 [clock seconds]