- priority: 5 --> 2
- status: open --> closed-fixed
OriginalBugID: 2838 Bug
Version: 8.2
SubmitDate: '1999-09-20'
LastModified: '1999-10-20'
Severity: LOW
Status: Released
Submitter: techsupp
ChangedBy: jenn
OS: Other
Machine: NA
FixedDate: '1999-10-20'
ClosedDate: '2000-10-25'
Name:
Andreas Kupries
ReproducibleScript:
A bit of cosmetic, added linefeeds between the procedure
definitions. But also moved the code dealing with debug output
into three helper procedures (DebugPuts, ...PArray,
...Do). This makes the procedures using them easier to read,
the package is easier to maintain, and people writing test
suites or interfaces to test suites are able to redirect the
information to somewhere else without having to rewrite an
unknown number of procedures.
ObservedBehavior:
--
DesiredBehavior:
--
Patch:
*** tcltest.tcl.orig Mon Sep 13 19:49:00 1999
--- tcltest.tcl Wed Sep 15 19:15:20 1999
***************
*** 193,199 ****
--- 193,270 ----
}
}
+
+ # ::tcltest::Debug* --
+ #
+ # Internal helper procedures to write out debug information
+ # dependent on the chosen level. A test shell may overide
+ # them, f.e. to redirect the output into a different
+ # channel, or even into a GUI.
+
+ # ::tcltest::DebugPuts --
+ #
+ # Prints the specified string if the current debug level is
+ # higher than the provided level argument.
+ #
+ # Arguments:
+ # level The highest debug level not triggering the output
+ # string The string to print out.
+ #
+ # Results:
+ # Prints the string. Nothing else is allowed.
+ #
+
+ proc ::tcltest::DebugPuts {level string} {
+ variable debug
+ if {$debug > $level} {
+ puts $string
+ }
+ }
+
+ # ::tcltest::DebugPArray --
+ #
+ # Prints the contents of the specified array if the current
+ # debug level is higher than the provided level argument
+ #
+ # Arguments:
+ # level The highest debug level not triggering the output
+ # arrayvar The name of the array to print out.
+ #
+ # Results:
+ # Prints the contents of the array. Nothing else is allowed.
+ #
+
+ proc ::tcltest::DebugPArray {level arrayvar} {
+ variable debug
+
+ if {$debug > $level} {
+ catch {upvar $arrayvar $arrayvar}
+ parray $arrayvar
+ }
+ }
+
+ # ::tcltest::DebugDo --
+ #
+ # Executes the script if the current debug level is greater than
+ # the provided level argument
+ #
+ # Arguments:
+ # level The highest debug level not triggering the execution.
+ # script The tcl script executed upon a debug level high enough.
+ #
+ # Results:
+ # Arbitrary side effects, dependent on the executed script.
+ #
+
+ proc ::tcltest::DebugDo {level script} {
+ variable debug
+
+ if {$debug > $level} {
+ uplevel $script
+ }
+ }
+
# ::tcltest::AddToSkippedBecause --
#
# Increments the variable used to track how many tests were skipped
***************
*** 217,223 ****
}
return
}
!
# ::tcltest::PrintError --
#
# Prints errors to ::tcltest::errorChannel and then flushes that
--- 288,294 ----
}
return
}
!
# ::tcltest::PrintError --
#
# Prints errors to ::tcltest::errorChannel and then flushes that
***************
*** 269,275 ****
flush $::tcltest::errorChannel
return
}
!
proc ::tcltest::initConstraintsHook {} {}
# ::tcltest::initConstraints --
--- 340,346 ----
flush $::tcltest::errorChannel
return
}
!
proc ::tcltest::initConstraintsHook {} {}
# ::tcltest::initConstraints --
***************
*** 544,550 ****
::tcltest::restore_locale
}
}
!
# ::tcltest::PrintUsageInfoHook
#
# Hook used for customization of display of usage information.
--- 615,621 ----
::tcltest::restore_locale
}
}
!
# ::tcltest::PrintUsageInfoHook
#
# Hook used for customization of display of usage information.
***************
*** 605,611 ****
::tcltest::PrintUsageInfoHook
return
}
!
# ::tcltest::processCmdLineArgsFlagsHook --
#
# This hook is used to add to the list of command line arguments that are
--- 676,682 ----
::tcltest::PrintUsageInfoHook
return
}
!
# ::tcltest::processCmdLineArgsFlagsHook --
#
# This hook is used to add to the list of command line arguments that are
***************
*** 822,843 ****
::tcltest::processCmdLineArgsHook [array get flag]
# Spit out everything you know if we're at debug level 2 or greater
- if {$::tcltest::debug > 1} {
- puts "Flags passed into tcltest:"
- parray flag
- puts "::tcltest::debug = $::tcltest::debug"
- puts "::tcltest::testsDirectory = $::tcltest::testsDirectory"
- puts "::tcltest::workingDirectory = $::tcltest::workingDirectory"
- puts "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
- puts "::tcltest::outputChannel = $::tcltest::outputChannel"
- puts "::tcltest::errorChannel = $::tcltest::errorChannel"
- puts "Original environment (::tcltest::originalEnv):"
- parray ::tcltest::originalEnv
- puts "Constraints:"
- parray ::tcltest::testConstraints
- }
- }
# ::tcltest::cleanupTests --
#
# Remove files and dirs created using the makeFile and makeDirectory
--- 893,913 ----
::tcltest::processCmdLineArgsHook [array get flag]
# Spit out everything you know if we're at debug level 2 or greater
+ DebugPuts 1 "Flags passed into tcltest:"
+ DebugPArray 1 flag
+ DebugPuts 1 "::tcltest::debug = $::tcltest::debug"
+ DebugPuts 1 "::tcltest::testsDirectory = $::tcltest::testsDirectory"
+ DebugPuts 1 "::tcltest::workingDirectory = $::tcltest::workingDirectory"
+ DebugPuts 1 "::tcltest::temporaryDirectory = $::tcltest::temporaryDirectory"
+ DebugPuts 1 "::tcltest::outputChannel = $::tcltest::outputChannel"
+ DebugPuts 1 "::tcltest::errorChannel = $::tcltest::errorChannel"
+ DebugPuts 1 "Original environment (::tcltest::originalEnv):"
+ DebugPArray 1 ::tcltest::originalEnv
+ DebugPuts 1 "Constraints:"
+ DebugPArray 1 ::tcltest::testConstraints
+ }
+
# ::tcltest::cleanupTests --
#
# Remove files and dirs created using the makeFile and makeDirectory
***************
*** 1051,1057 ****
#
proc ::tcltest::cleanupTestsHook {} {}
!
# test --
#
# This procedure runs a test and prints an error message if the test fails.
--- 1121,1127 ----
#
proc ::tcltest::cleanupTestsHook {} {}
!
# test --
#
# This procedure runs a test and prints an error message if the test fails.
***************
*** 1076,1084 ****
# expectedAnswer - Expected result from script.
proc ::tcltest::test {name description script expectedAnswer args} {
! if {$::tcltest::debug > 2} {
! puts "Running $name ($description)"
! }
incr ::tcltest::numTests(Total)
--- 1146,1153 ----
# expectedAnswer - Expected result from script.
proc ::tcltest::test {name description script expectedAnswer args} {
!
! DebugPuts 2 "Running $name ($description)"
incr ::tcltest::numTests(Total)
***************
*** 1087,1095 ****
foreach pattern $::tcltest::skip {
if {[string match $pattern $name]} {
incr ::tcltest::numTests(Skipped)
! if {$::tcltest::debug} {
! ::tcltest::AddToSkippedBecause userSpecifiedSkip
! }
return
}
}
--- 1156,1162 ----
foreach pattern $::tcltest::skip {
if {[string match $pattern $name]} {
incr ::tcltest::numTests(Skipped)
! DebugDo 0 {::tcltest::AddToSkippedBecause userSpecifiedSkip}
return
}
}
***************
*** 1106,1114 ****
}
if {!$ok} {
incr ::tcltest::numTests(Skipped)
! if {$::tcltest::debug} {
! ::tcltest::AddToSkippedBecause userSpecifiedNonMatch
! }
return
}
}
--- 1173,1179 ----
}
if {!$ok} {
incr ::tcltest::numTests(Skipped)
! DebugDo 0 {::tcltest::AddToSkippedBecause userSpecifiedNonMatch}
return
}
}
***************
*** 1260,1266 ****
array set tcl_platform $currentTclPlatform
}
}
!
# ::tcltest::getMatchingTestFiles
#
# Looks at the patterns given to match and skip files
--- 1325,1331 ----
array set tcl_platform $currentTclPlatform
}
}
!
# ::tcltest::getMatchingTestFiles
#
# Looks at the patterns given to match and skip files
***************
*** 1312,1318 ****
}
return $matchingFiles
}
!
# The following two procs are used in the io tests.
proc ::tcltest::openfiles {} {
--- 1377,1383 ----
}
return $matchingFiles
}
!
# The following two procs are used in the io tests.
proc ::tcltest::openfiles {} {
***************
*** 1334,1340 ****
}
return $leak
}
!
# ::tcltest::saveState --
#
# Save information regarding what procs and variables exist.
--- 1399,1405 ----
}
return $leak
}
!
# ::tcltest::saveState --
#
# Save information regarding what procs and variables exist.
***************
*** 1347,1355 ****
proc ::tcltest::saveState {} {
uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
! if {$::tcltest::debug > 1} {
! puts "::tcltest::saveState: $::tcltest::saveState"
! }
}
# ::tcltest::restoreState --
--- 1412,1418 ----
proc ::tcltest::saveState {} {
uplevel #0 {set ::tcltest::saveState [list [info procs] [info vars]]}
! DebugPuts 1 "::tcltest::saveState: $::tcltest::saveState"
}
# ::tcltest::restoreState --
***************
*** 1368,1389 ****
foreach p [info procs] {
if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
(![string equal ::tcltest::$p [namespace origin $p]])} {
! if {$::tcltest::debug > 2} {
! puts "::tcltest::restoreState: Removing proc $p"
! }
rename $p {}
}
}
foreach p [uplevel #0 {info vars}] {
if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
! if {$::tcltest::debug > 2} {
! puts "::tcltest::restoreState: Removing variable $p"
! }
uplevel #0 "unset $p"
}
}
}
!
# ::tcltest::normalizeMsg --
#
# Removes "extra" newlines from a string.
--- 1431,1450 ----
foreach p [info procs] {
if {([lsearch [lindex $::tcltest::saveState 0] $p] < 0) && \
(![string equal ::tcltest::$p [namespace origin $p]])} {
!
! DebugPuts 2 "::tcltest::restoreState: Removing proc $p"
rename $p {}
}
}
foreach p [uplevel #0 {info vars}] {
if {[lsearch [lindex $::tcltest::saveState 1] $p] < 0} {
!
! DebugPuts 2 "::tcltest::restoreState: Removing variable $p"
uplevel #0 "unset $p"
}
}
}
!
# ::tcltest::normalizeMsg --
#
# Removes "extra" newlines from a string.
***************
*** 1398,1404 ****
regsub -all "\n\}" $msg "\}" msg
return $msg
}
!
# makeFile --
#
# Create a new file with the name <name>, and write <contents> to it.
--- 1459,1465 ----
regsub -all "\n\}" $msg "\}" msg
return $msg
}
!
# makeFile --
#
# Create a new file with the name <name>, and write <contents> to it.
***************
*** 1410,1418 ****
proc ::tcltest::makeFile {contents name} {
global tcl_platform
! if {$::tcltest::debug > 2} {
! puts "::tcltest::makeFile: putting $contents into $name"
! }
set fd [open [file join $::tcltest::temporaryDirectory $name] w]
fconfigure $fd -translation lf
--- 1471,1478 ----
proc ::tcltest::makeFile {contents name} {
global tcl_platform
! DebugPuts 2 "::tcltest::makeFile: putting $contents into $name"
!
set fd [open [file join $::tcltest::temporaryDirectory $name] w]
fconfigure $fd -translation lf
***************
*** 1431,1437 ****
lappend ::tcltest::filesMade $fullName
}
}
!
# ::tcltest::removeFile --
#
# Removes the named file from the filesystem
--- 1491,1497 ----
lappend ::tcltest::filesMade $fullName
}
}
!
# ::tcltest::removeFile --
#
# Removes the named file from the filesystem
***************
*** 1441,1452 ****
#
proc ::tcltest::removeFile {name} {
! if {$::tcltest::debug > 2} {
! puts "::tcltest::removeFile: removing $name"
! }
file delete [file join $::tcltest::temporaryDirectory $name]
}
!
# makeDirectory --
#
# Create a new dir with the name <name>.
--- 1501,1510 ----
#
proc ::tcltest::removeFile {name} {
! DebugPuts 2 "::tcltest::removeFile: removing $name"
file delete [file join $::tcltest::temporaryDirectory $name]
}
!
# makeDirectory --
#
# Create a new dir with the name <name>.
***************
*** 1475,1481 ****
proc ::tcltest::removeDirectory {name} {
file delete -force $name
}
!
proc ::tcltest::viewFile {name} {
global tcl_platform
if {([string equal $tcl_platform(platform) "macintosh"]) || \
--- 1533,1539 ----
proc ::tcltest::removeDirectory {name} {
file delete -force $name
}
!
proc ::tcltest::viewFile {name} {
global tcl_platform
if {([string equal $tcl_platform(platform) "macintosh"]) || \
***************
*** 1488,1494 ****
exec cat [file join $::tcltest::temporaryDirectory $name]
}
}
!
# grep --
#
# Evaluate a given expression against each element of a list and return all
--- 1546,1552 ----
exec cat [file join $::tcltest::temporaryDirectory $name]
}
}
!
# grep --
#
# Evaluate a given expression against each element of a list and return all
***************
*** 1508,1514 ****
# Example:
# grep {regexp a} $someList
#
! proc ::tcltest:grep { expression searchList } {
foreach element $searchList {
if {[regsub -all CURRENT_ELEMENT $expression $element \
newExpression] == 0} {
--- 1566,1572 ----
# Example:
# grep {regexp a} $someList
#
! proc ::tcltest::grep { expression searchList } {
foreach element $searchList {
if {[regsub -all CURRENT_ELEMENT $expression $element \
newExpression] == 0} {
***************
*** 1523,1529 ****
}
return
}
!
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
--- 1581,1587 ----
}
return
}
!
#
# Construct a string that consists of the requested sequence of bytes,
# as opposed to a string of properly formed UTF-8 characters.
***************
*** 1541,1547 ****
proc ::tcltest::bytestring {string} {
encoding convertfrom identity $string
}
!
#
# Internationalization / ISO support procs -- dl
#
--- 1599,1605 ----
proc ::tcltest::bytestring {string} {
encoding convertfrom identity $string
}
!
#
# Internationalization / ISO support procs -- dl
#
***************
*** 1559,1565 ****
}
return
}
!
# threadReap --
#
# Kill all threads except for the main thread.
--- 1617,1623 ----
}
return
}
!
# threadReap --
#
# Kill all threads except for the main thread.
***************
*** 1587,1593 ****
return 1
}
}
!
# Initialize the constraints and set up command line arguments
namespace eval tcltest {
::tcltest::initConstraints
--- 1645,1651 ----
return 1
}
}
!
# Initialize the constraints and set up command line arguments
namespace eval tcltest {
::tcltest::initConstraints
PatchFiles:
tcltest.tcl
It may be more intuitive if the level sent into the Debug helper procs is the first debug level at which something is done (e.g. debug output is printed, script gets run) rather then the last debug level at which something isn't done.
-- 09/21/1999 jenn