diff options
Diffstat (limited to 'library/tcltest/tcltest.tcl')
| -rw-r--r-- | library/tcltest/tcltest.tcl | 356 |
1 files changed, 195 insertions, 161 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index edda144..0a7e50d 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -15,7 +15,7 @@ # Copyright (c) 2000 by Ajuba Solutions # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.52 2002/06/05 01:12:38 dgp Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.53 2002/06/06 18:44:43 dgp Exp $ # create the "tcltest" namespace for all testing variables and # procedures @@ -131,9 +131,14 @@ namespace eval tcltest { # predefined constraints (see the explanation for the # InitConstraints proc for more details). ArrayDefault testConstraints {} + Default ConstraintsSpecifiedByCommandLineArgument {} + + # Kept only for compatibility Default constraintsSpecified {} + trace variable constraintsSpecified r {set ::tcltest::constraintsSpecified \ + [array names ::tcltest::testConstraints] ;# } - # Don't run only the constrained tests by default + # Don't run only the "-constraint" specified tests by default Default limitConstraints false # A test application has to know how to load the tested commands @@ -434,7 +439,7 @@ namespace eval tcltest { foreach var { match skip matchFiles skipFiles matchDirectories skipDirectories preserveCore debug loadScript singleProcess - mainThread + mainThread ConstraintsSpecifiedByCommandLineArgument } { proc $var { {new ""} } [subst -nocommands { variable $var @@ -667,25 +672,29 @@ proc tcltest::errorFile { {filename ""} } { # content of tcltest::testConstraints($constraint) # # Side effects: -# appends the constraint name to tcltest::constraintsSpecified +# none proc tcltest::testConstraint {constraint {value ""}} { variable testConstraints - variable constraintsSpecified DebugPuts 3 "entering testConstraint $constraint $value" if {[llength [info level 0]] == 2} { return $testConstraints($constraint) } - lappend constraintsSpecified $constraint + # Check for boolean values + if {[catch {expr {$value && $value}} msg]} { + return -code error $msg + } set testConstraints($constraint) $value } # tcltest::limitConstraints -- # -# sets the limited constraints to tcltest::limitConstraints +# sets/gets flag indicating whether tests run are limited only +# to those matching constraints specified by the -constraints +# command line option. # # Arguments: -# list of constraint names +# new boolean value for the flag # # Results: # content of tcltest::limitConstraints @@ -693,17 +702,22 @@ proc tcltest::testConstraint {constraint {value ""}} { # Side effects: # None. -proc tcltest::limitConstraints { {constraintList ""} } { - variable constraintsSpecified +proc tcltest::limitConstraints { {value ""} } { variable testConstraints variable limitConstraints - DebugPuts 3 "entering limitConstraints $constraintList" + DebugPuts 3 "entering limitConstraints $value" if {[llength [info level 0]] == 1} { return $limitConstraints } - set limitConstraints $constraintList + # Check for boolean values + if {[catch {expr {$value && $value}} msg]} { + return -code error $msg + } + set limitConstraints $value + if {!$limitConstraints} {return $limitConstraints} foreach elt [array names testConstraints] { - if {[lsearch -exact $constraintsSpecified $elt] == -1} { + if {[lsearch -exact [ConstraintsSpecifiedByCommandLineArgument] $elt] + == -1} { testConstraint $elt 0 } } @@ -951,10 +965,6 @@ proc tcltest::PrintError {errorMsg} { return } -if {[llength [info commands tcltest::initConstraintsHook]] == 0} { - proc tcltest::initConstraintsHook {} {} -} - # tcltest::SafeFetch -- # # The following trace procedure makes it so that we can safely @@ -981,16 +991,44 @@ proc tcltest::SafeFetch {n1 n2 op} { DebugPuts 3 "entering SafeFetch $n1 $n2 $op" if {[string equal {} $n2]} {return} if {![info exists testConstraints($n2)]} { - testConstraint $n2 0 + if {[catch {testConstraint $n2 [eval [ConstraintInitializer $n2]]}]} { + testConstraint $n2 0 + } } } +# tcltest::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::ConstraintInitializer {constraint {script ""}} { + variable ConstraintInitializer + DebugPuts 3 "entering ConstraintInitializer $constraint $script" + if {[llength [info level 0]] == 2} { + return $ConstraintInitializer($constraint) + } + # Check for boolean values + if {![info complete $script]} { + return -code error "ConstraintInitializer must be complete script" + } + set ConstraintInitializer($constraint) $script +} + # tcltest::InitConstraints -- # -# Check constraint information that will determine which tests to run. -# To do this, create an array testConstraints. Each element has a value -# of 0 or 1. If the element is "true" then tests with that constraint -# will be run, otherwise tests with that constraint will be skipped. +# Call all registered constraint initializers to force initialization +# of all known constraints. # See the tcltest man page for the list of built-in constraints defined # in this procedure. # @@ -1006,118 +1044,109 @@ proc tcltest::SafeFetch {n1 n2 op} { # proc tcltest::InitConstraints {} { - global tcl_platform tcl_interactive tk_version - variable testConstraints - - # Safely refer to non-existent members of the testConstraints array - # without causing an error. - trace variable testConstraints r [namespace code SafeFetch] - + variable ConstraintInitializer initConstraintsHook + foreach constraint [array names ConstraintInitializer] { + testConstraint $constraint + } +} - testConstraint singleTestInterp [singleProcess] +proc tcltest::DefineConstraintInitializers {} { + ConstraintInitializer singleTestInterp {singleProcess} # All the 'pc' constraints are here for backward compatibility and # are not documented. They have been replaced with equivalent 'win' # constraints. - testConstraint unixOnly [string equal $tcl_platform(platform) unix] - testConstraint macOnly \ - [string equal $tcl_platform(platform) macintosh] - testConstraint pcOnly [string equal $tcl_platform(platform) windows] - testConstraint winOnly \ - [string equal $tcl_platform(platform) windows] - - testConstraint unix [testConstraint unixOnly] - testConstraint mac [testConstraint macOnly] - testConstraint pc [testConstraint pcOnly] - testConstraint win [testConstraint winOnly] - - testConstraint unixOrPc \ - [expr {[testConstraint unix] || [testConstraint pc]}] - testConstraint macOrPc \ - [expr {[testConstraint mac] || [testConstraint pc]}] - testConstraint unixOrWin \ - [expr {[testConstraint unix] || [testConstraint win]}] - testConstraint macOrWin \ - [expr {[testConstraint mac] || [testConstraint win]}] - testConstraint macOrUnix \ - [expr {[testConstraint mac] || [testConstraint unix]}] - - testConstraint nt [string equal $tcl_platform(os) "Windows NT"] - testConstraint 95 [string equal $tcl_platform(os) "Windows 95"] - testConstraint 98 [string equal $tcl_platform(os) "Windows 98"] + 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 {testConstraint unixOnly} + ConstraintInitializer mac {testConstraint macOnly} + ConstraintInitializer pc {testConstraint pcOnly} + ConstraintInitializer win {testConstraint winOnly} + + ConstraintInitializer unixOrPc \ + {expr {[testConstraint unix] || [testConstraint pc]}} + ConstraintInitializer macOrPc \ + {expr {[testConstraint mac] || [testConstraint pc]}} + ConstraintInitializer unixOrWin \ + {expr {[testConstraint unix] || [testConstraint win]}} + ConstraintInitializer macOrWin \ + {expr {[testConstraint mac] || [testConstraint win]}} + ConstraintInitializer macOrUnix \ + {expr {[testConstraint mac] || [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. - testConstraint tempNotPc [expr {![testConstraint pc]}] - testConstraint tempNotWin [expr {![testConstraint win]}] - testConstraint tempNotMac [expr {![testConstraint mac]}] - testConstraint tempNotUnix [expr {![testConstraint unix]}] + ConstraintInitializer tempNotPc {expr {![testConstraint pc]}} + ConstraintInitializer tempNotWin {expr {![testConstraint win]}} + ConstraintInitializer tempNotMac {expr {![testConstraint mac]}} + ConstraintInitializer tempNotUnix {expr {![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. - testConstraint pcCrash [expr {![testConstraint pc]}] - testConstraint winCrash [expr {![testConstraint win]}] - testConstraint macCrash [expr {![testConstraint mac]}] - testConstraint unixCrash [expr {![testConstraint unix]}] + ConstraintInitializer pcCrash {expr {![testConstraint pc]}} + ConstraintInitializer winCrash {expr {![testConstraint win]}} + ConstraintInitializer macCrash {expr {![testConstraint mac]}} + ConstraintInitializer unixCrash {expr {![testConstraint unix]}} # Skip empty tests - testConstraint emptyTest 0 + ConstraintInitializer emptyTest {format 0} # By default, tests that expose known bugs are skipped. - testConstraint knownBug 0 + ConstraintInitializer knownBug {format 0} # By default, non-portable tests are skipped. - testConstraint nonPortable 0 + ConstraintInitializer nonPortable {format 0} # Some tests require user interaction. - testConstraint userInteraction 0 + ConstraintInitializer userInteraction {format 0} # Some tests must be skipped if the interpreter is not in # interactive mode - if {[info exists tcl_interactive]} { - testConstraint interactive $tcl_interactive - } else { - testConstraint interactive 0 - } + 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. - testConstraint root 0 - testConstraint notRoot 1 - if {[string equal unix $tcl_platform(platform)] - && ([string equal root $tcl_platform(user)] - || [string equal "" $tcl_platform(user)])} { - testConstraint root 1 - testConstraint notRoot 0 - } + ConstraintInitializer root {expr \ + {[string equal unix $::tcl_platform(platform)] + && ([string equal root $::tcl_platform(user)] + || [string equal "" $::tcl_platform(user)])}} + ConstraintInitializer notRoot {expr {![testConstraint root]}} # Set nonBlockFiles constraint: 1 means this platform supports # setting files into nonblocking mode. - if {[catch {set f [open defs r]}]} { - testConstraint nonBlockFiles 1 - } else { - if {[catch {fconfigure $f -blocking off}] == 0} { - testConstraint nonBlockFiles 1 - } else { - testConstraint nonBlockFiles 0 - } - close $f + 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 @@ -1127,94 +1156,82 @@ proc tcltest::InitConstraints {} { # potential problem with select is apparently interfering. # (Mark Diekhans). - testConstraint asyncPipeClose 1 - if {[string equal unix $tcl_platform(platform)] && ([catch { - exec uname -X | fgrep {Release = 3.2v}}] == 0)} { - testConstraint asyncPipeClose 0 - } + 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. - testConstraint eformat 1 - if {![string equal [format %g 5e-5] 5e-05]} { - testConstraint eformat 0 - } + 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. - testConstraint unixExecs 1 - if {[string equal macintosh $tcl_platform(platform)]} { - testConstraint unixExecs 0 - } - if {[testConstraint unixExecs] - && [string equal windows $tcl_platform(platform)]} { - set file "_tcl_test_remove_me.txt" - if {[catch { - set fid [open $file w] - puts $fid "hello" - close $fid - }]} { - testConstraint unixExecs 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}] || - [string equal {} [auto_execok mkdir]] || - [string equal {} [auto_execok fgrep]] || - [string equal {} [auto_execok grep]] || - [string equal {} [auto_execok ps]] + 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 } { - testConstraint unixExecs 0 - } - file delete -force $file - } - - # Locate tcltest executable - if {![info exists tk_version]} { - interpreter [info nameofexecutable] + set code 0 + } + removeFile $file + } + set code } - testConstraint stdio 0 - catch { - catch {file delete -force tmp} - set f [open tmp w] - puts $f { - exit + 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 + } + } } - close $f - - set f [open "|[list [interpreter] tmp]" r] - close $f - - testConstraint stdio 1 + set code } - catch {file delete -force tmp} # Deliberately call socket with the wrong number of arguments. The # error message you get will indicate whether sockets are available # on this system. - catch {socket} msg - testConstraint socket [string compare $msg \ - "sockets are not available on this system"] + ConstraintInitializer socket { + catch {socket} msg + string compare $msg "sockets are not available on this system" + } # Check for internationalization - - if {[llength [info commands testlocale]] == 0} { - # No testlocale command, no tests... - testConstraint hasIsoLocale 0 - } else { - testConstraint hasIsoLocale \ - [string length [SetIso8859_1_Locale]] - RestoreLocale + ConstraintInitializer hasIsoLocale { + if {[llength [info commands testlocale]] == 0} { + set code 0 + } else { + set code [string length [SetIso8859_1_Locale]] + RestoreLocale + } + set code } + } ##################################################################### @@ -1399,12 +1416,12 @@ proc tcltest::ProcessFlags {flagArray} { # Use the -constraints flag, if given, to turn on constraints that # are turned off by default: userInteractive knownBug nonPortable. - # This code fragment must be run after constraints are initialized. if {[info exists flag(-constraints)]} { foreach elt $flag(-constraints) { testConstraint $elt 1 } + ConstraintsSpecifiedByCommandLineArgument $flag(-constraints) } # Use the -limitconstraints flag, if given, to tell the harness to @@ -2220,7 +2237,6 @@ proc tcltest::RunTest { variable numTests variable skip variable match - variable limitConstraints variable testConstraints variable originalTclPlatform variable coreModTime @@ -2264,7 +2280,7 @@ proc tcltest::RunTest { if {[string equal {} $constraints]} { # If we're limited to the listed constraints and there aren't # any listed, then we shouldn't run the test. - if {$limitConstraints} { + if {[limitConstraints]} { AddToSkippedBecause userSpecifiedLimitConstraint if {$testLevel == 1} { incr numTests(Skipped) @@ -3309,7 +3325,25 @@ proc tcltest::threadReap {} { # Initialize the constraints and set up command line arguments namespace eval tcltest { - InitConstraints + # Define initializers for all the built-in contraint definitions + DefineConstraintInitializers + + # Set up the constraints in the testConstraints array to be lazily + # initialized by a registered initializer, or by "false" if no + # initializer is registered. + trace variable testConstraints r [namespace code SafeFetch] + + # Only initialize constraints at package load time if an + # [initConstraintsHook] has been pre-defined. This is only + # for compatibility support. The modern way to add a custom + # test constraint is to just call the [testConstraint] command + # straight away, without all this "hook" nonsense. + if {[string equal [namespace current] \ + [namespace qualifiers [namespace which initConstraintsHook]]]} { + InitConstraints + } else { + proc initConstraintsHook {} {} + } ProcessCmdLineArgs # Save the names of files that already exist in |