* 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.


FossilOrigin-Name: a956513b642afa1d81f0b7bd56aed38d1f007fca

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  <jenn@scriptics.com>
+
+	* 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    <redman@scriptics.com>
 
 	* 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