818 lines
20 KiB
Diff
818 lines
20 KiB
Diff
|
--- tcl-8.4.13/tcl8.4.13/library/tcltest/constraints.tcl.tst 2007-02-16 09:45:27.000000000 +0100
|
||
|
+++ tcl-8.4.13/tcl8.4.13/library/tcltest/constraints.tcl 2004-10-30 04:52:16.000000000 +0200
|
||
|
@@ -0,0 +1,451 @@
|
||
|
+# constraints.tcl --
|
||
|
+
|
||
|
+# Interface for constraints.
|
||
|
+
|
||
|
+# $Id$
|
||
|
+
|
||
|
+# tcltest::constraints::exists --
|
||
|
+#
|
||
|
+# Check to see whether a given constraint exists.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# constraint.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# 1 if constraint exists, 0 if it does not.
|
||
|
+
|
||
|
+proc tcltest::constraints::exists {constraint} {
|
||
|
+ return [info exists vars::$constraint]
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::constraints::cset --
|
||
|
+#
|
||
|
+# Set constraint or check its value.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# constraint - constraint to set or check.
|
||
|
+# value - optional argument.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# Sets constraint if value is given.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::constraints::cset {args} {
|
||
|
+ set constraint [lindex $args 0]
|
||
|
+ if { [llength $args] == 1 } {
|
||
|
+ if { ! [info exists vars::$constraint] } {
|
||
|
+ return 0
|
||
|
+ } else {
|
||
|
+ return [set vars::$constraint]
|
||
|
+ }
|
||
|
+ } else {
|
||
|
+ set vars::$constraint [lindex $args 1]
|
||
|
+ }
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+proc tcltest::constraints::initconst {constraint} {
|
||
|
+ set retval 0
|
||
|
+ if { [catch {
|
||
|
+ set retval [tcltest::testConstraint $constraint \
|
||
|
+ [eval [ConstraintInitializer $constraint]]]
|
||
|
+ } err] } {
|
||
|
+ puts "DIO CAGNOLINO $err"
|
||
|
+ }
|
||
|
+
|
||
|
+ return $retval
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::constraints::getlist --
|
||
|
+#
|
||
|
+# Gets a list of all constraints.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# List of all constraints.
|
||
|
+
|
||
|
+proc tcltest::constraints::getlist {} {
|
||
|
+ set reslist {}
|
||
|
+ foreach v [info vars vars::*] {
|
||
|
+ lappend reslist [namespace tail $v]
|
||
|
+ }
|
||
|
+ return $reslist
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::constraints::incrskippedbecause --
|
||
|
+#
|
||
|
+# Increments the variable used to track how many tests were
|
||
|
+# skipped because of a particular constraint.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# constraint The name of the constraint to be modified
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# Modifies tcltest::skippedBecause; sets the variable to 1 if
|
||
|
+# didn't previously exist - otherwise, it just increments it.
|
||
|
+#
|
||
|
+# Side effects:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::constraints::incrskippedbecause { constraint {value 1} } {
|
||
|
+ variable skippedBecause
|
||
|
+
|
||
|
+ if {[info exists skippedBecause($constraint)]} {
|
||
|
+ incr skippedBecause($constraint) $value
|
||
|
+ } else {
|
||
|
+ set skippedBecause($constraint) $value
|
||
|
+ }
|
||
|
+ return
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::constraints::skippedlist --
|
||
|
+#
|
||
|
+# Get list of all constraints that kept tests from running..
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# A list of constraints.
|
||
|
+
|
||
|
+proc tcltest::constraints::skippedlist {} {
|
||
|
+ variable skippedBecause
|
||
|
+ return [array names skippedBecause]
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::constraints::getskipped --
|
||
|
+#
|
||
|
+# Gets number of tests skipped because of a particular
|
||
|
+# constraint.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# constraint - constraint.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# Integer number of tests skipped.
|
||
|
+
|
||
|
+proc tcltest::constraints::getskipped { constraint } {
|
||
|
+ variable skippedBecause
|
||
|
+ return $skippedBecause($constraint)
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::constraints::clearskippedlist --
|
||
|
+#
|
||
|
+# Clears the list of skipped constraints.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# Resets the list of skipped constraints.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::constraints::clearskippedlist {} {
|
||
|
+ variable skippedBecause
|
||
|
+ array unset skippedBecause
|
||
|
+ array set skippedBecause {}
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::constraints::checktest --
|
||
|
+#
|
||
|
+# Check test to see if the constraints are satisfied. Note that
|
||
|
+# 'constraintsvar' has to use upvar to reference the real
|
||
|
+# variable, because these checks actually change the
|
||
|
+# constraints. Something to fix in the future if possible.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# name - test name.
|
||
|
+# constraintsvar - constraint to check against.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::constraints::checktest {name constraintsvar} {
|
||
|
+ upvar $constraintsvar constraints
|
||
|
+ set doTest 0
|
||
|
+
|
||
|
+ # I don't agree with this. I think that a constraint should
|
||
|
+ # either be an artificial construct such as unix || pc, OR it
|
||
|
+ # should be a plain old Tcl expression, possibly to be evaluated
|
||
|
+ # in its own namespace. FIXME at some later date when we can toss
|
||
|
+ # this stuff out. -davidw
|
||
|
+
|
||
|
+ if {[string match {*[$\[]*} $constraints] != 0} {
|
||
|
+ # full expression, e.g. {$foo > [info tclversion]}
|
||
|
+ catch {set doTest [uplevel \#0 expr $constraints]}
|
||
|
+ } elseif {[regexp {[^.a-zA-Z0-9 \n\r\t]+} $constraints] != 0} {
|
||
|
+ # something like {a || b} should be turned into
|
||
|
+ # $testConstraints(a) || $testConstraints(b).
|
||
|
+
|
||
|
+ regsub -all {[.\w]+} $constraints {$&} c
|
||
|
+ catch {set doTest [namespace eval vars [list expr $c]]}
|
||
|
+ } elseif {![catch {llength $constraints}]} {
|
||
|
+ # just simple constraints such as {unixOnly fonts}.
|
||
|
+ set doTest 1
|
||
|
+ foreach constraint $constraints {
|
||
|
+ if { ! [cset $constraint] } {
|
||
|
+ set doTest 0
|
||
|
+ # store the constraint that kept the test from
|
||
|
+ # running
|
||
|
+ set constraints $constraint
|
||
|
+ break
|
||
|
+ }
|
||
|
+ }
|
||
|
+ }
|
||
|
+
|
||
|
+ # Return the opposite of doTest
|
||
|
+ return [expr {$doTest ? 0 : 1}]
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::constraints::ConstraintInitializer --
|
||
|
+#
|
||
|
+# Get or set a script that when evaluated in the tcltest namespace
|
||
|
+# will return a boolean value with which to initialize the
|
||
|
+# associated constraint.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# constraint - name of the constraint initialized by the script
|
||
|
+# script - the initializer script
|
||
|
+#
|
||
|
+# Results
|
||
|
+# boolean value of the constraint - enabled or disabled
|
||
|
+#
|
||
|
+# Side effects:
|
||
|
+# Constraint is initialized for future reference by [test]
|
||
|
+
|
||
|
+proc tcltest::constraints::ConstraintInitializer {constraint {script ""}} {
|
||
|
+ variable ConstraintInitializer
|
||
|
+
|
||
|
+ # Check for boolean values
|
||
|
+ if {![info complete $script]} {
|
||
|
+ return -code error "ConstraintInitializer must be complete script"
|
||
|
+ }
|
||
|
+ set retval [namespace eval ::tcltest $script]
|
||
|
+ cset $constraint $retval
|
||
|
+
|
||
|
+}
|
||
|
+
|
||
|
+# tcltest::constraints::DefineConstraintInitializers --
|
||
|
+#
|
||
|
+# Set up the initial constraints (such as unix, pc, and so on).
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# Creates a number of constraints.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::constraints::DefineConstraintInitializers {} {
|
||
|
+ ConstraintInitializer singleTestInterp {tcltest::singleProcess}
|
||
|
+
|
||
|
+ # All the 'pc' constraints are here for backward compatibility and
|
||
|
+ # are not documented. They have been replaced with equivalent 'win'
|
||
|
+ # constraints.
|
||
|
+
|
||
|
+ ConstraintInitializer unixOnly \
|
||
|
+ {string equal $::tcl_platform(platform) unix}
|
||
|
+ ConstraintInitializer macOnly \
|
||
|
+ {string equal $::tcl_platform(platform) macintosh}
|
||
|
+ ConstraintInitializer pcOnly \
|
||
|
+ {string equal $::tcl_platform(platform) windows}
|
||
|
+ ConstraintInitializer winOnly \
|
||
|
+ {string equal $::tcl_platform(platform) windows}
|
||
|
+
|
||
|
+ ConstraintInitializer unix {tcltest::testConstraint unixOnly}
|
||
|
+ ConstraintInitializer mac {tcltest::testConstraint macOnly}
|
||
|
+ ConstraintInitializer pc {tcltest::testConstraint pcOnly}
|
||
|
+ ConstraintInitializer win {tcltest::testConstraint winOnly}
|
||
|
+
|
||
|
+ ConstraintInitializer unixOrPc \
|
||
|
+ {expr {[tcltest::testConstraint unix] || [tcltest::testConstraint pc]}}
|
||
|
+ ConstraintInitializer macOrPc \
|
||
|
+ {expr {[tcltest::testConstraint mac] || [tcltest::testConstraint pc]}}
|
||
|
+ ConstraintInitializer unixOrWin \
|
||
|
+ {expr {[tcltest::testConstraint unix] || [tcltest::testConstraint win]}}
|
||
|
+ ConstraintInitializer macOrWin \
|
||
|
+ {expr {[tcltest::testConstraint mac] || [tcltest::testConstraint win]}}
|
||
|
+ ConstraintInitializer macOrUnix \
|
||
|
+ {expr {[tcltest::testConstraint mac] || [tcltest::testConstraint unix]}}
|
||
|
+
|
||
|
+ ConstraintInitializer nt {string equal $::tcl_platform(os) "Windows NT"}
|
||
|
+ ConstraintInitializer 95 {string equal $::tcl_platform(os) "Windows 95"}
|
||
|
+ ConstraintInitializer 98 {string equal $::tcl_platform(os) "Windows 98"}
|
||
|
+
|
||
|
+ # The following Constraints switches are used to mark tests that
|
||
|
+ # should work, but have been temporarily disabled on certain
|
||
|
+ # platforms because they don't and we haven't gotten around to
|
||
|
+ # fixing the underlying problem.
|
||
|
+
|
||
|
+ ConstraintInitializer tempNotPc {expr {![tcltest::testConstraint pc]}}
|
||
|
+ ConstraintInitializer tempNotWin {expr {![tcltest::testConstraint win]}}
|
||
|
+ ConstraintInitializer tempNotMac {expr {![tcltest::testConstraint mac]}}
|
||
|
+ ConstraintInitializer tempNotUnix {expr {![tcltest::testConstraint unix]}}
|
||
|
+
|
||
|
+ # The following Constraints switches are used to mark tests that
|
||
|
+ # crash on certain platforms, so that they can be reactivated again
|
||
|
+ # when the underlying problem is fixed.
|
||
|
+
|
||
|
+ ConstraintInitializer pcCrash {expr {![tcltest::testConstraint pc]}}
|
||
|
+ ConstraintInitializer winCrash {expr {![tcltest::testConstraint win]}}
|
||
|
+ ConstraintInitializer macCrash {expr {![tcltest::testConstraint mac]}}
|
||
|
+ ConstraintInitializer unixCrash {expr {![tcltest::testConstraint unix]}}
|
||
|
+
|
||
|
+ # Skip empty tests
|
||
|
+
|
||
|
+ ConstraintInitializer emptyTest {format 0}
|
||
|
+
|
||
|
+ # By default, tests that expose known bugs are skipped.
|
||
|
+
|
||
|
+ ConstraintInitializer knownBug {format 0}
|
||
|
+
|
||
|
+ # By default, non-portable tests are skipped.
|
||
|
+
|
||
|
+ ConstraintInitializer nonPortable {format 0}
|
||
|
+
|
||
|
+ # Some tests require user interaction.
|
||
|
+
|
||
|
+ ConstraintInitializer userInteraction {format 0}
|
||
|
+
|
||
|
+ # Some tests must be skipped if the interpreter is not in
|
||
|
+ # interactive mode
|
||
|
+
|
||
|
+ ConstraintInitializer interactive \
|
||
|
+ {expr {[info exists ::tcl_interactive] && $::tcl_interactive}}
|
||
|
+
|
||
|
+ # Some tests can only be run if the installation came from a CD
|
||
|
+ # image instead of a web image. Some tests must be skipped if you
|
||
|
+ # are running as root on Unix. Other tests can only be run if you
|
||
|
+ # are running as root on Unix.
|
||
|
+
|
||
|
+ ConstraintInitializer root {expr \
|
||
|
+ {[string equal unix $::tcl_platform(platform)]
|
||
|
+ && ([string equal root $::tcl_platform(user)]
|
||
|
+ || [string equal "" $::tcl_platform(user)])}}
|
||
|
+ ConstraintInitializer notRoot {expr {![tcltest::testConstraint root]}}
|
||
|
+
|
||
|
+ # Set nonBlockFiles constraint: 1 means this platform supports
|
||
|
+ # setting files into nonblocking mode.
|
||
|
+
|
||
|
+ ConstraintInitializer nonBlockFiles {
|
||
|
+ set code [expr {[catch {set f [open defs r]}]
|
||
|
+ || [catch {fconfigure $f -blocking off}]}]
|
||
|
+ catch {close $f}
|
||
|
+ set code
|
||
|
+ }
|
||
|
+
|
||
|
+ # Set asyncPipeClose constraint: 1 means this platform supports
|
||
|
+ # async flush and async close on a pipe.
|
||
|
+ #
|
||
|
+ # Test for SCO Unix - cannot run async flushing tests because a
|
||
|
+ # potential problem with select is apparently interfering.
|
||
|
+ # (Mark Diekhans).
|
||
|
+
|
||
|
+ ConstraintInitializer asyncPipeClose {expr {
|
||
|
+ !([string equal unix $::tcl_platform(platform)]
|
||
|
+ && ([catch {exec uname -X | fgrep {Release = 3.2v}}] == 0))}}
|
||
|
+
|
||
|
+ # Test to see if we have a broken version of sprintf with respect
|
||
|
+ # to the "e" format of floating-point numbers.
|
||
|
+
|
||
|
+ ConstraintInitializer eformat {string equal [format %g 5e-5] 5e-05}
|
||
|
+
|
||
|
+ # Test to see if execed commands such as cat, echo, rm and so forth
|
||
|
+ # are present on this machine.
|
||
|
+
|
||
|
+ ConstraintInitializer unixExecs {
|
||
|
+ set code 1
|
||
|
+ if {[string equal macintosh $::tcl_platform(platform)]} {
|
||
|
+ set code 0
|
||
|
+ }
|
||
|
+ if {[string equal windows $::tcl_platform(platform)]} {
|
||
|
+ if {[catch {
|
||
|
+ set file _tcl_test_remove_me.txt
|
||
|
+ makeFile {hello} $file
|
||
|
+ }]} {
|
||
|
+ set code 0
|
||
|
+ } elseif {
|
||
|
+ [catch {exec cat $file}] ||
|
||
|
+ [catch {exec echo hello}] ||
|
||
|
+ [catch {exec sh -c echo hello}] ||
|
||
|
+ [catch {exec wc $file}] ||
|
||
|
+ [catch {exec sleep 1}] ||
|
||
|
+ [catch {exec echo abc > $file}] ||
|
||
|
+ [catch {exec chmod 644 $file}] ||
|
||
|
+ [catch {exec rm $file}] ||
|
||
|
+ [llength [auto_execok mkdir]] == 0 ||
|
||
|
+ [llength [auto_execok fgrep]] == 0 ||
|
||
|
+ [llength [auto_execok grep]] == 0 ||
|
||
|
+ [llength [auto_execok ps]] == 0
|
||
|
+ } {
|
||
|
+ set code 0
|
||
|
+ }
|
||
|
+ removeFile $file
|
||
|
+ }
|
||
|
+ set code
|
||
|
+ }
|
||
|
+
|
||
|
+ ConstraintInitializer stdio {
|
||
|
+ set code 0
|
||
|
+ if {![catch {set f [open "|[list [interpreter]]" w]}]} {
|
||
|
+ if {![catch {puts $f exit}]} {
|
||
|
+ if {![catch {close $f}]} {
|
||
|
+ set code 1
|
||
|
+ }
|
||
|
+ }
|
||
|
+ }
|
||
|
+ set code
|
||
|
+ }
|
||
|
+
|
||
|
+ # Deliberately call socket with the wrong number of arguments. The
|
||
|
+ # error message you get will indicate whether sockets are available
|
||
|
+ # on this system.
|
||
|
+
|
||
|
+ ConstraintInitializer socket {
|
||
|
+ catch {socket} msg
|
||
|
+ string compare $msg "sockets are not available on this system"
|
||
|
+ }
|
||
|
+
|
||
|
+ # Check for internationalization
|
||
|
+ ConstraintInitializer hasIsoLocale {
|
||
|
+ if {[llength [info commands testlocale]] == 0} {
|
||
|
+ set code 0
|
||
|
+ } else {
|
||
|
+ set code [string length [SetIso8859_1_Locale]]
|
||
|
+ RestoreLocale
|
||
|
+ }
|
||
|
+ set code
|
||
|
+ }
|
||
|
+
|
||
|
+}
|
||
|
--- tcl-8.4.13/tcl8.4.13/library/tcltest/testresults.tcl.tst 2007-02-16 09:45:41.000000000 +0100
|
||
|
+++ tcl-8.4.13/tcl8.4.13/library/tcltest/testresults.tcl 2004-10-30 04:52:27.000000000 +0200
|
||
|
@@ -0,0 +1,230 @@
|
||
|
+namespace eval tcltest::testresults {
|
||
|
+
|
||
|
+ # The 'TestNames' variable doesn't work for us because it's an
|
||
|
+ # array.
|
||
|
+ set testNames [list]
|
||
|
+
|
||
|
+ array set ResID {}
|
||
|
+
|
||
|
+ # Since this is a pretty long list, we keep it in one place
|
||
|
+ # here, and loop through it when needed.
|
||
|
+ set testAPIvars {
|
||
|
+ testDescription
|
||
|
+ testPassFail
|
||
|
+ testBody
|
||
|
+ testDontRun
|
||
|
+
|
||
|
+ testSkipped
|
||
|
+
|
||
|
+ testSetup
|
||
|
+ testScriptFailure
|
||
|
+ testScriptMatch
|
||
|
+ testActualAnswer
|
||
|
+ testMatch
|
||
|
+ testResult
|
||
|
+ testMsg
|
||
|
+ testReturnCode
|
||
|
+ testExpectedReturnCodes
|
||
|
+ testErrorInfo
|
||
|
+ testErrorCode
|
||
|
+
|
||
|
+ testCodeFailure
|
||
|
+ testOutputFailure
|
||
|
+ testErrorFailure
|
||
|
+
|
||
|
+ testOutputMatch
|
||
|
+ testOutData
|
||
|
+ testOutput
|
||
|
+
|
||
|
+ testErrorMatch
|
||
|
+ testErrorData
|
||
|
+ testErrorOutput
|
||
|
+
|
||
|
+ testCleanupMsg
|
||
|
+ testCore
|
||
|
+ }
|
||
|
+ foreach var $testAPIvars {
|
||
|
+ array set $var {}
|
||
|
+ }
|
||
|
+
|
||
|
+ # initialize numTests array to keep track of the number of tests
|
||
|
+ # that pass, fail, and are skipped.
|
||
|
+ array set numTests [list Total 0 Passed 0 Skipped 0 Failed 0]
|
||
|
+}
|
||
|
+
|
||
|
+# tcltest::testresults::newresult --
|
||
|
+#
|
||
|
+# Start recording information about a new result. Must be
|
||
|
+# called prior to tcltest::result.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# name - test name.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# Sets the ResID variable, which acts as a unique ID for each
|
||
|
+# result.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::testresults::newresult {name} {
|
||
|
+ variable testNames
|
||
|
+ variable ResID
|
||
|
+
|
||
|
+ lappend testNames $name
|
||
|
+ set ResID($name) [expr {[llength $testNames] - 1}]
|
||
|
+}
|
||
|
+
|
||
|
+# tcltest::testresults::result --
|
||
|
+#
|
||
|
+# Store information about a particular test.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# var - variable name to set.
|
||
|
+# name - test name.
|
||
|
+# data - data to store.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::testresults::result {var name data} {
|
||
|
+ variable testAPIvars
|
||
|
+ variable ResID
|
||
|
+
|
||
|
+ foreach tstvar $testAPIvars {
|
||
|
+ variable $tstvar
|
||
|
+ }
|
||
|
+
|
||
|
+ set [set var]($ResID($name)) $data
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::testresults::results --
|
||
|
+#
|
||
|
+# Takes a subcommand as the first argument, and based on that,
|
||
|
+# returns some information about test results.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# cmd - one of tests vars, exists, get or clear
|
||
|
+# args - additional arguments, such as the test name, the
|
||
|
+# variable to query, and so on. See the tcltest man page.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# The 'clear' command eliminates the results of the specified test.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# tests - returns information on all tests.
|
||
|
+# vars - returns the variables available for a given test.
|
||
|
+# exists - reports whether a variable exists for a given test.
|
||
|
+# get - fetches the information about a variable for a given test.
|
||
|
+# clear - clears all information about a given test, and removes
|
||
|
+# it from the list of tests.
|
||
|
+
|
||
|
+proc tcltest::testresults::results {cmd args} {
|
||
|
+ variable testNames
|
||
|
+ variable testAPIvars
|
||
|
+ variable numTests
|
||
|
+
|
||
|
+ foreach var $testAPIvars {
|
||
|
+ variable $var
|
||
|
+ }
|
||
|
+
|
||
|
+ if { $cmd == "tests" } {
|
||
|
+ return $testNames
|
||
|
+ }
|
||
|
+
|
||
|
+ set res {}
|
||
|
+ set testname [lindex $args 0]
|
||
|
+ # Fetch the list index of the test name.
|
||
|
+ set id [lsearch -all $testNames $testname]
|
||
|
+ # If there was more than one result, either one is specified or we
|
||
|
+ # error out.
|
||
|
+
|
||
|
+ if { [llength $id] > 1 } {
|
||
|
+ set num [lindex $args 1]
|
||
|
+ if { ![string is int $num] || $num == "" } {
|
||
|
+ error "Multiple tests correspond - please specify one: 0-[expr [llength $id] - 1]"
|
||
|
+ }
|
||
|
+ set id [lindex $id $num]
|
||
|
+ } elseif {$id < 0} {
|
||
|
+ error "No $testname test recorded"
|
||
|
+ }
|
||
|
+
|
||
|
+ switch -exact $cmd {
|
||
|
+ vars {
|
||
|
+ foreach var $testAPIvars {
|
||
|
+ if { [info exists [set var]($id)] } {
|
||
|
+ lappend res $var
|
||
|
+ }
|
||
|
+ }
|
||
|
+ return $res
|
||
|
+ }
|
||
|
+
|
||
|
+ exists {
|
||
|
+ set varname [lindex $args end]
|
||
|
+ return [info exists [set varname]($id)]
|
||
|
+ }
|
||
|
+
|
||
|
+ get {
|
||
|
+ set varname [lindex $args end]
|
||
|
+ return [set [set varname]($id)]
|
||
|
+ }
|
||
|
+
|
||
|
+ clear {
|
||
|
+ foreach var $testAPIvars {
|
||
|
+ if { [info exists [set var]($id)] } {
|
||
|
+ unset [set var]($id)
|
||
|
+ }
|
||
|
+ }
|
||
|
+ set testNames [lreplace $testNames $id $id]
|
||
|
+ return
|
||
|
+ }
|
||
|
+
|
||
|
+ default {
|
||
|
+ error "bad option \"$cmd\": must be tests, vars, exists, get, or clear"
|
||
|
+ }
|
||
|
+ }
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::testresults::tally --
|
||
|
+#
|
||
|
+# Return information about the number of tests that have passed,
|
||
|
+# failed, been skipped, and the total.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# type - type of tally to return: passed, failed, skipped, total.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# A number corresponding to the type of information sought.
|
||
|
+
|
||
|
+proc tcltest::testresults::tally {type} {
|
||
|
+ variable numTests
|
||
|
+ return $numTests([string totitle $type])
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::testresults::incrtotal --
|
||
|
+#
|
||
|
+# Increase the count for the number of tests that have either
|
||
|
+# Passed, Failed, Skipped, or the Total number of tests.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::testresults::incrtotal {type {num 1}} {
|
||
|
+ variable numTests
|
||
|
+ incr numTests($type) $num
|
||
|
+}
|
||
|
\ No newline at end of file
|
||
|
--- tcl-8.4.13/tcl8.4.13/library/tcltest/files.tcl.tst 2007-02-16 09:45:36.000000000 +0100
|
||
|
+++ tcl-8.4.13/tcl8.4.13/library/tcltest/files.tcl 2004-10-30 04:52:17.000000000 +0200
|
||
|
@@ -0,0 +1,126 @@
|
||
|
+# files.tcl -- manage test suite files.
|
||
|
+
|
||
|
+# $Id$
|
||
|
+
|
||
|
+namespace eval tcltest::files {
|
||
|
+ array set failFiles {}
|
||
|
+}
|
||
|
+
|
||
|
+# tcltest::files::add --
|
||
|
+#
|
||
|
+# Add a file to the list of files that have been processed by
|
||
|
+# the test suite.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# filename - name of file to add to list.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# File name list includes filename.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::files::add {filename} {
|
||
|
+ variable filelist
|
||
|
+ lappend filelist $filename
|
||
|
+}
|
||
|
+
|
||
|
+# tcltest::files::getlist --
|
||
|
+#
|
||
|
+# Get list of files the test suite has been through.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# List of files.
|
||
|
+
|
||
|
+proc tcltest::files::getlist {} {
|
||
|
+ variable filelist
|
||
|
+ return $filelist
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::files::failed --
|
||
|
+#
|
||
|
+# Indicate that a particular file has failed tests.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# filename.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::files::failed {filename} {
|
||
|
+ variable failFiles
|
||
|
+ set failFiles($filename) 1
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::files::setcreated --
|
||
|
+#
|
||
|
+# This is used to indicate that the particular test file has
|
||
|
+# created some files.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::files::setcreated { filename {files ""} } {
|
||
|
+ variable createdNewFiles
|
||
|
+ if { [llength $files] == 0 } {
|
||
|
+ return $createdNewFiles($filename)
|
||
|
+ }
|
||
|
+ set createdNewFiles($filename) $files
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::files::allcreated --
|
||
|
+#
|
||
|
+# Returns a list of all the files that have been created.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# List of files.
|
||
|
+
|
||
|
+proc tcltest::files::allcreated {} {
|
||
|
+ variable createdNewFiles
|
||
|
+ return [array names createdNewFiles]
|
||
|
+}
|
||
|
+
|
||
|
+
|
||
|
+# tcltest::files::clearcreated --
|
||
|
+#
|
||
|
+# Clear list of created files.
|
||
|
+#
|
||
|
+# Arguments:
|
||
|
+# None.
|
||
|
+#
|
||
|
+# Side Effects:
|
||
|
+# List of created files is set to empty list.
|
||
|
+#
|
||
|
+# Results:
|
||
|
+# None.
|
||
|
+
|
||
|
+proc tcltest::files::clearcreated {} {
|
||
|
+ variable createdNewFiles
|
||
|
+ array unset createdNewFiles
|
||
|
+ array set createdNewFiles {}
|
||
|
+}
|
||
|
+
|