From eee25bb571c43b9d4ff16fc5d60ccc66a3e81454 Mon Sep 17 00:00:00 2001 From: jenn Date: Wed, 28 Jul 1999 18:33:18 +0000 Subject: * tests/tcltest.test: * library/tcltest1.0/tcltest.tcl: Fixed the condition under which ::tcltest::PrintError had an infinite loop problem and added a test case for it. Added an optional argument to ::tcltest::getMatchingFiles telling it where to search for test files. --- ChangeLog | 9 +++++++++ library/tcltest/tcltest.tcl | 30 ++++++++++++++++-------------- library/tcltest1.0/tcltest.tcl | 30 ++++++++++++++++-------------- tests/tcltest.test | 7 ++++--- 4 files changed, 45 insertions(+), 31 deletions(-) diff --git a/ChangeLog b/ChangeLog index ad5f04d..0b8f05d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +1999-07-28 Jennifer Hom + + * tests/tcltest.test: + * library/tcltest1.0/tcltest.tcl: Fixed the condition under which + ::tcltest::PrintError had an infinite loop problem and added a + test case for it. Added an optional argument to + ::tcltest::getMatchingFiles telling it where to search for test + files. + 1999-07-27 * tools/tclSplash.bmp: Updated Windows installer bitmap diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index 3974335..8031015 100644 --- a/library/tcltest/tcltest.tcl +++ b/library/tcltest/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.7 1999/07/26 22:50:55 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.8 1999/07/28 18:33:20 jenn Exp $ package provide tcltest 1.0 @@ -232,9 +232,7 @@ proc ::tcltest::PrintError {errorMsg} { set InitialMsgLen [string length $InitialMessage] puts -nonewline $::tcltest::errorChannel $InitialMessage - # Keep track of where we last started from and where the end of the - # string is. - set priorBeginningIndex 0 + # Keep track of where the end of the string is. set endingIndex [string length $errorMsg] if {$endingIndex < 80} { @@ -243,7 +241,7 @@ proc ::tcltest::PrintError {errorMsg} { # Print up to 80 characters on the first line, including the # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ - [string wordend $errorMsg [expr {80 - $InitialMsgLen}]]]] + [expr {80 - $InitialMsgLen}]]] puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] while {$beginningIndex != "end"} { @@ -254,18 +252,17 @@ proc ::tcltest::PrintError {errorMsg} { [string range $errorMsg $beginningIndex end]] set beginningIndex end } else { - set newEndingIndex [string last " " [string range $errorMsg \ - $beginningIndex [string wordend $errorMsg \ - [expr {$beginningIndex + 72}]]]] + set newEndingIndex [expr [string last " " [string range \ + $errorMsg $beginningIndex \ + [expr {$beginningIndex + 72}]]] + $beginningIndex] if {($newEndingIndex <= 0) \ - || ($newEndingIndex == $beginningIndex)} { + || ($newEndingIndex <= $beginningIndex)} { set newEndingIndex end } puts $::tcltest::errorChannel [string trim \ [string range $errorMsg \ $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex - set priorBeginningIndex $beginningIndex } } } @@ -1266,7 +1263,7 @@ proc ::tcltest::test {name description script expectedAnswer args} { # ::tcltest::getMatchingTestFiles # -# Looks at the patterns given to match and skip directories and files +# Looks at the patterns given to match and skip files # and uses them to put together a list of the tests that will be run. # # Arguments: @@ -1276,17 +1273,22 @@ proc ::tcltest::test {name description script expectedAnswer args} { # The constructed list is returned to the user. This will primarily # be used in 'all.tcl' files. -proc ::tcltest::getMatchingFiles {} { +proc ::tcltest::getMatchingFiles {args} { set matchingFiles {} + if {[llength $args] > 0} { + set searchDirectory $args + } else { + set searchDirectory $::tcltest::testsDirectory + } # Find the matching files in the list of directories and then remove the # ones that match the skip pattern - foreach directory $::tcltest::testsDirectory { + foreach directory $searchDirectory { set matchFileList {} foreach match $::tcltest::matchFiles { set matchFileList [concat $matchFileList \ [glob -nocomplain [file join $directory $match]]] } - if {$tcltest::skipFiles != {}} { + if {$::tcltest::skipFiles != {}} { set skipFileList {} foreach skip $::tcltest::skipFiles { set skipFileList [concat $skipFileList \ diff --git a/library/tcltest1.0/tcltest.tcl b/library/tcltest1.0/tcltest.tcl index 3974335..8031015 100644 --- a/library/tcltest1.0/tcltest.tcl +++ b/library/tcltest1.0/tcltest.tcl @@ -12,7 +12,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.tcl,v 1.7 1999/07/26 22:50:55 jenn Exp $ +# RCS: @(#) $Id: tcltest.tcl,v 1.8 1999/07/28 18:33:20 jenn Exp $ package provide tcltest 1.0 @@ -232,9 +232,7 @@ proc ::tcltest::PrintError {errorMsg} { set InitialMsgLen [string length $InitialMessage] puts -nonewline $::tcltest::errorChannel $InitialMessage - # Keep track of where we last started from and where the end of the - # string is. - set priorBeginningIndex 0 + # Keep track of where the end of the string is. set endingIndex [string length $errorMsg] if {$endingIndex < 80} { @@ -243,7 +241,7 @@ proc ::tcltest::PrintError {errorMsg} { # Print up to 80 characters on the first line, including the # InitialMessage. set beginningIndex [string last " " [string range $errorMsg 0 \ - [string wordend $errorMsg [expr {80 - $InitialMsgLen}]]]] + [expr {80 - $InitialMsgLen}]]] puts $::tcltest::errorChannel [string range $errorMsg 0 $beginningIndex] while {$beginningIndex != "end"} { @@ -254,18 +252,17 @@ proc ::tcltest::PrintError {errorMsg} { [string range $errorMsg $beginningIndex end]] set beginningIndex end } else { - set newEndingIndex [string last " " [string range $errorMsg \ - $beginningIndex [string wordend $errorMsg \ - [expr {$beginningIndex + 72}]]]] + set newEndingIndex [expr [string last " " [string range \ + $errorMsg $beginningIndex \ + [expr {$beginningIndex + 72}]]] + $beginningIndex] if {($newEndingIndex <= 0) \ - || ($newEndingIndex == $beginningIndex)} { + || ($newEndingIndex <= $beginningIndex)} { set newEndingIndex end } puts $::tcltest::errorChannel [string trim \ [string range $errorMsg \ $beginningIndex $newEndingIndex]] set beginningIndex $newEndingIndex - set priorBeginningIndex $beginningIndex } } } @@ -1266,7 +1263,7 @@ proc ::tcltest::test {name description script expectedAnswer args} { # ::tcltest::getMatchingTestFiles # -# Looks at the patterns given to match and skip directories and files +# Looks at the patterns given to match and skip files # and uses them to put together a list of the tests that will be run. # # Arguments: @@ -1276,17 +1273,22 @@ proc ::tcltest::test {name description script expectedAnswer args} { # The constructed list is returned to the user. This will primarily # be used in 'all.tcl' files. -proc ::tcltest::getMatchingFiles {} { +proc ::tcltest::getMatchingFiles {args} { set matchingFiles {} + if {[llength $args] > 0} { + set searchDirectory $args + } else { + set searchDirectory $::tcltest::testsDirectory + } # Find the matching files in the list of directories and then remove the # ones that match the skip pattern - foreach directory $::tcltest::testsDirectory { + foreach directory $searchDirectory { set matchFileList {} foreach match $::tcltest::matchFiles { set matchFileList [concat $matchFileList \ [glob -nocomplain [file join $directory $match]]] } - if {$tcltest::skipFiles != {}} { + if {$::tcltest::skipFiles != {}} { set skipFileList {} foreach skip $::tcltest::skipFiles { set skipFileList [concat $skipFileList \ diff --git a/tests/tcltest.test b/tests/tcltest.test index 6229d46..2c43514 100755 --- a/tests/tcltest.test +++ b/tests/tcltest.test @@ -10,7 +10,7 @@ # Copyright (c) 1998-1999 by Scriptics Corporation. # All rights reserved. # -# RCS: @(#) $Id: tcltest.test,v 1.2 1999/07/27 01:42:23 redman Exp $ +# RCS: @(#) $Id: tcltest.test,v 1.3 1999/07/28 18:33:23 jenn Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -156,6 +156,7 @@ makeFile { \"Path/that/is/really/long/and/contains/no/spaces\"" ::tcltest::PrintError "a really really long string containing a \ \"Really/Long/Path/that/contains/no/spaces/and/is/longer/than/eighty/characters/to/see/what/happens\"" + ::tcltest::PrintError "Problem renaming file: error renaming \"Z:/ws/tcl8.2/win32-ix86/tests/core\" to \"Z:/ws/tcl8.2/win32-ix86/tests/movecore-core\"" } printerror.tcl # -outfile, -errfile @@ -289,8 +290,8 @@ test tcltest-11.1 {PrintError} { set result [catch {exec $::tcltest::tcltest printerror.tcl} msg] list $result [regexp "Error: a really short string" $msg] \ [regexp " \"quotes\"" $msg] [regexp " \"Path" $msg] \ - [regexp " \"Really" $msg] -} {1 1 1 1 1} + [regexp " \"Really" $msg] [regexp Problem $msg] +} {1 1 1 1 1 1} # cleanup ::tcltest::cleanupTests -- cgit v0.12