From 96da55129351108de4a053ec7b8cdfa272f727ee Mon Sep 17 00:00:00 2001 From: jenn Date: Fri, 9 Jul 1999 00:00:58 +0000 Subject: Removed -asidefromdir and -relateddir flags, removed unused ::tcltest::dotests proc, cleaned up implementation of core file checking, and fixed the code that checks for 1-letter flag abbreviations. --- ChangeLog | 11 +- doc/tcltest.n | 45 ++++---- library/tcltest/tcltest.tcl | 250 ++++++++++++++++++++++------------------- library/tcltest1.0/tcltest.tcl | 250 ++++++++++++++++++++++------------------- 4 files changed, 306 insertions(+), 250 deletions(-) diff --git a/ChangeLog b/ChangeLog index d9d4a59..97c8b3d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ +1999-07-08 Jennifer Hom + + * doc/tcltest.n: + * library/tcltest1.0/tcltest.tcl: Removed -asidefromdir and + -relateddir flags, removed unused ::tcltest::dotests proc, cleaned + up implementation of core file checking, and fixed the code that + checks for 1-letter flag abbreviations. + 1999-07-08 * win/Makefile.in: Added tcltest target so runtest works @@ -97,7 +105,8 @@ * library/tcltest1.0/tcltest.tcl: * library/tcltest1.0: Added initial implementation of the Tcl test harness package. This package was based on the defs.tcl file that - was part of the tests directory. + was part of the tests directory. Reversed the way that tests were + evaluated to fix a problem with false passes. * doc/tcltest.n: Added documentation for the tcltest package. diff --git a/doc/tcltest.n b/doc/tcltest.n index b065333..951595b 100644 --- a/doc/tcltest.n +++ b/doc/tcltest.n @@ -6,7 +6,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tcltest.n,v 1.2 1999/06/29 20:14:10 jenn Exp $ +'\" RCS: @(#) $Id: tcltest.n,v 1.3 1999/07/09 00:01:01 jenn Exp $ '\" .so man.macros .TH "Tcltest" n 8.1 Tcl "Tcl Built-In Commands" @@ -23,8 +23,6 @@ Tcltest \- Test harness support code and utilities .sp \fB::tcltest::getMatchingTestFiles .sp -\fB::tcltest::dotests \fIfile pattern\fR -.sp \fB::tcltest::makeFile \fIcontents name\fR .sp \fB::tcltest::removeFile \fIname\fR @@ -98,9 +96,6 @@ This command is used when you want to run multiple test files. It returns the list of tests that should be sourced in an 'all.tcl' file. See the section \fI"Running test files"\fR for more information. .TP -\fB::tcltest::dotests\fP \fIfile pattern\fR -Source a test file and run tests of the specified pattern. -.TP \fB::tcltest::makeFile\fP \fIcontents name\fR Create a file that will be automatically be removed by \fB::tcltest::cleanupTests\fR at the end of a test run. @@ -224,8 +219,7 @@ the output directory - defaults to the current working directory and can be specified using -tmpdir .TP \fB::tcltest::testsDirectory\fR -where the tests reside - defaults to [pwd] and can be affected by use of --relateddir and -asidefromdir +where the tests reside .TP \fB::tcltest::isoLocale\fR used for internationalization support - default language is French; default @@ -383,14 +377,6 @@ only source test files that match any of the items in source files except for those that match any of the items in (relative to ::tcltest::testsDirectory). .TP -\fB-relateddir \fR -only run tests in the directories that match (relative to the -current directory). -.TP -\fB-asidefromdir \fR -use all specified directories except those that match (relative -to the current directory). -.TP \fB-constraints \fR tests with any constraints in will not be skipped. Note that elements of must exactly match the existing constraints. @@ -406,23 +392,36 @@ put any temporary files (created with ::tcltest::makeFile and ::tcltest::makeDirectory) into the named directory. The default location is your current working directory. .TP -\fB-preservecore \fR -If the argument to this flag is 1 (true), the test harness saves any -core files produced at the end of a test run in -::tcltest::temporaryDirectory. The default value for this flag is 0 -(false). +\fB-preservecore \fR +check for core files. This flag is used to determine how much +checking should be done for core files. The default value for +\fIlevel\fR is 0. Levels are defined as: +.RS +.IP 0 +No checking - do not check for core files at the end of each test +command, but do check for them whenever ::tcltest::cleanupTests is +called from an all.tcl file. +.IP 1 +Check for core files at the end of each test command and whenever +::tcltest::cleanupTests is called from all.tcl. +.IP 2 +Check for core files at the end of all test commands and whenever +::tcltest::cleanupTests is called from all.tcl. Save any core files +produced in ::tcltest::temporaryDirectory. .TP \fB-debug \fR print out debug information. This is used to debug code in the test -harness. The default debug level is 1. Levels are defined as: +harness. The default debug level is 0. Levels are defined as: .RS +.IP 0 +Do not display any debug information. .IP 1 Display information regarding whether a test is skipped because it doesn't match any of the tests that were specified using -match or ::tcltest::match (userSpecifiedNonMatch) or matches any of the tests specified by -skip or ::tcltest::skip (userSpecifiedSkip). .IP 2 -Display the flag array parssed by the command line processor, the +Display the flag array parsed by the command line processor, the contents of the env array, and all user-defined variables that exist in the current namespace as they are used. .IP 3 diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 91e7630..8640d67 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -5,14 +5,14 @@ # directory, constraints available, output and error channels, etc. used # by Tcl tests. See the README file for more details. # -# This design was based on the original Tcl testing approach designed and +# This design was based on the Tcl testing approach designed and # initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.4 1999/07/08 02:57:17 rjohnson Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.5 1999/07/09 00:01:02 jenn Exp $ package provide tcltest 1.0 @@ -24,10 +24,9 @@ set auto_path [list [info library]] namespace eval tcltest { # Export the public tcltest procs - set procList [list test cleanupTests dotests saveState restoreState \ + set procList [list test cleanupTests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile grep bytestring set_iso8859_1_locale restore_locale \ - safeFetch threadReap getMatchingTestFiles] + viewFile bytestring safeFetch threadReap getMatchingTestFiles] foreach proc $procList { namespace export $proc } @@ -45,11 +44,8 @@ namespace eval tcltest { variable matchFiles {*.test} variable skipFiles {} - variable matchDirectories {} - variable skipDirectories {} - # By default, don't save core files - variable preserveCore false + variable preserveCore 0 # output goes to stdout by default @@ -126,7 +122,7 @@ namespace eval tcltest { set mainThread [testthread names] } - # save the original environement so that it can be restored later + # save the original environment so that it can be restored later array set ::tcltest::originalEnv [array get ::env] @@ -140,7 +136,10 @@ namespace eval tcltest { # Files that are part of the test suite should be accessed relative to # ::tcltest::testsDirectory. + set oDir [pwd] + cd [file join [file dirname [info library]] tests] variable testsDirectory [pwd] + cd $oDir # the variables and procs that existed when ::tcltest::saveState was # called are stored in a variable of the same name @@ -185,7 +184,15 @@ namespace eval tcltest { variable tcltest [info nameofexecutable] # save the platform information so it can be restored later - variable tcl_platform [array get tcl_platform] + variable originalTclPlatform [array get tcl_platform] + + + # If a core file exists, save its modification time. + if {[file exists [file join $::tcltest::workingDirectory core]]} { + variable coreModificationTime [file mtime [file join \ + $::tcltest::workingDirectory core]] + } + } # ::tcltest::AddToSkippedBecause -- @@ -215,7 +222,7 @@ proc ::tcltest::AddToSkippedBecause { constraint } { # ::tcltest::PrintError -- # # Prints errors to ::tcltest::errorChannel and then flushes that -# channel. +# channel, making sure that all messages are < 80 characters per line. # # Arguments: # errorMsg String containing the error to be printed @@ -225,18 +232,24 @@ proc ::tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] puts -nonewline $::tcltest::errorChannel $InitialMessage - set beginningIndex [string wordend $errorMsg 72] + set beginningIndex [string last " " [string range $errorMsg 0 \ + [string wordend $errorMsg 72]]] puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] set endingIndex [string length $errorMsg] while {$beginningIndex < $endingIndex} { - set newEndingIndex [string wordend $errorMsg \ - [expr {$beginningIndex + 72}]] + set newEndingIndex [string last " " [string range $errorMsg \ + $beginningIndex [string wordend $errorMsg \ + [expr {$beginningIndex + 72}]]]] + if {$newEndingIndex == 0} { + set newEndingIndex $endingIndex + } puts -nonewline $::tcltest::errorChannel \ [string repeat " " $InitialMsgLen] puts $::tcltest::errorChannel [string trim \ [string range $errorMsg $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex } + flush $::tcltest::errorChannel return } @@ -291,11 +304,14 @@ proc ::tcltest::initConstraints {} { set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly) set ::tcltest::testConstraints(unixOrPc) \ - [expr {$::tcltest::testConstraints(unix) || $::tcltest::testConstraints(pc)}] + [expr {$::tcltest::testConstraints(unix) \ + || $::tcltest::testConstraints(pc)}] set ::tcltest::testConstraints(macOrPc) \ - [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(pc)}] + [expr {$::tcltest::testConstraints(mac) \ + || $::tcltest::testConstraints(pc)}] set ::tcltest::testConstraints(macOrUnix) \ - [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(unix)}] + [expr {$::tcltest::testConstraints(mac) \ + || $::tcltest::testConstraints(unix)}] set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ "Windows NT"] @@ -310,18 +326,25 @@ proc ::tcltest::initConstraints {} { # but have been temporarily disabled on certain platforms because they don't # and we haven't gotten around to fixing the underlying problem. - set ::tcltest::testConstraints(tempNotPc) [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(tempNotMac) [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(tempNotUnix) [expr {!$::tcltest::testConstraints(unix)}] + set ::tcltest::testConstraints(tempNotPc) \ + [expr {!$::tcltest::testConstraints(pc)}] + set ::tcltest::testConstraints(tempNotMac) \ + [expr {!$::tcltest::testConstraints(mac)}] + set ::tcltest::testConstraints(tempNotUnix) \ + [expr {!$::tcltest::testConstraints(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. - set ::tcltest::testConstraints(pcCrash) [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(win32sCrash) [expr {!$::tcltest::testConstraints(win32s)}] - set ::tcltest::testConstraints(macCrash) [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(unixCrash) [expr {!$::tcltest::testConstraints(unix)}] + set ::tcltest::testConstraints(pcCrash) \ + [expr {!$::tcltest::testConstraints(pc)}] + set ::tcltest::testConstraints(win32sCrash) \ + [expr {!$::tcltest::testConstraints(win32s)}] + set ::tcltest::testConstraints(macCrash) \ + [expr {!$::tcltest::testConstraints(mac)}] + set ::tcltest::testConstraints(unixCrash) \ + [expr {!$::tcltest::testConstraints(unix)}] # Skip empty tests @@ -547,13 +570,10 @@ proc ::tcltest::PrintUsageInfo {} { \t match the glob pattern given. \n\ -notfile pattern\t Skip all test files that match the \n\ \t glob pattern given. \n\ - -relateddir pattern\t Run tests in directories that match \n\ - \t the glob pattern given. \n\ - -asidefromdir pattern\t Skip tests in directories that match \n\ - \t the glob pattern given. \n\ -preservecore level \t If 2, save any core files produced \n\ \t during testing in the directory \n\ - \t specified by -tmpdir. The default \n\ + \t specified by -tmpdir. If 1, notify the\n\ + \t user if core files are created. The default \n\ \t is $::tcltest::preserveCore. \n\ -tmpdir directory\t Save temporary files in the specified\n\ \t directory. The default value is \n\ @@ -634,8 +654,8 @@ proc ::tcltest::processCmdLineArgs {} { # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile -relateddir \ - -asidefromdir -preservecore -limitconstraints + -outfile -errfile -debug -tmpdir -file -notfile \ + -preservecore -limitconstraints set defaultFlags [concat $defaultFlags \ [ ::tcltest::processCmdLineArgsAddFlagsHook ]] @@ -674,14 +694,6 @@ proc ::tcltest::processCmdLineArgs {} { set ::tcltest::skipFiles $flag(-notfile) } - # Handle -relateddir and -asidefromdir flags - if {[info exists flag(-relateddir)]} { - set ::tcltest::matchDirectories $flag(-relateddir) - } - if {[info exists flag(-asidefromdir)]} { - set ::tcltest::skipDirectories $flag(-asidefromdir) - } - # 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. @@ -788,29 +800,6 @@ proc ::tcltest::processCmdLineArgs {} { set ::tcltest::preserveCore $flag(-preserveCore) } - # Find the matching directories and then remove the ones that are - # specified in the skip pattern; if no match pattern is specified, use - # the default value specified for ::tcltest::testsDirectory - ignore the - # value of ::tcltest::skipDirectories if the default value is being used. - if {$::tcltest::matchDirectories != {}} { - set matchDir {} - set skipDir {} - if {$::tcltest::skipDirectories != {}} { - set skipDir [glob -nocomplain $::tcltest::skipDirectories] - } - foreach dir [glob -nocomplain $::tcltest::matchDirectories] { - if {[lsearch -exact $skipDir $dir] == -1} { - lappend matchDir $dir - } - } - - # Only reset ::tcltest::testsDirectory if anything actually matched - # after removing the skip patterns. - if {[llength $matchDir] > 0} { - set ::tcltest::testsDirectory $matchDir - } - } - # Call the hook ::tcltest::processCmdLineArgsHook [array get flag] @@ -993,6 +982,44 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { "env array elements removed:\t$removedEnv" } + set changedTclPlatform {} + foreach index [array names ::tcltest::originalTclPlatform] { + if {$::tcl_platform($index) != \ + $::tcltest::originalTclPlatform($index)} { + lappend changedTclPlatform $index + set ::tcl_platform($index) \ + $::tcltest::originalTclPlatform($index) + } + } + if {[llength $changedTclPlatform] > 0} { + puts $::tcltest::outputChannel \ + "tcl_platform array elements changed:\t$changedTclPlatform" + } + + if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {$::tcltest::preserveCore > 1} { + file rename -force \ + [file join $::tcltest::workingDirectory core] \ + [file join $::tcltest::temporaryDirectory core-$name] + + puts $::tcltest::outputChannel "produced core file! \ + Moved file to: \ + [file join $::tcltest::temporaryDirectory core-$name]" + } else { + # Print a message if there is a core file and (1) there + # previously wasn't one or (2) the new one is different from + # the old one. + + if {[info exists ::tcltest::coreModificationTime]} { + if {$::tcltest::coreModificationTime != [file mtime \ + [file join $::tcltest::workingDirectory core]]} { + puts $::tcltest::outputChannel "A core file was created!" + } + } else { + puts $::tcltest::outputChannel "A core file was created!" + } + } + } } } @@ -1028,12 +1055,11 @@ proc ::tcltest::cleanupTestsHook {} {} # expectedAnswer - Expected result from script. proc ::tcltest::test {name description script expectedAnswer args} { - incr ::tcltest::numTests(Total) + if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + puts "Running $name ($description)" + } -# if {[file exists [file join $::tcltest::workingDirectory core]]} { -# set coreModificationTime [file mtime [file join \ -# $::tcltest::workingDirectory core]] -# } + incr ::tcltest::numTests(Total) # skip the test if it's name matches an element of skip @@ -1065,6 +1091,7 @@ proc ::tcltest::test {name description script expectedAnswer args} { return } } + set i [llength $args] if {$i == 0} { set constraints {} @@ -1122,6 +1149,19 @@ proc ::tcltest::test {name description script expectedAnswer args} { error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" } + # Save information about the core file. You need to restore the original + # tcl_platform environment because some of the tests mess with tcl_platform. + + if {$::tcltest::preserveCore} { + set currentTclPlatform [array get tcl_platform] + array set tcl_platform $::tcltest::originalTclPlatform + if {[file exists [file join $::tcltest::workingDirectory core]]} { + set coreModTime [file mtime [file join \ + $::tcltest::workingDirectory core]] + } + array set tcl_platform $currentTclPlatform + } + # If there is no "memory" command (because memory debugging isn't # enabled), then don't attempt to use the command. @@ -1167,28 +1207,34 @@ proc ::tcltest::test {name description script expectedAnswer args} { puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" puts $::tcltest::outputChannel "==== $name FAILED\n" } -# if {[file exists [file join $::tcltest::workingDirectory core]]} { -# if {$::tcltest::preserveCore} { -# file rename -force [file join $::tcltest::workingDirectory core] \ -# [file join $::tcltest::temporaryDirectory core-$name] - -# puts $::tcltest::outputChannel "==== $name produced core file! \ -# Moved file to: \ -# [file join $::tcltest::temporaryDirectory core-$name]" -# } else { -# # Print a message if there is a core file and (1) there previously -# # wasn't one or (2) the new one is different from the old one. - -# if {[info exists coreModificationTime]} { -# if {$coreModificationTime != [file mtime \ -# [file join $::tcltest::workingDirectory core]]} { -# puts $::tcltest::outputChannel "==== $name produced core file!" -# } -# } else { -# puts $::tcltest::outputChannel "==== $name produced core file!" -# } -# } -# } + if {$::tcltest::preserveCore} { + set currentTclPlatform [array get tcl_platform] + if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {$::tcltest::preserveCore > 1} { + file rename -force \ + [file join $::tcltest::workingDirectory core] \ + [file join $::tcltest::temporaryDirectory core-$name] + + puts $::tcltest::outputChannel "==== $name produced core file! \ + Moved file to: \ + [file join $::tcltest::temporaryDirectory core-$name]" + } else { + # Print a message if there is a core file and (1) there + # previously wasn't one or (2) the new one is different from + # the old one. + + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join $::tcltest::workingDirectory core]]} { + puts $::tcltest::outputChannel "==== $name produced core file!" + } + } else { + puts $::tcltest::outputChannel "==== $name produced core file!" + } + } + } + array set tcl_platform $currentTclPlatform + } } # ::tcltest::getMatchingTestFiles @@ -1238,29 +1284,6 @@ proc ::tcltest::getMatchingFiles {} { return $matchingFiles } -# ::tcltest::dotests -- -# -# takes two arguments--the name of the test file (such -# as "parse.test"), and a pattern selecting the tests you want to -# execute. It sets ::tcltest::match to the second argument, calls -# "source" on the file specified in the first argument, and restores -# ::tcltest::match to its pre-call value at the end. -# -# Arguments: -# file name of tests file to source -# args pattern selecting the tests you want to execute -# -# Results: -# none - -proc ::tcltest::dotests {file args} { - set savedTests $::tcltest::match - set ::tcltest::match $args - source $file - set ::tcltest::match $savedTests -} - - # The following two procs are used in the io tests. proc ::tcltest::openfiles {} { @@ -1362,6 +1385,7 @@ proc ::tcltest::makeFile {contents name} { puts "::tcltest::makeFile: putting $contents into $name" } set fd [open $name w] + fconfigure $fd -translation lf if {[string equal \ diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index 91e7630..8640d67 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -5,14 +5,14 @@ # directory, constraints available, output and error channels, etc. used # by Tcl tests. See the README file for more details. # -# This design was based on the original Tcl testing approach designed and +# This design was based on the Tcl testing approach designed and # initially implemented by Mary Ann May-Pumphrey of Sun Microsystems. # # Copyright (c) 1994-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.4 1999/07/08 02:57:17 rjohnson Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.5 1999/07/09 00:01:02 jenn Exp $ package provide tcltest 1.0 @@ -24,10 +24,9 @@ set auto_path [list [info library]] namespace eval tcltest { # Export the public tcltest procs - set procList [list test cleanupTests dotests saveState restoreState \ + set procList [list test cleanupTests saveState restoreState \ normalizeMsg makeFile removeFile makeDirectory removeDirectory \ - viewFile grep bytestring set_iso8859_1_locale restore_locale \ - safeFetch threadReap getMatchingTestFiles] + viewFile bytestring safeFetch threadReap getMatchingTestFiles] foreach proc $procList { namespace export $proc } @@ -45,11 +44,8 @@ namespace eval tcltest { variable matchFiles {*.test} variable skipFiles {} - variable matchDirectories {} - variable skipDirectories {} - # By default, don't save core files - variable preserveCore false + variable preserveCore 0 # output goes to stdout by default @@ -126,7 +122,7 @@ namespace eval tcltest { set mainThread [testthread names] } - # save the original environement so that it can be restored later + # save the original environment so that it can be restored later array set ::tcltest::originalEnv [array get ::env] @@ -140,7 +136,10 @@ namespace eval tcltest { # Files that are part of the test suite should be accessed relative to # ::tcltest::testsDirectory. + set oDir [pwd] + cd [file join [file dirname [info library]] tests] variable testsDirectory [pwd] + cd $oDir # the variables and procs that existed when ::tcltest::saveState was # called are stored in a variable of the same name @@ -185,7 +184,15 @@ namespace eval tcltest { variable tcltest [info nameofexecutable] # save the platform information so it can be restored later - variable tcl_platform [array get tcl_platform] + variable originalTclPlatform [array get tcl_platform] + + + # If a core file exists, save its modification time. + if {[file exists [file join $::tcltest::workingDirectory core]]} { + variable coreModificationTime [file mtime [file join \ + $::tcltest::workingDirectory core]] + } + } # ::tcltest::AddToSkippedBecause -- @@ -215,7 +222,7 @@ proc ::tcltest::AddToSkippedBecause { constraint } { # ::tcltest::PrintError -- # # Prints errors to ::tcltest::errorChannel and then flushes that -# channel. +# channel, making sure that all messages are < 80 characters per line. # # Arguments: # errorMsg String containing the error to be printed @@ -225,18 +232,24 @@ proc ::tcltest::PrintError {errorMsg} { set InitialMessage "Error: " set InitialMsgLen [string length $InitialMessage] puts -nonewline $::tcltest::errorChannel $InitialMessage - set beginningIndex [string wordend $errorMsg 72] + set beginningIndex [string last " " [string range $errorMsg 0 \ + [string wordend $errorMsg 72]]] puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] set endingIndex [string length $errorMsg] while {$beginningIndex < $endingIndex} { - set newEndingIndex [string wordend $errorMsg \ - [expr {$beginningIndex + 72}]] + set newEndingIndex [string last " " [string range $errorMsg \ + $beginningIndex [string wordend $errorMsg \ + [expr {$beginningIndex + 72}]]]] + if {$newEndingIndex == 0} { + set newEndingIndex $endingIndex + } puts -nonewline $::tcltest::errorChannel \ [string repeat " " $InitialMsgLen] puts $::tcltest::errorChannel [string trim \ [string range $errorMsg $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex } + flush $::tcltest::errorChannel return } @@ -291,11 +304,14 @@ proc ::tcltest::initConstraints {} { set ::tcltest::testConstraints(pc) $::tcltest::testConstraints(pcOnly) set ::tcltest::testConstraints(unixOrPc) \ - [expr {$::tcltest::testConstraints(unix) || $::tcltest::testConstraints(pc)}] + [expr {$::tcltest::testConstraints(unix) \ + || $::tcltest::testConstraints(pc)}] set ::tcltest::testConstraints(macOrPc) \ - [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(pc)}] + [expr {$::tcltest::testConstraints(mac) \ + || $::tcltest::testConstraints(pc)}] set ::tcltest::testConstraints(macOrUnix) \ - [expr {$::tcltest::testConstraints(mac) || $::tcltest::testConstraints(unix)}] + [expr {$::tcltest::testConstraints(mac) \ + || $::tcltest::testConstraints(unix)}] set ::tcltest::testConstraints(nt) [string equal $tcl_platform(os) \ "Windows NT"] @@ -310,18 +326,25 @@ proc ::tcltest::initConstraints {} { # but have been temporarily disabled on certain platforms because they don't # and we haven't gotten around to fixing the underlying problem. - set ::tcltest::testConstraints(tempNotPc) [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(tempNotMac) [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(tempNotUnix) [expr {!$::tcltest::testConstraints(unix)}] + set ::tcltest::testConstraints(tempNotPc) \ + [expr {!$::tcltest::testConstraints(pc)}] + set ::tcltest::testConstraints(tempNotMac) \ + [expr {!$::tcltest::testConstraints(mac)}] + set ::tcltest::testConstraints(tempNotUnix) \ + [expr {!$::tcltest::testConstraints(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. - set ::tcltest::testConstraints(pcCrash) [expr {!$::tcltest::testConstraints(pc)}] - set ::tcltest::testConstraints(win32sCrash) [expr {!$::tcltest::testConstraints(win32s)}] - set ::tcltest::testConstraints(macCrash) [expr {!$::tcltest::testConstraints(mac)}] - set ::tcltest::testConstraints(unixCrash) [expr {!$::tcltest::testConstraints(unix)}] + set ::tcltest::testConstraints(pcCrash) \ + [expr {!$::tcltest::testConstraints(pc)}] + set ::tcltest::testConstraints(win32sCrash) \ + [expr {!$::tcltest::testConstraints(win32s)}] + set ::tcltest::testConstraints(macCrash) \ + [expr {!$::tcltest::testConstraints(mac)}] + set ::tcltest::testConstraints(unixCrash) \ + [expr {!$::tcltest::testConstraints(unix)}] # Skip empty tests @@ -547,13 +570,10 @@ proc ::tcltest::PrintUsageInfo {} { \t match the glob pattern given. \n\ -notfile pattern\t Skip all test files that match the \n\ \t glob pattern given. \n\ - -relateddir pattern\t Run tests in directories that match \n\ - \t the glob pattern given. \n\ - -asidefromdir pattern\t Skip tests in directories that match \n\ - \t the glob pattern given. \n\ -preservecore level \t If 2, save any core files produced \n\ \t during testing in the directory \n\ - \t specified by -tmpdir. The default \n\ + \t specified by -tmpdir. If 1, notify the\n\ + \t user if core files are created. The default \n\ \t is $::tcltest::preserveCore. \n\ -tmpdir directory\t Save temporary files in the specified\n\ \t directory. The default value is \n\ @@ -634,8 +654,8 @@ proc ::tcltest::processCmdLineArgs {} { # -help is not listed since it has already been processed lappend defaultFlags -verbose -match -skip -constraints \ - -outfile -errfile -debug -tmpdir -file -notfile -relateddir \ - -asidefromdir -preservecore -limitconstraints + -outfile -errfile -debug -tmpdir -file -notfile \ + -preservecore -limitconstraints set defaultFlags [concat $defaultFlags \ [ ::tcltest::processCmdLineArgsAddFlagsHook ]] @@ -674,14 +694,6 @@ proc ::tcltest::processCmdLineArgs {} { set ::tcltest::skipFiles $flag(-notfile) } - # Handle -relateddir and -asidefromdir flags - if {[info exists flag(-relateddir)]} { - set ::tcltest::matchDirectories $flag(-relateddir) - } - if {[info exists flag(-asidefromdir)]} { - set ::tcltest::skipDirectories $flag(-asidefromdir) - } - # 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. @@ -788,29 +800,6 @@ proc ::tcltest::processCmdLineArgs {} { set ::tcltest::preserveCore $flag(-preserveCore) } - # Find the matching directories and then remove the ones that are - # specified in the skip pattern; if no match pattern is specified, use - # the default value specified for ::tcltest::testsDirectory - ignore the - # value of ::tcltest::skipDirectories if the default value is being used. - if {$::tcltest::matchDirectories != {}} { - set matchDir {} - set skipDir {} - if {$::tcltest::skipDirectories != {}} { - set skipDir [glob -nocomplain $::tcltest::skipDirectories] - } - foreach dir [glob -nocomplain $::tcltest::matchDirectories] { - if {[lsearch -exact $skipDir $dir] == -1} { - lappend matchDir $dir - } - } - - # Only reset ::tcltest::testsDirectory if anything actually matched - # after removing the skip patterns. - if {[llength $matchDir] > 0} { - set ::tcltest::testsDirectory $matchDir - } - } - # Call the hook ::tcltest::processCmdLineArgsHook [array get flag] @@ -993,6 +982,44 @@ proc ::tcltest::cleanupTests {{calledFromAllFile 0}} { "env array elements removed:\t$removedEnv" } + set changedTclPlatform {} + foreach index [array names ::tcltest::originalTclPlatform] { + if {$::tcl_platform($index) != \ + $::tcltest::originalTclPlatform($index)} { + lappend changedTclPlatform $index + set ::tcl_platform($index) \ + $::tcltest::originalTclPlatform($index) + } + } + if {[llength $changedTclPlatform] > 0} { + puts $::tcltest::outputChannel \ + "tcl_platform array elements changed:\t$changedTclPlatform" + } + + if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {$::tcltest::preserveCore > 1} { + file rename -force \ + [file join $::tcltest::workingDirectory core] \ + [file join $::tcltest::temporaryDirectory core-$name] + + puts $::tcltest::outputChannel "produced core file! \ + Moved file to: \ + [file join $::tcltest::temporaryDirectory core-$name]" + } else { + # Print a message if there is a core file and (1) there + # previously wasn't one or (2) the new one is different from + # the old one. + + if {[info exists ::tcltest::coreModificationTime]} { + if {$::tcltest::coreModificationTime != [file mtime \ + [file join $::tcltest::workingDirectory core]]} { + puts $::tcltest::outputChannel "A core file was created!" + } + } else { + puts $::tcltest::outputChannel "A core file was created!" + } + } + } } } @@ -1028,12 +1055,11 @@ proc ::tcltest::cleanupTestsHook {} {} # expectedAnswer - Expected result from script. proc ::tcltest::test {name description script expectedAnswer args} { - incr ::tcltest::numTests(Total) + if {($::tcltest::debug) && ($::tcltest::debugLevel > 2)} { + puts "Running $name ($description)" + } -# if {[file exists [file join $::tcltest::workingDirectory core]]} { -# set coreModificationTime [file mtime [file join \ -# $::tcltest::workingDirectory core]] -# } + incr ::tcltest::numTests(Total) # skip the test if it's name matches an element of skip @@ -1065,6 +1091,7 @@ proc ::tcltest::test {name description script expectedAnswer args} { return } } + set i [llength $args] if {$i == 0} { set constraints {} @@ -1122,6 +1149,19 @@ proc ::tcltest::test {name description script expectedAnswer args} { error "wrong # args: must be \"test name description ?constraints? script expectedAnswer\"" } + # Save information about the core file. You need to restore the original + # tcl_platform environment because some of the tests mess with tcl_platform. + + if {$::tcltest::preserveCore} { + set currentTclPlatform [array get tcl_platform] + array set tcl_platform $::tcltest::originalTclPlatform + if {[file exists [file join $::tcltest::workingDirectory core]]} { + set coreModTime [file mtime [file join \ + $::tcltest::workingDirectory core]] + } + array set tcl_platform $currentTclPlatform + } + # If there is no "memory" command (because memory debugging isn't # enabled), then don't attempt to use the command. @@ -1167,28 +1207,34 @@ proc ::tcltest::test {name description script expectedAnswer args} { puts $::tcltest::outputChannel "---- Result should have been:\n$expectedAnswer" puts $::tcltest::outputChannel "==== $name FAILED\n" } -# if {[file exists [file join $::tcltest::workingDirectory core]]} { -# if {$::tcltest::preserveCore} { -# file rename -force [file join $::tcltest::workingDirectory core] \ -# [file join $::tcltest::temporaryDirectory core-$name] - -# puts $::tcltest::outputChannel "==== $name produced core file! \ -# Moved file to: \ -# [file join $::tcltest::temporaryDirectory core-$name]" -# } else { -# # Print a message if there is a core file and (1) there previously -# # wasn't one or (2) the new one is different from the old one. - -# if {[info exists coreModificationTime]} { -# if {$coreModificationTime != [file mtime \ -# [file join $::tcltest::workingDirectory core]]} { -# puts $::tcltest::outputChannel "==== $name produced core file!" -# } -# } else { -# puts $::tcltest::outputChannel "==== $name produced core file!" -# } -# } -# } + if {$::tcltest::preserveCore} { + set currentTclPlatform [array get tcl_platform] + if {[file exists [file join $::tcltest::workingDirectory core]]} { + if {$::tcltest::preserveCore > 1} { + file rename -force \ + [file join $::tcltest::workingDirectory core] \ + [file join $::tcltest::temporaryDirectory core-$name] + + puts $::tcltest::outputChannel "==== $name produced core file! \ + Moved file to: \ + [file join $::tcltest::temporaryDirectory core-$name]" + } else { + # Print a message if there is a core file and (1) there + # previously wasn't one or (2) the new one is different from + # the old one. + + if {[info exists coreModTime]} { + if {$coreModTime != [file mtime \ + [file join $::tcltest::workingDirectory core]]} { + puts $::tcltest::outputChannel "==== $name produced core file!" + } + } else { + puts $::tcltest::outputChannel "==== $name produced core file!" + } + } + } + array set tcl_platform $currentTclPlatform + } } # ::tcltest::getMatchingTestFiles @@ -1238,29 +1284,6 @@ proc ::tcltest::getMatchingFiles {} { return $matchingFiles } -# ::tcltest::dotests -- -# -# takes two arguments--the name of the test file (such -# as "parse.test"), and a pattern selecting the tests you want to -# execute. It sets ::tcltest::match to the second argument, calls -# "source" on the file specified in the first argument, and restores -# ::tcltest::match to its pre-call value at the end. -# -# Arguments: -# file name of tests file to source -# args pattern selecting the tests you want to execute -# -# Results: -# none - -proc ::tcltest::dotests {file args} { - set savedTests $::tcltest::match - set ::tcltest::match $args - source $file - set ::tcltest::match $savedTests -} - - # The following two procs are used in the io tests. proc ::tcltest::openfiles {} { @@ -1362,6 +1385,7 @@ proc ::tcltest::makeFile {contents name} { puts "::tcltest::makeFile: putting $contents into $name" } set fd [open $name w] + fconfigure $fd -translation lf if {[string equal \ -- cgit v0.12