rpms
/
tcl
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
tcl/tcl-8.4.13-tests.patch

818 lines
20 KiB
Diff
Raw Blame History

--- 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 {}
+}
+
Reference in New Issue View Git Blame Copy Permalink