summaryrefslogtreecommitdiffstats
path: root/library
diff options
context:
space:
mode:
Diffstat (limited to 'library')
-rwxr-xr-xlibrary/tcltest/tcltest2.tcl363
-rwxr-xr-xlibrary/tcltest1.0/tcltest2.tcl363
2 files changed, 476 insertions, 250 deletions
diff --git a/library/tcltest/tcltest2.tcl b/library/tcltest/tcltest2.tcl
index 9a6104e..2a676dc 100755
--- a/library/tcltest/tcltest2.tcl
+++ b/library/tcltest/tcltest2.tcl
@@ -13,9 +13,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest2.tcl,v 1.1 2000/09/20 23:09:52 jenn Exp $
-
-package provide tcltest 2.0
+# RCS: @(#) $Id: tcltest2.tcl,v 1.2 2000/09/29 22:48:12 jenn Exp $
# create the "tcltest" namespace for all testing variables and procedures
@@ -100,9 +98,9 @@ namespace eval tcltest {
variable parameters {}
}
- # Count the number of files tested (0 if all.tcl wasn't called).
- # The all.tcl file will set testSingleFile to false, so stats will
- # not be printed until all.tcl calls the cleanupTests proc.
+ # Count the number of files tested (0 if runAllTests wasn't called).
+ # runAllTests will set testSingleFile to false, so stats will
+ # not be printed until runAllTests calls the cleanupTests proc.
# The currentFailure var stores the boolean value of whether the
# current test file has had any failures. The failFiles list
# stores the names of test files that had failures.
@@ -1868,7 +1866,6 @@ proc tcltest::testEval {script {ignoreOutput 1}} {
# actual - string containing the actual result
# expected - pattern to be matched against
# mode - type of comparison to be done
-# subst - perform subst on the expected value if this is true
#
# Results:
# result of the match
@@ -1876,18 +1873,7 @@ proc tcltest::testEval {script {ignoreOutput 1}} {
# Side effects:
# None.
-proc tcltest::compareStrings {actual expected mode {subst false}} {
- if {$subst} {
- switch -- $mode {
- exact {
- set expected [uplevel 2 subst \{$expected\}]
- }
- glob -
- regexp {
- set expected [uplevel 2 subst -nocommand -nobackslashes \{$expected\}]
- }
- }
- }
+proc tcltest::compareStrings {actual expected mode} {
switch -- $mode {
exact {
set retval [string equal $actual $expected]
@@ -1896,13 +1882,109 @@ proc tcltest::compareStrings {actual expected mode {subst false}} {
set retval [string match $expected $actual]
}
regexp {
- set retval [regexp $expected $actual]
+ set retval [regexp -- $expected $actual]
}
}
return $retval
}
+#
+# tcltest::substArguments list
+#
+# This helper function takes in a list of words, then perform a
+# substitution on the list as though each word in the list is a
+# separate argument to the Tcl function. For example, if this
+# function is invoked as:
+#
+# substArguments {$a {$a}}
+#
+# Then it is as though the function is invoked as:
+#
+# substArguments $a {$a}
+#
+# This code is adapted from Paul Duffin's function "SplitIntoWords".
+# The original function can be found on:
+#
+# http://purl.org/thecliff/tcl/wiki/858.html
+#
+# Returns:
+# a list containing the result of the substitution
+#
+# Exceptions:
+# An error may occur if the list containing unbalanced quote or
+# unknown variable.
+#
+proc tcltest::substArguments {argList} {
+
+ # We need to split the argList up into tokens but cannot use
+ # list operations as they throw away some significant
+ # quoting, and [split] ignores braces as it should.
+ # Therefore what we do is gradually build up a string out of
+ # whitespace seperated strings. We cannot use [split] to
+ # split the argList into whitespace seperated strings as it
+ # throws away the whitespace which maybe important so we
+ # have to do it all by hand.
+
+ set result {}
+ set token ""
+
+ while {[string length $argList]} {
+ # Look for the next word containing a quote: " { }
+ if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
+ $argList all]} {
+ # Get the text leading up to this word, but not
+ # including this word, from the argList.
+ set text [string range $argList 0 \
+ [expr {[lindex $all 0] - 1}]]
+ # Get the word with the quote
+ set word [string range $argList \
+ [lindex $all 0] [lindex $all 1]]
+
+ # Remove all text up to and including the word from the
+ # argList.
+ set argList [string range $argList \
+ [expr {[lindex $all 1] + 1}] end]
+ } else {
+ # Take everything up to the end of the argList.
+ set text $argList
+ set word {}
+ set argList {}
+ }
+
+ if {$token != {}} {
+ # If we saw a word with quote before, then there is a
+ # multi-word token starting with that word. In this case,
+ # add the text and the current word to this token.
+ append token $text $word
+ } else {
+ # Add the text to the result. There is no need to parse
+ # the text because it couldn't be a part of any multi-word
+ # token. Then start a new multi-word token with the word
+ # because we need to pass this token to the Tcl parser to
+ # check for balancing quotes
+ append result $text
+ set token $word
+ }
+
+ if { [catch {llength $token} length] == 0 && $length == 1} {
+ # The token is a valid list so add it to the result.
+ # lappend result [string trim $token]
+ append result \{$token\}
+ set token {}
+ }
+ }
+
+ # If the last token has not been added to the list then there
+ # is a problem.
+ if { [string length $token] } {
+ error "incomplete token \"$token\""
+ }
+
+ return $result
+}
+
+
# test --
#
# This procedure runs a test and prints an error message if the test fails.
@@ -1920,133 +2002,147 @@ proc tcltest::compareStrings {actual expected mode {subst false}} {
# Only description is a required attribute. All others are optional.
# Default values are indicated.
#
-# description - Short textual description of the test, to
-# help humans understand what it does.
# constraints - A list of one or more keywords, each of
# which must be the name of an element in
# the array "tcltest::testConstraints". If any
# of these elements is zero, the test is
# skipped. This attribute is optional; default is {}
-# script - Script to run to carry out the test. It must
+# body - Script to run to carry out the test. It must
# return a result that can be checked for
# correctness. This attribute is optional;
# default is {}
-# expect - Expected result from script. This attribute is
+# result - Expected result from script. This attribute is
# optional; default is {}.
-# expect_out - Expected output sent to stdout. This attribute
+# output - Expected output sent to stdout. This attribute
# is optional; default is {}.
-# expect_err - Expected output sent to stderr. This attribute
+# errorOutput - Expected output sent to stderr. This attribute
# is optional; default is {}.
-# expect_codes - Expected return codes. This attribute is
+# returnCodes - Expected return codes. This attribute is
# optional; default is {0 2}.
# setup - Code to run before $script (above). This
# attribute is optional; default is {}.
# cleanup - Code to run after $script (above). This
# attribute is optional; default is {}.
+# match - specifies type of matching to do on result,
+# output, errorOutput; this must be one of: exact,
+# glob, regexp. default is exact.
#
# Arguments:
# name - Name of test, in the form foo-1.2.
+# description - Short textual description of the test, to
+# help humans understand what it does.
#
# Results:
# 0 if the command ran successfully; 1 otherwise.
#
# Side effects:
#
-proc tcltest::test {name args} {
+proc tcltest::test {name description args} {
DebugPuts 3 "Test $name $args"
incr tcltest::testLevel
- # Pre-define everything to null except expect_out and expect_err. We
+ # Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not these
- # variables (expect_out & expect_err) are defined.
- foreach item {constraints setup cleanup description script \
- expect expect_codes} {
+ # variables (output & errorOutput) are defined.
+ foreach item {constraints setup cleanup body result returnCodes match} {
set $item {}
}
# Set the default match mode
- set expectMatch exact
- set expect_outMatch exact
- set expect_errMatch exact
-
- # default test format is the old format (where we don't have to subst the
- # expected answer
- set substExpected false
+ set match exact
# Set the default match values for return codes (0 is the standard expected
# return value if everything went well; 2 represents 'return' being used in
# the test script).
- set expect_codes [list 0 2]
+ set returnCodes [list 0 2]
- if {[llength $args] >= 3} {
- # This is parsing for the old test command format; it is here for
- # backward compatibility.
- set description [lindex $args 0]
- set expect [lindex $args end]
- if {[llength $args] == 3} {
- set script [lindex $args 1]
+ # if the commands are embedded within an outer set of braces, we have to do
+ # evaluate them before we can run or compare them
+ set doSubst false
+
+ # The old test format can't have a 3rd argument (constraints or script)
+ # that starts with '-'.
+ if {[llength $args] == 0} {
+ puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}"
+ incr tcltest::testLevel -1
+ return 1
+ } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} {
+ if {[llength args] == 1} {
+ set list [substArguments [lindex $args 0]]
+ foreach {element value} $list {
+ set testAttributes($element) $value
+ }
+ set doSubst true
} else {
- set constraints [lindex $args 1]
- set script [lindex $args 2]
+ array set testAttributes $args
+ }
+
+ set validFlags {-setup -cleanup -body -result -returnCodes -match \
+ -output -errorOutput -constraints}
+
+ foreach flag [array names testAttributes] {
+ if {[lsearch -exact $validFlags $flag] == -1} {
+ puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test"
+ incr tcltest::testLevel -1
+ return 1
+ }
}
- } else {
- # we'll have to do a subst on the expected values later
- set substExpected true
- set testAttributes [lindex $args 0]
+ # store whatever the user gave us
+ foreach item [array names testAttributes] {
+ set [string trimleft $item "-"] $testAttributes($item)
+ }
- # These are attribute value pairs; there must be an even number in the
- # list.
- if {[expr {[llength $testAttributes] %2}] == 1} {
- puts [errorChannel] "value for \"[lindex $testAttributes end]\" missing"
+ # Check the values supplied for -match
+ if {[lsearch {regexp glob exact} $match] == -1} {
+ puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}"
incr tcltest::testLevel -1
return 1
}
- # store whatever the user gave us
- foreach {item value} $testAttributes {
- set $item $value
+ # Replace symbolic valies supplied for -returnCodes
+ regsub -nocase normal $returnCodes 0 returnCodes
+ regsub -nocase error $returnCodes 1 returnCodes
+ regsub -nocase return $returnCodes 2 returnCodes
+ regsub -nocase break $returnCodes 3 returnCodes
+ regsub -nocase continue $returnCodes 4 returnCodes
+ } else {
+ # This is parsing for the old test command format; it is here for
+ # backward compatibility.
+ set result [lindex $args end]
+ if {[llength $args] == 2} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 3} {
+ set constraints [lindex $args 0]
+ set body [lindex $args 1]
+ } else {
+ puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}"
+ incr tcltest::testLevel -1
+ return 1
}
-
- foreach mode {expect expect_out expect_err} {
- if {[info exists $mode]} {
- set expectedContent [subst $$mode]
- set suffix Match
- # Set the match mode and the content based on whether or not
- # the exact, glob, or regexp flags are being used. If they
- # are, set the appropriate match flag and reset the match
- # pattern.
- if {[llength $expectedContent] == 2} {
- set flag [lindex $expectedContent 0]
- if {[regexp -- {-(exact|glob|regexp)} $flag fullMatch \
- $mode$suffix]} {
- set $mode [lindex $expectedContent 1]
- }
- }
- }
- }
- }
+ }
- if {($name == {}) || ($description == {})} {
- puts [errorChannel] "one of: name, description empty"
- incr tcltest::testLevel -1
- return 1
- }
-
set setupFailure 0
set cleanupFailure 0
# Run the setup script
+ if {$doSubst} {
+ set setup [uplevel concat $setup]
+ }
if {[catch {uplevel $setup} setupMsg]} {
set setupFailure 1
}
# run the test script
- set command [list tcltest::runTest $name $description $script \
- $expect $constraints]
+ if {$doSubst} {
+ set constraints [uplevel concat $constraints]
+ set body [uplevel concat $body]
+ }
+ set command [list tcltest::runTest $name $description $body \
+ $result $constraints]
if {!$setupFailure} {
- if {[info exists expect_out] || [info exists expect_err]} {
+ if {[info exists output] || [info exists errorOutput]} {
set testResult [uplevel tcltest::testEval [list $command] 0]
} else {
set testResult [uplevel tcltest::testEval [list $command] 1]
@@ -2056,19 +2152,32 @@ proc tcltest::test {name args} {
}
# Run the cleanup code
+ if {$doSubst} {
+ set cleanup [uplevel concat $cleanup]
+ }
if {[catch {uplevel $cleanup} cleanupMsg]} {
set cleanupFailure 1
}
+ if {$doSubst} {
+ foreach item {result returnCodes match} {
+ set $item [uplevel concat [subst $$item]]
+ }
+ if {[info exists output]} {
+ set output [uplevel concat $output]
+ }
+ if {[info exists errorOutput]} {
+ set errorOutput [uplevel concat $errorOutput]
+ }
+ }
+
# If testResult is an empty list, then the test was skipped
if {$testResult != {}} {
-
set coreFailure 0
set coreMsg ""
# check for a core file first - if one was created by the test, then
# the test failed
if {$tcltest::preserveCore} {
- puts "checking for core"
set currentTclPlatform [array get tcl_platform]
if {[file exists [file join [tcltest::workingDirectory] core]]} {
# There's only a test failure if there is a core file and (1)
@@ -2084,7 +2193,6 @@ proc tcltest::test {name args} {
}
if {($tcltest::preserveCore > 1) && ($coreFailure)} {
- puts "core failure (> 1)"
append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]"
catch {file rename -force \
[file join [tcltest::workingDirectory] core] \
@@ -2098,8 +2206,6 @@ proc tcltest::test {name args} {
array set tcl_platform $currentTclPlatform
}
- set expectedAnswer $expect
-
set actualAnswer [lindex $testResult 0]
set code [lindex $testResult end]
@@ -2107,38 +2213,40 @@ proc tcltest::test {name args} {
# them. If the comparison fails, then so did the test.
set outputFailure 0
set errorFailure 0
- if {[info exists expect_out]} {
+ if {[info exists output]} {
set outputFailure [expr ![compareStrings $tcltest::outData \
- $expect_out $expect_outMatch $substExpected]]
+ $output $match]]
}
- if {[info exists expect_err]} {
+ if {[info exists errorOutput]} {
set errorFailure [expr ![compareStrings $tcltest::errData \
- $expect_err $expect_errMatch $substExpected]]
+ $errorOutput $match]]
}
set testFailed 1
set codeFailure 0
+ set scriptFailure 0
+ # check if the return code matched the expected return code
+ if {[lsearch -exact $returnCodes $code] == -1} {
+ set codeFailure 1
+ }
+
+ # check if the answer matched the expected answer
+ if {[compareStrings $actualAnswer $result $match] == 0} {
+ set scriptFailure 1
+ }
+
+ # if we didn't experience any failures, then we passed
if {!($setupFailure || $cleanupFailure || $coreFailure || \
- $outputFailure || $errorFailure)} {
- # if the strings compare properly, and we didn't experience a
- # problem with setup or cleanup, we might have passed.
- if {[compareStrings $actualAnswer $expectedAnswer $expectMatch $substExpected]} {
- # if the return code matches the expected return codes, we
- # definitely passed.
- if {[lsearch -exact $code $expect_codes]} {
- set codeFailure 0
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Passed)
- if {[string first p $tcltest::verbose] != -1} {
- puts [outputChannel] "++++ $name PASSED"
- }
- }
- set testFailed 0
- } else {
- set codeFailure 1
+ $outputFailure || $errorFailure || $codeFailure || \
+ $scriptFailure)} {
+ if {$tcltest::testLevel == 1} {
+ incr tcltest::numTests(Passed)
+ if {[string first p $tcltest::verbose] != -1} {
+ puts [outputChannel] "++++ $name PASSED"
}
}
+ set testFailed 0
}
if {$testFailed} {
@@ -2147,21 +2255,21 @@ proc tcltest::test {name args} {
}
set tcltest::currentFailure true
if {[string first b $tcltest::verbose] == -1} {
- set script ""
+ set body ""
}
- puts [outputChannel] "\n==== $name $description FAILED"
- if {$script != ""} {
+ puts [outputChannel] "\n==== $name [string trim $description] FAILED"
+ if {$body != ""} {
puts [outputChannel] "==== Contents of test case:"
- puts [outputChannel] $script
+ puts [outputChannel] $body
}
if {$setupFailure} {
puts [outputChannel] "---- Test setup failed:\n$setupMsg"
- } else {
- puts [outputChannel] "---- Result should have been ($expectMatch matching):\n$expectedAnswer"
+ }
+ if {$scriptFailure} {
puts [outputChannel] "---- Result was:\n$actualAnswer"
+ puts [outputChannel] "---- Result should have been ($match matching):\n$result"
}
if {$codeFailure} {
- puts [outputChannel] "---- Return code should have been one of: $expect_codes"
switch -- $code {
0 { set msg "Test completed normally" }
1 { set msg "Test generated error" }
@@ -2171,14 +2279,15 @@ proc tcltest::test {name args} {
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $code"
+ puts [outputChannel] "---- Return code should have been one of: $returnCodes"
}
if {$outputFailure} {
- puts [outputChannel] "---- Output should have been ($expect_outMatch matching):\n$expect_out"
puts [outputChannel] "---- Output was:\n$tcltest::outData"
+ puts [outputChannel] "---- Output should have been ($match matching):\n$output"
}
if {$errorFailure} {
- puts [outputChannel] "---- Error output should have been ($expect_errMatch matching):\n$expect_err"
puts [outputChannel] "---- Error output was:\n$tcltest::errData"
+ puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput"
}
if {$cleanupFailure} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
@@ -2187,11 +2296,13 @@ proc tcltest::test {name args} {
puts [outputChannel] "---- Core file produced while running test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
+
}
}
incr tcltest::testLevel -1
- return 0}
+ return 0
+}
# runTest --
@@ -2323,7 +2434,6 @@ proc tcltest::runTest {name description script expectedAnswer constraints} {
# tcl_platform.
if {$tcltest::preserveCore} {
- puts "check for core 2"
set currentTclPlatform [array get tcl_platform]
array set tcl_platform $tcltest::originalTclPlatform
if {[file exists [file join [tcltest::workingDirectory] core]]} {
@@ -2784,6 +2894,7 @@ proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] {
puts [outputChannel] "\n$dir test ended at $endTime"
puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
}
+ return
}
#####################################################################
@@ -3120,3 +3231,5 @@ namespace eval tcltest {
}
}
+package provide tcltest 2.0
+
diff --git a/library/tcltest1.0/tcltest2.tcl b/library/tcltest1.0/tcltest2.tcl
index 9a6104e..2a676dc 100755
--- a/library/tcltest1.0/tcltest2.tcl
+++ b/library/tcltest1.0/tcltest2.tcl
@@ -13,9 +13,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest2.tcl,v 1.1 2000/09/20 23:09:52 jenn Exp $
-
-package provide tcltest 2.0
+# RCS: @(#) $Id: tcltest2.tcl,v 1.2 2000/09/29 22:48:12 jenn Exp $
# create the "tcltest" namespace for all testing variables and procedures
@@ -100,9 +98,9 @@ namespace eval tcltest {
variable parameters {}
}
- # Count the number of files tested (0 if all.tcl wasn't called).
- # The all.tcl file will set testSingleFile to false, so stats will
- # not be printed until all.tcl calls the cleanupTests proc.
+ # Count the number of files tested (0 if runAllTests wasn't called).
+ # runAllTests will set testSingleFile to false, so stats will
+ # not be printed until runAllTests calls the cleanupTests proc.
# The currentFailure var stores the boolean value of whether the
# current test file has had any failures. The failFiles list
# stores the names of test files that had failures.
@@ -1868,7 +1866,6 @@ proc tcltest::testEval {script {ignoreOutput 1}} {
# actual - string containing the actual result
# expected - pattern to be matched against
# mode - type of comparison to be done
-# subst - perform subst on the expected value if this is true
#
# Results:
# result of the match
@@ -1876,18 +1873,7 @@ proc tcltest::testEval {script {ignoreOutput 1}} {
# Side effects:
# None.
-proc tcltest::compareStrings {actual expected mode {subst false}} {
- if {$subst} {
- switch -- $mode {
- exact {
- set expected [uplevel 2 subst \{$expected\}]
- }
- glob -
- regexp {
- set expected [uplevel 2 subst -nocommand -nobackslashes \{$expected\}]
- }
- }
- }
+proc tcltest::compareStrings {actual expected mode} {
switch -- $mode {
exact {
set retval [string equal $actual $expected]
@@ -1896,13 +1882,109 @@ proc tcltest::compareStrings {actual expected mode {subst false}} {
set retval [string match $expected $actual]
}
regexp {
- set retval [regexp $expected $actual]
+ set retval [regexp -- $expected $actual]
}
}
return $retval
}
+#
+# tcltest::substArguments list
+#
+# This helper function takes in a list of words, then perform a
+# substitution on the list as though each word in the list is a
+# separate argument to the Tcl function. For example, if this
+# function is invoked as:
+#
+# substArguments {$a {$a}}
+#
+# Then it is as though the function is invoked as:
+#
+# substArguments $a {$a}
+#
+# This code is adapted from Paul Duffin's function "SplitIntoWords".
+# The original function can be found on:
+#
+# http://purl.org/thecliff/tcl/wiki/858.html
+#
+# Returns:
+# a list containing the result of the substitution
+#
+# Exceptions:
+# An error may occur if the list containing unbalanced quote or
+# unknown variable.
+#
+proc tcltest::substArguments {argList} {
+
+ # We need to split the argList up into tokens but cannot use
+ # list operations as they throw away some significant
+ # quoting, and [split] ignores braces as it should.
+ # Therefore what we do is gradually build up a string out of
+ # whitespace seperated strings. We cannot use [split] to
+ # split the argList into whitespace seperated strings as it
+ # throws away the whitespace which maybe important so we
+ # have to do it all by hand.
+
+ set result {}
+ set token ""
+
+ while {[string length $argList]} {
+ # Look for the next word containing a quote: " { }
+ if {[regexp -indices {[^ \t\n]*[\"\{\}]+[^ \t\n]*} \
+ $argList all]} {
+ # Get the text leading up to this word, but not
+ # including this word, from the argList.
+ set text [string range $argList 0 \
+ [expr {[lindex $all 0] - 1}]]
+ # Get the word with the quote
+ set word [string range $argList \
+ [lindex $all 0] [lindex $all 1]]
+
+ # Remove all text up to and including the word from the
+ # argList.
+ set argList [string range $argList \
+ [expr {[lindex $all 1] + 1}] end]
+ } else {
+ # Take everything up to the end of the argList.
+ set text $argList
+ set word {}
+ set argList {}
+ }
+
+ if {$token != {}} {
+ # If we saw a word with quote before, then there is a
+ # multi-word token starting with that word. In this case,
+ # add the text and the current word to this token.
+ append token $text $word
+ } else {
+ # Add the text to the result. There is no need to parse
+ # the text because it couldn't be a part of any multi-word
+ # token. Then start a new multi-word token with the word
+ # because we need to pass this token to the Tcl parser to
+ # check for balancing quotes
+ append result $text
+ set token $word
+ }
+
+ if { [catch {llength $token} length] == 0 && $length == 1} {
+ # The token is a valid list so add it to the result.
+ # lappend result [string trim $token]
+ append result \{$token\}
+ set token {}
+ }
+ }
+
+ # If the last token has not been added to the list then there
+ # is a problem.
+ if { [string length $token] } {
+ error "incomplete token \"$token\""
+ }
+
+ return $result
+}
+
+
# test --
#
# This procedure runs a test and prints an error message if the test fails.
@@ -1920,133 +2002,147 @@ proc tcltest::compareStrings {actual expected mode {subst false}} {
# Only description is a required attribute. All others are optional.
# Default values are indicated.
#
-# description - Short textual description of the test, to
-# help humans understand what it does.
# constraints - A list of one or more keywords, each of
# which must be the name of an element in
# the array "tcltest::testConstraints". If any
# of these elements is zero, the test is
# skipped. This attribute is optional; default is {}
-# script - Script to run to carry out the test. It must
+# body - Script to run to carry out the test. It must
# return a result that can be checked for
# correctness. This attribute is optional;
# default is {}
-# expect - Expected result from script. This attribute is
+# result - Expected result from script. This attribute is
# optional; default is {}.
-# expect_out - Expected output sent to stdout. This attribute
+# output - Expected output sent to stdout. This attribute
# is optional; default is {}.
-# expect_err - Expected output sent to stderr. This attribute
+# errorOutput - Expected output sent to stderr. This attribute
# is optional; default is {}.
-# expect_codes - Expected return codes. This attribute is
+# returnCodes - Expected return codes. This attribute is
# optional; default is {0 2}.
# setup - Code to run before $script (above). This
# attribute is optional; default is {}.
# cleanup - Code to run after $script (above). This
# attribute is optional; default is {}.
+# match - specifies type of matching to do on result,
+# output, errorOutput; this must be one of: exact,
+# glob, regexp. default is exact.
#
# Arguments:
# name - Name of test, in the form foo-1.2.
+# description - Short textual description of the test, to
+# help humans understand what it does.
#
# Results:
# 0 if the command ran successfully; 1 otherwise.
#
# Side effects:
#
-proc tcltest::test {name args} {
+proc tcltest::test {name description args} {
DebugPuts 3 "Test $name $args"
incr tcltest::testLevel
- # Pre-define everything to null except expect_out and expect_err. We
+ # Pre-define everything to null except output and errorOutput. We
# determine whether or not to trap output based on whether or not these
- # variables (expect_out & expect_err) are defined.
- foreach item {constraints setup cleanup description script \
- expect expect_codes} {
+ # variables (output & errorOutput) are defined.
+ foreach item {constraints setup cleanup body result returnCodes match} {
set $item {}
}
# Set the default match mode
- set expectMatch exact
- set expect_outMatch exact
- set expect_errMatch exact
-
- # default test format is the old format (where we don't have to subst the
- # expected answer
- set substExpected false
+ set match exact
# Set the default match values for return codes (0 is the standard expected
# return value if everything went well; 2 represents 'return' being used in
# the test script).
- set expect_codes [list 0 2]
+ set returnCodes [list 0 2]
- if {[llength $args] >= 3} {
- # This is parsing for the old test command format; it is here for
- # backward compatibility.
- set description [lindex $args 0]
- set expect [lindex $args end]
- if {[llength $args] == 3} {
- set script [lindex $args 1]
+ # if the commands are embedded within an outer set of braces, we have to do
+ # evaluate them before we can run or compare them
+ set doSubst false
+
+ # The old test format can't have a 3rd argument (constraints or script)
+ # that starts with '-'.
+ if {[llength $args] == 0} {
+ puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?options?\"}"
+ incr tcltest::testLevel -1
+ return 1
+ } elseif {([string index [lindex $args 0] 0] == "-") || ([llength $args] == 1)} {
+ if {[llength args] == 1} {
+ set list [substArguments [lindex $args 0]]
+ foreach {element value} $list {
+ set testAttributes($element) $value
+ }
+ set doSubst true
} else {
- set constraints [lindex $args 1]
- set script [lindex $args 2]
+ array set testAttributes $args
+ }
+
+ set validFlags {-setup -cleanup -body -result -returnCodes -match \
+ -output -errorOutput -constraints}
+
+ foreach flag [array names testAttributes] {
+ if {[lsearch -exact $validFlags $flag] == -1} {
+ puts [errorChannel] "test $name: bad flag $flag supplied to tcltest::test"
+ incr tcltest::testLevel -1
+ return 1
+ }
}
- } else {
- # we'll have to do a subst on the expected values later
- set substExpected true
- set testAttributes [lindex $args 0]
+ # store whatever the user gave us
+ foreach item [array names testAttributes] {
+ set [string trimleft $item "-"] $testAttributes($item)
+ }
- # These are attribute value pairs; there must be an even number in the
- # list.
- if {[expr {[llength $testAttributes] %2}] == 1} {
- puts [errorChannel] "value for \"[lindex $testAttributes end]\" missing"
+ # Check the values supplied for -match
+ if {[lsearch {regexp glob exact} $match] == -1} {
+ puts [errorChannel] "test $name: {bad value for -match: must be one of exact, glob, regexp}"
incr tcltest::testLevel -1
return 1
}
- # store whatever the user gave us
- foreach {item value} $testAttributes {
- set $item $value
+ # Replace symbolic valies supplied for -returnCodes
+ regsub -nocase normal $returnCodes 0 returnCodes
+ regsub -nocase error $returnCodes 1 returnCodes
+ regsub -nocase return $returnCodes 2 returnCodes
+ regsub -nocase break $returnCodes 3 returnCodes
+ regsub -nocase continue $returnCodes 4 returnCodes
+ } else {
+ # This is parsing for the old test command format; it is here for
+ # backward compatibility.
+ set result [lindex $args end]
+ if {[llength $args] == 2} {
+ set body [lindex $args 0]
+ } elseif {[llength $args] == 3} {
+ set constraints [lindex $args 0]
+ set body [lindex $args 1]
+ } else {
+ puts [errorChannel] "test $name: {wrong # args: should be \"test name desc ?constraints? script expectedResult\"}"
+ incr tcltest::testLevel -1
+ return 1
}
-
- foreach mode {expect expect_out expect_err} {
- if {[info exists $mode]} {
- set expectedContent [subst $$mode]
- set suffix Match
- # Set the match mode and the content based on whether or not
- # the exact, glob, or regexp flags are being used. If they
- # are, set the appropriate match flag and reset the match
- # pattern.
- if {[llength $expectedContent] == 2} {
- set flag [lindex $expectedContent 0]
- if {[regexp -- {-(exact|glob|regexp)} $flag fullMatch \
- $mode$suffix]} {
- set $mode [lindex $expectedContent 1]
- }
- }
- }
- }
- }
+ }
- if {($name == {}) || ($description == {})} {
- puts [errorChannel] "one of: name, description empty"
- incr tcltest::testLevel -1
- return 1
- }
-
set setupFailure 0
set cleanupFailure 0
# Run the setup script
+ if {$doSubst} {
+ set setup [uplevel concat $setup]
+ }
if {[catch {uplevel $setup} setupMsg]} {
set setupFailure 1
}
# run the test script
- set command [list tcltest::runTest $name $description $script \
- $expect $constraints]
+ if {$doSubst} {
+ set constraints [uplevel concat $constraints]
+ set body [uplevel concat $body]
+ }
+ set command [list tcltest::runTest $name $description $body \
+ $result $constraints]
if {!$setupFailure} {
- if {[info exists expect_out] || [info exists expect_err]} {
+ if {[info exists output] || [info exists errorOutput]} {
set testResult [uplevel tcltest::testEval [list $command] 0]
} else {
set testResult [uplevel tcltest::testEval [list $command] 1]
@@ -2056,19 +2152,32 @@ proc tcltest::test {name args} {
}
# Run the cleanup code
+ if {$doSubst} {
+ set cleanup [uplevel concat $cleanup]
+ }
if {[catch {uplevel $cleanup} cleanupMsg]} {
set cleanupFailure 1
}
+ if {$doSubst} {
+ foreach item {result returnCodes match} {
+ set $item [uplevel concat [subst $$item]]
+ }
+ if {[info exists output]} {
+ set output [uplevel concat $output]
+ }
+ if {[info exists errorOutput]} {
+ set errorOutput [uplevel concat $errorOutput]
+ }
+ }
+
# If testResult is an empty list, then the test was skipped
if {$testResult != {}} {
-
set coreFailure 0
set coreMsg ""
# check for a core file first - if one was created by the test, then
# the test failed
if {$tcltest::preserveCore} {
- puts "checking for core"
set currentTclPlatform [array get tcl_platform]
if {[file exists [file join [tcltest::workingDirectory] core]]} {
# There's only a test failure if there is a core file and (1)
@@ -2084,7 +2193,6 @@ proc tcltest::test {name args} {
}
if {($tcltest::preserveCore > 1) && ($coreFailure)} {
- puts "core failure (> 1)"
append coreMsg "\nMoving file to: [file join $tcltest::temporaryDirectory core-$name]"
catch {file rename -force \
[file join [tcltest::workingDirectory] core] \
@@ -2098,8 +2206,6 @@ proc tcltest::test {name args} {
array set tcl_platform $currentTclPlatform
}
- set expectedAnswer $expect
-
set actualAnswer [lindex $testResult 0]
set code [lindex $testResult end]
@@ -2107,38 +2213,40 @@ proc tcltest::test {name args} {
# them. If the comparison fails, then so did the test.
set outputFailure 0
set errorFailure 0
- if {[info exists expect_out]} {
+ if {[info exists output]} {
set outputFailure [expr ![compareStrings $tcltest::outData \
- $expect_out $expect_outMatch $substExpected]]
+ $output $match]]
}
- if {[info exists expect_err]} {
+ if {[info exists errorOutput]} {
set errorFailure [expr ![compareStrings $tcltest::errData \
- $expect_err $expect_errMatch $substExpected]]
+ $errorOutput $match]]
}
set testFailed 1
set codeFailure 0
+ set scriptFailure 0
+ # check if the return code matched the expected return code
+ if {[lsearch -exact $returnCodes $code] == -1} {
+ set codeFailure 1
+ }
+
+ # check if the answer matched the expected answer
+ if {[compareStrings $actualAnswer $result $match] == 0} {
+ set scriptFailure 1
+ }
+
+ # if we didn't experience any failures, then we passed
if {!($setupFailure || $cleanupFailure || $coreFailure || \
- $outputFailure || $errorFailure)} {
- # if the strings compare properly, and we didn't experience a
- # problem with setup or cleanup, we might have passed.
- if {[compareStrings $actualAnswer $expectedAnswer $expectMatch $substExpected]} {
- # if the return code matches the expected return codes, we
- # definitely passed.
- if {[lsearch -exact $code $expect_codes]} {
- set codeFailure 0
- if {$tcltest::testLevel == 1} {
- incr tcltest::numTests(Passed)
- if {[string first p $tcltest::verbose] != -1} {
- puts [outputChannel] "++++ $name PASSED"
- }
- }
- set testFailed 0
- } else {
- set codeFailure 1
+ $outputFailure || $errorFailure || $codeFailure || \
+ $scriptFailure)} {
+ if {$tcltest::testLevel == 1} {
+ incr tcltest::numTests(Passed)
+ if {[string first p $tcltest::verbose] != -1} {
+ puts [outputChannel] "++++ $name PASSED"
}
}
+ set testFailed 0
}
if {$testFailed} {
@@ -2147,21 +2255,21 @@ proc tcltest::test {name args} {
}
set tcltest::currentFailure true
if {[string first b $tcltest::verbose] == -1} {
- set script ""
+ set body ""
}
- puts [outputChannel] "\n==== $name $description FAILED"
- if {$script != ""} {
+ puts [outputChannel] "\n==== $name [string trim $description] FAILED"
+ if {$body != ""} {
puts [outputChannel] "==== Contents of test case:"
- puts [outputChannel] $script
+ puts [outputChannel] $body
}
if {$setupFailure} {
puts [outputChannel] "---- Test setup failed:\n$setupMsg"
- } else {
- puts [outputChannel] "---- Result should have been ($expectMatch matching):\n$expectedAnswer"
+ }
+ if {$scriptFailure} {
puts [outputChannel] "---- Result was:\n$actualAnswer"
+ puts [outputChannel] "---- Result should have been ($match matching):\n$result"
}
if {$codeFailure} {
- puts [outputChannel] "---- Return code should have been one of: $expect_codes"
switch -- $code {
0 { set msg "Test completed normally" }
1 { set msg "Test generated error" }
@@ -2171,14 +2279,15 @@ proc tcltest::test {name args} {
default { set msg "Test generated exception" }
}
puts [outputChannel] "---- $msg; Return code was: $code"
+ puts [outputChannel] "---- Return code should have been one of: $returnCodes"
}
if {$outputFailure} {
- puts [outputChannel] "---- Output should have been ($expect_outMatch matching):\n$expect_out"
puts [outputChannel] "---- Output was:\n$tcltest::outData"
+ puts [outputChannel] "---- Output should have been ($match matching):\n$output"
}
if {$errorFailure} {
- puts [outputChannel] "---- Error output should have been ($expect_errMatch matching):\n$expect_err"
puts [outputChannel] "---- Error output was:\n$tcltest::errData"
+ puts [outputChannel] "---- Error output should have been ($match matching):\n$errorOutput"
}
if {$cleanupFailure} {
puts [outputChannel] "---- Test cleanup failed:\n$cleanupMsg"
@@ -2187,11 +2296,13 @@ proc tcltest::test {name args} {
puts [outputChannel] "---- Core file produced while running test! $coreMsg"
}
puts [outputChannel] "==== $name FAILED\n"
+
}
}
incr tcltest::testLevel -1
- return 0}
+ return 0
+}
# runTest --
@@ -2323,7 +2434,6 @@ proc tcltest::runTest {name description script expectedAnswer constraints} {
# tcl_platform.
if {$tcltest::preserveCore} {
- puts "check for core 2"
set currentTclPlatform [array get tcl_platform]
array set tcl_platform $tcltest::originalTclPlatform
if {[file exists [file join [tcltest::workingDirectory] core]]} {
@@ -2784,6 +2894,7 @@ proc tcltest::runAllTests [list [list shell [tcltest::interpreter]]] {
puts [outputChannel] "\n$dir test ended at $endTime"
puts [outputChannel] "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
}
+ return
}
#####################################################################
@@ -3120,3 +3231,5 @@ namespace eval tcltest {
}
}
+package provide tcltest 2.0
+
generated by cgit v0.12 at 2024-11-06 09:03:22 (GMT)