summaryrefslogtreecommitdiffstats
path: root/library/tcltest/tcltest.tcl
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2002-06-05 01:12:37 (GMT)
committerdgp <dgp@users.sourceforge.net>2002-06-05 01:12:37 (GMT)
commit6d6b5b0d0e9c53fadc2e50abbd967d516a317486 (patch)
tree4009db09e77f17f43d7727a947ab98bed252bd18 /library/tcltest/tcltest.tcl
parent297b9f609d66168f3e62c65c6901d0a04a272780 (diff)
downloadtcl-6d6b5b0d0e9c53fadc2e50abbd967d516a317486.zip
tcl-6d6b5b0d0e9c53fadc2e50abbd967d516a317486.tar.gz
tcl-6d6b5b0d0e9c53fadc2e50abbd967d516a317486.tar.bz2
* Added more TIP 85 tests from Arjen Markus.
Converted tcltest.test to use a private namespace. Fixed bugs in [tcltest::Eval] revealed by calling [tcltest::test] from a non-global namespace, and namespace errors in init.test.
Diffstat (limited to 'library/tcltest/tcltest.tcl')
-rw-r--r--library/tcltest/tcltest.tcl40
1 files changed, 29 insertions, 11 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 5bc73a3..edda144 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -15,7 +15,7 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.51 2002/06/03 23:44:32 dgp Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.52 2002/06/05 01:12:38 dgp Exp $
# create the "tcltest" namespace for all testing variables and
# procedures
@@ -317,6 +317,13 @@ proc tcltest::DebugPArray {level arrayvar} {
return
}
+# Define our own [parray] in ::tcltest that will inherit use of the [puts]
+# defined in ::tcltest. NOTE: Ought to construct with [info args] and
+# [info default], but can't be bothered now. If [parray] changes, then
+# this will need changing too.
+auto_load ::parray
+proc tcltest::parray {a {pattern *}} [info body ::parray]
+
# tcltest::DebugDo --
#
# Executes the script if the current debug level is greater than
@@ -1592,10 +1599,10 @@ proc tcltest::Replace::puts {args} {
}
if {[info exists channel]} {
- if {[string equal $channel [outputChannel]]
+ if {[string equal $channel [[namespace parent]::outputChannel]]
|| [string equal $channel stdout]} {
append outData [lindex $args end]\n
- } elseif {[string equal $channel [errorChannel]]
+ } elseif {[string equal $channel [[namespace parent]::errorChannel]]
|| [string equal $channel stderr]} {
append errData [lindex $args end]\n
}
@@ -1633,15 +1640,26 @@ proc tcltest::Eval {script {ignoreOutput 1}} {
if {!$ignoreOutput} {
set outData {}
set errData {}
- # If caller has its own [puts], this may disable it.
- uplevel 1 [list ::rename puts [namespace current]::Puts]
- uplevel 1 [list ::namespace import \
- [namespace origin Replace::puts]]
+ set callerHasPuts [llength [uplevel 1 {
+ ::info commands [::namespace current]::puts
+ }]]
+ if {$callerHasPuts} {
+ uplevel 1 [list ::rename puts [namespace current]::Replace::Puts]
+ } else {
+ interp alias {} [namespace current]::Replace::Puts {} ::puts
+ }
+ uplevel 1 [list ::namespace import [namespace origin Replace::puts]]
+ namespace import Replace::puts
}
set result [uplevel 1 $script]
if {!$ignoreOutput} {
+ namespace forget puts
uplevel 1 ::namespace forget puts
- uplevel 1 [list ::rename [namespace current]::Puts puts]
+ if {$callerHasPuts} {
+ uplevel 1 [list ::rename [namespace current]::Replace::Puts puts]
+ } else {
+ interp alias {} [namespace current]::Replace::Puts {}
+ }
}
return $result
}
@@ -3302,9 +3320,9 @@ namespace eval tcltest {
}
# Define the standard match commands
- customMatch exact [list ::string equal]
- customMatch glob [list ::string match]
- customMatch regexp [list ::regexp --]
+ customMatch exact [list string equal]
+ customMatch glob [list string match]
+ customMatch regexp [list regexp --]
unset file
}