summaryrefslogtreecommitdiffstats
path: root/tests/namespace.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/namespace.test')
-rw-r--r--tests/namespace.test902
1 files changed, 750 insertions, 152 deletions
diff --git a/tests/namespace.test b/tests/namespace.test
index 947beb6..fab0040 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -1,25 +1,37 @@
# Functionality covered: this file contains a collection of tests for the
-# procedures in tclNamesp.c that implement Tcl's basic support for
-# namespaces. Other namespace-related tests appear in variable.test.
+# procedures in tclNamesp.c and tclEnsemble.c that implement Tcl's basic
+# support for namespaces. Other namespace-related tests appear in
+# variable.test.
#
-# Sourcing this file into Tcl runs the tests and generates output for
-# errors. No output means no errors were found.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
# Copyright (c) 1998-2000 by Scriptics Corporation.
#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# RCS: @(#) $Id: namespace.test,v 1.46 2005/07/05 17:33:07 dgp Exp $
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest 2
- namespace import -force ::tcltest::*
-}
+package require tcltest 2
+namespace import -force ::tcltest::*
+testConstraint memory [llength [info commands memory]]
+
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
+#
+# REMARK: the tests for 'namespace upvar' are not done here. They are to be
+# found in the file 'upvar.test'.
+#
# Clear out any namespaces called test_ns_*
-catch {namespace delete {expand}[namespace children :: test_ns_*]}
+catch {namespace delete {*}[namespace children :: test_ns_*]}
+
+proc fq {ns} {
+ if {[string match ::* $ns]} {return $ns}
+ set current [uplevel 1 {namespace current}]
+ return [string trimright $current :]::[string trimleft $ns :]
+}
test namespace-1.1 {TclInitNamespaces, GetNamespaceFromObj, NamespaceChildrenCmd} {
namespace children :: test_ns_*
@@ -40,7 +52,6 @@ test namespace-2.2 {Tcl_GetCurrentNamespace} {
}
}
lappend l [namespace current]
- set l
} {:: ::test_ns_1 ::test_ns_1::foo ::}
test namespace-3.1 {Tcl_GetGlobalNamespace} {
@@ -79,7 +90,7 @@ test namespace-5.2 {Tcl_PopCallFrame, local vars must be deleted} {
} {123}
test namespace-6.1 {Tcl_CreateNamespace} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [lsort [namespace children :: test_ns_*]] \
[namespace eval test_ns_1 {namespace current}] \
[namespace eval test_ns_2 {namespace current}] \
@@ -98,7 +109,7 @@ test namespace-6.3 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
list [catch {namespace eval test_ns_7::: {namespace current}} msg] $msg
} {0 ::test_ns_7}
test namespace-6.4 {Tcl_CreateNamespace, trailing ::s in ns name are ignored} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1:: {
namespace eval test_ns_2:: {}
namespace eval test_ns_3:: {}
@@ -116,7 +127,7 @@ test namespace-6.5 {Tcl_CreateNamespace, relative ns names now only looked up in
} {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_2}
test namespace-7.1 {Tcl_DeleteNamespace, active call frames in ns} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
@@ -133,6 +144,56 @@ test namespace-7.2 {Tcl_DeleteNamespace, no active call frames in ns} {
}
list [test_ns_2::p] [namespace delete test_ns_2]
} {::test_ns_2 {}}
+test namespace-7.3 {recursive Tcl_DeleteNamespace, active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ set x 1
+ trace add variable x unset "namespace delete [namespace current];#"
+ namespace delete [namespace current]
+ }
+} {}
+test namespace-7.4 {recursive Tcl_DeleteNamespace, active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ proc x {} {}
+ trace add command x delete "namespace delete [namespace current];#"
+ namespace delete [namespace current]
+ }
+} {}
+test namespace-7.5 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ set x 1
+ trace add variable x unset "namespace delete [namespace current];#"
+ }
+ namespace delete test_ns_2
+} {}
+test namespace-7.6 {recursive Tcl_DeleteNamespace, no active call frames in ns} {
+ # [Bug 1355942]
+ namespace eval test_ns_2 {
+ proc x {} {}
+ trace add command x delete "namespace delete [namespace current];#"
+ }
+ namespace delete test_ns_2
+} {}
+test namespace-7.7 {Bug 1655305} -setup {
+ interp create slave
+ # Can't invoke through the ensemble, since deleting the global namespace
+ # (indirectly, via deleting ::tcl) deletes the ensemble.
+ slave eval {rename ::tcl::info::commands ::infocommands}
+ slave hide infocommands
+ slave eval {
+ proc foo {} {
+ namespace delete ::
+ }
+ }
+} -body {
+ slave eval foo
+ slave invokehidden infocommands
+} -cleanup {
+ interp delete slave
+} -result {}
+
test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
catch {interp delete test_interp}
@@ -161,7 +222,7 @@ test namespace-8.1 {TclTeardownNamespace, delete global namespace} {
[interp delete test_interp]
} {{::test_ns_1 27} {} 1 {invalid command name "set"} {}}
test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}}
namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}}
list [namespace children test_ns_1] \
@@ -169,7 +230,7 @@ test namespace-8.2 {TclTeardownNamespace, remove deleted ns from parent} {
[namespace children test_ns_1]
} {::test_ns_1::test_ns_2 {} {}}
test namespace-8.3 {TclTeardownNamespace, delete child namespaces} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2::test_ns_3a {proc p {} {}}
namespace eval test_ns_1::test_ns_2::test_ns_3b {proc q {} {}}
list [namespace children test_ns_1] \
@@ -177,9 +238,9 @@ test namespace-8.3 {TclTeardownNamespace, delete child namespaces} {
[namespace children test_ns_1] \
[catch {namespace children test_ns_1::test_ns_2} msg] $msg \
[info commands test_ns_1::test_ns_2::test_ns_3a::*]
-} {::test_ns_1::test_ns_2 {} {} 1 {unknown namespace "test_ns_1::test_ns_2" in namespace children command} {}}
+} {::test_ns_1::test_ns_2 {} {} 1 {namespace "test_ns_1::test_ns_2" not found in "::"} {}}
test namespace-8.4 {TclTeardownNamespace, cmds imported from deleted ns go away} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1 cmd2
proc cmd1 {args} {return "cmd1: $args"}
@@ -220,7 +281,7 @@ test namespace-8.7 {TclTeardownNamespace: preserve errorInfo; errorCode values}
} baz
test namespace-9.1 {Tcl_Import, empty import pattern} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_import {namespace import {}}} msg] $msg
} {1 {empty import pattern}}
test namespace-9.2 {Tcl_Import, unknown namespace in import pattern} {
@@ -230,7 +291,7 @@ test namespace-9.3 {Tcl_Import, import ns == export ns} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_import::puts}} msg] $msg
} {1 {import pattern "::test_ns_import::puts" tries to import from namespace "test_ns_import" into itself}}
test namespace-9.4 {Tcl_Import, simple import} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
@@ -242,7 +303,7 @@ test namespace-9.4 {Tcl_Import, simple import} {
}
test_ns_import::p
} {cmd1: 123}
-test namespace-9.5 {Tcl_Import, can't redefine cmd unless allowOverwrite!=0} {
+test namespace-9.5 {Tcl_Import, RFE 1230597} {
list [catch {namespace eval test_ns_import {namespace import ::test_ns_export::*}} msg] $msg
} {0 {}}
test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
@@ -252,7 +313,7 @@ test namespace-9.6 {Tcl_Import, cmd redefinition ok if allowOverwrite!=0} {
}
} {cmd1: 555}
test namespace-9.7 {Tcl_Import, links are preserved if cmd is redefined} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
@@ -314,7 +375,7 @@ test namespace-9.9 {Tcl_Import: Bug 1017299} -setup {
} -returnCodes error -match glob -result {import pattern * would create a loop*}
test namespace-10.1 {Tcl_ForgetImport, check for valid namespaces} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace forget xyzzy::*} msg] $msg
} {1 {unknown namespace in namespace forget pattern "xyzzy::*"}}
test namespace-10.2 {Tcl_ForgetImport, ignores patterns that don't match} {
@@ -454,7 +515,7 @@ test namespace-10.9 {Tcl_ForgetImport: Bug 560297} -setup {
} -returnCodes error -match glob -result *
test namespace-11.1 {TclGetOriginalCommand, check if not imported cmd} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
@@ -478,7 +539,7 @@ test namespace-11.3 {TclGetOriginalCommand, indirectly imported cmd} {
} {{cmd1: 123} ::test_ns_export::cmd1}
test namespace-12.1 {InvokeImportedCmd} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_export {
namespace export cmd1
proc cmd1 {args} {namespace current}
@@ -497,9 +558,18 @@ test namespace-13.1 {DeleteImportedCmd, deletes imported cmds} {
lappend l [info commands ::test_ns_import::*]
}
} {::test_ns_import::cmd1 {}}
+test namespace-13.2 {DeleteImportedCmd, Bug a4494e28ed} {
+ # Will panic if still buggy
+ namespace eval src {namespace export foo; proc foo {} {}}
+ namespace eval dst {namespace import [namespace parent]::src::foo}
+ trace add command src::foo delete \
+ "[list namespace delete [namespace current]::dst] ;#"
+ proc src::foo {} {}
+ namespace delete src
+} {}
test namespace-14.1 {TclGetNamespaceForQualName, absolute names} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
variable v 10
namespace eval test_ns_1::test_ns_2 {
variable v 20
@@ -517,7 +587,7 @@ test namespace-14.2 {TclGetNamespaceForQualName, invalid absolute names} {
list [catch {set ::test_ns_777::v} msg] $msg \
[catch {namespace children test_ns_777} msg] $msg
}
-} {1 {can't read "::test_ns_777::v": no such variable} 1 {unknown namespace "test_ns_777" in namespace children command}}
+} {1 {can't read "::test_ns_777::v": no such variable} 1 {namespace "test_ns_777" not found in "::test_ns_1"}}
test namespace-14.3 {TclGetNamespaceForQualName, relative names} {
namespace eval test_ns_1 {
list $v $test_ns_2::v
@@ -531,15 +601,14 @@ test namespace-14.4 {TclGetNamespaceForQualName, relative ns names looked up onl
list [namespace children test_ns_2] \
[catch {namespace children test_ns_1} msg] $msg
}
-} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}}
+} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}}
test namespace-14.5 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval ::test_ns_2 {
namespace eval bar {}
}
namespace eval test_ns_1 {
- set l [list [catch {namespace delete test_ns_2::bar} msg] $msg]
+ list [catch {namespace delete test_ns_2::bar} msg] $msg
}
- set l
} {1 {unknown namespace "test_ns_2::bar" in namespace delete command}}
test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up only in current ns} {
namespace eval test_ns_1::test_ns_2 {
@@ -549,7 +618,7 @@ test namespace-14.6 {TclGetNamespaceForQualName, relative ns names looked up onl
list [namespace children test_ns_2] \
[catch {namespace children test_ns_1} msg] $msg
}
-} {::test_ns_1::test_ns_2::foo 1 {unknown namespace "test_ns_1" in namespace children command}}
+} {::test_ns_1::test_ns_2::foo 1 {namespace "test_ns_1" not found in "::test_ns_1"}}
test namespace-14.7 {TclGetNamespaceForQualName, ignore extra :s if ns} {
namespace children test_ns_1:::
} {::test_ns_1::test_ns_2}
@@ -577,7 +646,7 @@ test namespace-14.11 {TclGetNamespaceForQualName, extra ::s are significant for
lappend l [test_ns_1::test_ns_2:: hello]
} {1 {invalid command name "test_ns_1::test_ns_2::"} {{}: hello}}
test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for vars} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
variable {}
set test_ns_1::(x) y
@@ -585,12 +654,12 @@ test namespace-14.12 {TclGetNamespaceForQualName, extra ::s are significant for
set test_ns_1::(x)
} y
test namespace-14.13 {TclGetNamespaceForQualName, namespace other than global ns can't have empty name} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace eval test_ns_1 {proc {} {} {}; namespace eval {} {}; {}}} msg] $msg
} {1 {can't create namespace "": only global namespace can have empty name}}
test namespace-15.1 {Tcl_FindNamespace, absolute name found} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_delete {
namespace eval test_ns_delete2 {}
proc cmd {args} {namespace current}
@@ -617,7 +686,7 @@ test namespace-15.4 {Tcl_FindNamespace, relative name not found} {
} {1 {unknown namespace "test_ns_delete2" in namespace delete command}}
test namespace-16.1 {Tcl_FindCommand, absolute name found} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc cmd {args} {return "[namespace current]::cmd: $args"}
variable v "::test_ns_1::cmd"
@@ -660,14 +729,16 @@ test namespace-16.8 {Tcl_FindCommand, relative name found} {
cmd a b c
}
} {::test_ns_1::cmd: a b c}
-test namespace-16.9 {Tcl_FindCommand, relative name found} {
- catch {rename cmd2 {}}
+test namespace-16.9 {Tcl_FindCommand, relative name found} -body {
proc cmd2 {args} {return "[namespace current]::cmd2: $args"}
namespace eval test_ns_1 {
cmd2 a b c
}
-} {::::cmd2: a b c}
-test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} {
+} -cleanup {
+ catch {rename cmd2 {}}
+} -result {::::cmd2: a b c}
+test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current then global ns} -body {
+ proc cmd2 {args} {return "[namespace current]::cmd2: $args"}
namespace eval test_ns_1 {
proc cmd2 {args} {
return "[namespace current]::cmd2 in test_ns_1: $args"
@@ -676,7 +747,9 @@ test namespace-16.10 {Tcl_FindCommand, relative name found, only look in current
cmd2 a b c
}
}
-} {::::cmd2: a b c}
+} -cleanup {
+ catch {rename cmd2 {}}
+} -result {::::cmd2: a b c}
test namespace-16.11 {Tcl_FindCommand, relative name not found} {
namespace eval test_ns_1 {
list [catch {cmd3 a b c} msg] $msg
@@ -685,7 +758,7 @@ test namespace-16.11 {Tcl_FindCommand, relative name not found} {
catch {unset x}
test namespace-17.1 {Tcl_FindNamespaceVar, absolute name found} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
set x 314159
namespace eval test_ns_1 {
set ::x
@@ -754,7 +827,7 @@ test namespace-17.10 {Tcl_FindNamespaceVar, interference with cached varNames} {
set a 0
namespace eval test_ns_1 set a 1
namespace delete test_ns_1
- set a
+ return $a
} 1
catch {unset a}
catch {unset x}
@@ -762,7 +835,7 @@ catch {unset x}
catch {unset l}
catch {rename foo {}}
test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
proc foo {} {return "global foo"}
namespace eval test_ns_1 {
proc trigger {} {
@@ -776,7 +849,6 @@ test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadow
proc foo {} {return "foo in test_ns_1"}
}
lappend l [test_ns_1::trigger]
- set l
} {{global foo} {foo in test_ns_1}}
test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shadowing} {
namespace eval test_ns_2 {
@@ -797,13 +869,12 @@ test namespace-18.2 {TclResetShadowedCmdRefs, multilevel check for command shado
}
}
lappend l [test_ns_1::trigger]
- set l
} {{foo in ::test_ns_2} {foo in ::test_ns_1::test_ns_2}}
catch {unset l}
catch {rename foo {}}
test namespace-19.1 {GetNamespaceFromObj, global name found} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
namespace children ::test_ns_1
} {::test_ns_1::test_ns_2}
@@ -812,11 +883,11 @@ test namespace-19.2 {GetNamespaceFromObj, relative name found} {
namespace children test_ns_2
}
} {}
-test namespace-19.3 {GetNamespaceFromObj, name not found} {
+test namespace-19.3 {GetNamespaceFromObj, name not found} -body {
namespace eval test_ns_1 {
- list [catch {namespace children test_ns_99} msg] $msg
+ namespace children test_ns_99
}
-} {1 {unknown namespace "test_ns_99" in namespace children command}}
+} -returnCodes error -result {namespace "test_ns_99" not found in "::test_ns_1"}
test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} {
namespace eval test_ns_1 {
proc foo {} {
@@ -829,22 +900,21 @@ test namespace-19.4 {GetNamespaceFromObj, invalidation of cached ns refs} {
namespace delete test_ns_1::test_ns_2
namespace eval test_ns_1::test_ns_2::test_ns_3 {}
lappend l [test_ns_1::foo]
- set l
} {{} ::test_ns_1::test_ns_2::test_ns_3}
test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace} msg] $msg
} {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
-test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} {
- list [catch {namespace wombat {}} msg] $msg
-} {1 {bad option "wombat": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}}
+test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} -body {
+ namespace wombat {}
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "wombat": must be *}
test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
namespace ch :: test_ns_*
} {}
test namespace-21.1 {NamespaceChildrenCmd, no args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
expr {[string first ::test_ns_1 [namespace children]] != -1}
} {1}
@@ -874,9 +944,13 @@ test namespace-21.7 {NamespaceChildrenCmd, glob-style pattern given} {
namespace eval test_ns_1::test_ns_foo {}
lsort [namespace children test_ns_1 test*]
} [lsort {::test_ns_1::test_ns_2 ::test_ns_1::test_ns_foo}]
+test namespace-21.8 {NamespaceChildrenCmd, trivial pattern starting with ::} {
+ namespace eval test_ns_1 {}
+ namespace children [namespace current] [fq test_ns_1]
+} [fq test_ns_1]
test namespace-22.1 {NamespaceCodeCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace code} msg] $msg \
[catch {namespace code xxx yyy} msg] $msg
} {1 {wrong # args: should be "namespace code arg"} 1 {wrong # args: should be "namespace code arg"}}
@@ -884,11 +958,11 @@ test namespace-22.2 {NamespaceCodeCmd, arg is already scoped value} {
namespace eval test_ns_1 {
proc cmd {} {return "test_ns_1::cmd"}
}
- namespace code {namespace inscope ::test_ns_1 cmd}
-} {namespace inscope ::test_ns_1 cmd}
+ namespace code {::namespace inscope ::test_ns_1 cmd}
+} {::namespace inscope ::test_ns_1 cmd}
test namespace-22.3 {NamespaceCodeCmd, arg is already scoped value} {
namespace code {namespace inscope ::test_ns_1 cmd}
-} {namespace inscope ::test_ns_1 cmd}
+} {::namespace inscope :: {namespace inscope ::test_ns_1 cmd}}
test namespace-22.4 {NamespaceCodeCmd, in :: namespace} {
namespace code unknown
} {::namespace inscope :: unknown}
@@ -908,9 +982,15 @@ test namespace-22.6 {NamespaceCodeCmd, in other namespace} {
namespace code {set v}
}]
} {42}
+test namespace-22.7 {NamespaceCodeCmd, Bug 3202171} {
+ namespace eval demo {
+ proc namespace args {puts $args}
+ ::namespace code {namespace inscope foo}
+ }
+} [list ::namespace inscope [fq demo] {namespace inscope foo}]
test namespace-23.1 {NamespaceCurrentCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace current xxx} msg] $msg \
[catch {namespace current xxx yyy} msg] $msg
} {1 {wrong # args: should be "namespace current"} 1 {wrong # args: should be "namespace current"}}
@@ -924,7 +1004,7 @@ test namespace-23.3 {NamespaceCurrentCmd, in nested ns} {
} {::test_ns_1::test_ns_2}
test namespace-24.1 {NamespaceDeleteCmd, no args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace delete
} {}
test namespace-24.2 {NamespaceDeleteCmd, one arg} {
@@ -940,12 +1020,12 @@ test namespace-24.4 {NamespaceDeleteCmd, unknown ns} {
} {1 {unknown namespace "::test_ns_foo" in namespace delete command}}
test namespace-25.1 {NamespaceEvalCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace eval} msg] $msg
} {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
-test namespace-25.2 {NamespaceEvalCmd, bad args} {
- list [catch {namespace test_ns_1} msg] $msg
-} {1 {bad option "test_ns_1": must be children, code, current, delete, ensemble, eval, exists, export, forget, import, inscope, origin, parent, path, qualifiers, tail, or which}}
+test namespace-25.2 {NamespaceEvalCmd, bad args} -body {
+ namespace test_ns_1
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *}
catch {unset v}
test namespace-25.3 {NamespaceEvalCmd, new namespace} {
set v 123
@@ -968,7 +1048,7 @@ test namespace-25.5 {NamespaceEvalCmd, multiple args} {
namespace eval test_ns_1 "set" "v"
} {314159}
test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} {
- list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $errorInfo
+ list [catch {namespace eval test_ns_1 {xxxx}} msg] $msg $::errorInfo
} {1 {invalid command name "xxxx"} {invalid command name "xxxx"
while executing
"xxxx"
@@ -976,21 +1056,24 @@ test namespace-25.6 {NamespaceEvalCmd, error in eval'd script} {
invoked from within
"namespace eval test_ns_1 {xxxx}"}}
test namespace-25.7 {NamespaceEvalCmd, error in eval'd script} {
- list [catch {namespace eval test_ns_1 {error foo bar baz}} msg] $msg $errorInfo
+ list [catch {namespace eval test_ns_1 {error foo bar baz}} msg] $msg $::errorInfo
} {1 foo {bar
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 {error foo bar baz}"}}
test namespace-25.8 {NamespaceEvalCmd, error in eval'd script} {
- list [catch {namespace eval test_ns_1 error foo bar baz} msg] $msg $errorInfo
+ list [catch {namespace eval test_ns_1 error foo bar baz} msg] $msg $::errorInfo
} {1 foo {bar
(in namespace eval "::test_ns_1" script line 1)
invoked from within
"namespace eval test_ns_1 error foo bar baz"}}
catch {unset v}
+test namespace-25.9 {NamespaceEvalCmd, 545325} {
+ namespace eval test_ns_1 info level 0
+} {namespace eval test_ns_1 info level 0}
test namespace-26.1 {NamespaceExportCmd, no args and new ns} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace export
} {}
test namespace-26.2 {NamespaceExportCmd, just -clear arg} {
@@ -1037,9 +1120,17 @@ test namespace-26.7 {NamespaceExportCmd, -clear resets export list} {
}
list [lsort [info commands test_ns_2::*]] [test_ns_2::cmd4 hello]
} [list [lsort {::test_ns_2::cmd4 ::test_ns_2::cmd1 ::test_ns_2::cmd3}] {cmd4: hello}]
+test namespace-26.8 {NamespaceExportCmd, -clear resets export list} {
+ catch {namespace delete foo}
+ namespace eval foo {
+ namespace export x
+ namespace export -clear
+ }
+ list [namespace eval foo namespace export] [namespace delete foo]
+} {{} {}}
test namespace-27.1 {NamespaceForgetCmd, no args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace forget
} {}
test namespace-27.2 {NamespaceForgetCmd, args must be valid namespaces} {
@@ -1058,10 +1149,23 @@ test namespace-27.3 {NamespaceForgetCmd, arg is forgotten} {
info commands ::test_ns_2::*
} {::test_ns_2::cmd2}
-test namespace-28.1 {NamespaceImportCmd, no args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
- namespace import
-} {}
+test namespace-28.1 {NamespaceImportCmd, no args} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -body {
+ namespace eval ::test_ns_1 {
+ proc foo {} {}
+ proc bar {} {}
+ proc boo {} {}
+ proc glorp {} {}
+ namespace export foo b*
+ }
+ namespace eval ::test_ns_2 {
+ namespace import ::test_ns_1::*
+ lsort [namespace import]
+ }
+} -cleanup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+} -result {bar boo foo}
test namespace-28.2 {NamespaceImportCmd, no args and just "-force"} {
namespace import -force
} {}
@@ -1079,15 +1183,15 @@ test namespace-28.3 {NamespaceImportCmd, arg is imported} {
} {::test_ns_2::cmd2}
test namespace-29.1 {NamespaceInscopeCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace inscope} msg] $msg
} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
test namespace-29.2 {NamespaceInscopeCmd, bad args} {
list [catch {namespace inscope ::} msg] $msg
} {1 {wrong # args: should be "namespace inscope name arg ?arg...?"}}
-test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} {
- list [catch {namespace inscope test_ns_1 {set v}} msg] $msg
-} {1 {unknown namespace "test_ns_1" in inscope namespace command}}
+test namespace-29.3 {NamespaceInscopeCmd, specified ns must exist} -body {
+ namespace inscope test_ns_1 {set v}
+} -returnCodes error -result {namespace "test_ns_1" not found in "::"}
test namespace-29.4 {NamespaceInscopeCmd, simple case} {
namespace eval test_ns_1 {
variable v 747
@@ -1102,9 +1206,13 @@ test namespace-29.5 {NamespaceInscopeCmd, has lappend semantics} {
list [namespace inscope test_ns_1 cmd x y z] \
[namespace eval test_ns_1 [concat cmd [list x y z]]]
} {{::test_ns_1::cmd: v=747, args=x y z} {::test_ns_1::cmd: v=747, args=x y z}}
+test namespace-29.6 {NamespaceInscopeCmd, 1400572} {
+ namespace inscope test_ns_1 {info level 0}
+} {namespace inscope test_ns_1 {info level 0}}
+
test namespace-30.1 {NamespaceOriginCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace origin} msg] $msg
} {1 {wrong # args: should be "namespace origin name"}}
test namespace-30.2 {NamespaceOriginCmd, bad args} {
@@ -1137,7 +1245,7 @@ test namespace-30.5 {NamespaceOriginCmd, imported command} {
} {::foreach ::test_ns_2::p ::test_ns_1::cmd1 ::test_ns_1::cmd2}
test namespace-31.1 {NamespaceParentCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace parent a b} msg] $msg
} {1 {wrong # args: should be "namespace parent ?name?"}}
test namespace-31.2 {NamespaceParentCmd, no args} {
@@ -1153,12 +1261,12 @@ test namespace-31.3 {NamespaceParentCmd, namespace specified} {
[namespace parent test_ns_1::test_ns_2] \
[namespace eval test_ns_1::test_ns_2::test_ns_3 {namespace parent ::test_ns_1::test_ns_2}]
} {{} ::test_ns_1 ::test_ns_1}
-test namespace-31.4 {NamespaceParentCmd, bad namespace specified} {
- list [catch {namespace parent test_ns_1::test_ns_foo} msg] $msg
-} {1 {unknown namespace "test_ns_1::test_ns_foo" in namespace parent command}}
+test namespace-31.4 {NamespaceParentCmd, bad namespace specified} -body {
+ namespace parent test_ns_1::test_ns_foo
+} -returnCodes error -result {namespace "test_ns_1::test_ns_foo" not found in "::"}
test namespace-32.1 {NamespaceQualifiersCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace qualifiers} msg] $msg
} {1 {wrong # args: should be "namespace qualifiers string"}}
test namespace-32.2 {NamespaceQualifiersCmd, bad args} {
@@ -1184,7 +1292,7 @@ test namespace-32.8 {NamespaceQualifiersCmd, odd number of :s} {
} {foo}
test namespace-33.1 {NamespaceTailCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace tail} msg] $msg
} {1 {wrong # args: should be "namespace tail string"}}
test namespace-33.2 {NamespaceTailCmd, bad args} {
@@ -1210,7 +1318,7 @@ test namespace-33.8 {NamespaceTailCmd, odd number of :s} {
} {}
test namespace-34.1 {NamespaceWhichCmd, bad args} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
list [catch {namespace which} msg] $msg
} {1 {wrong # args: should be "namespace which ?-command? ?-variable? name"}}
test namespace-34.2 {NamespaceWhichCmd, bad args} {
@@ -1263,7 +1371,7 @@ test namespace-34.7 {NamespaceWhichCmd, variable lookup} {
} {::env ::test_ns_3::v3 ::test_ns_2::v2 0 {}}
test namespace-35.1 {FreeNsNameInternalRep, resulting ref count > 0} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc p {} {
namespace delete [namespace current]
@@ -1286,7 +1394,7 @@ test namespace-35.2 {FreeNsNameInternalRep, resulting ref count == 0} {
catch {unset x}
catch {unset y}
test namespace-36.1 {DupNsNameInternalRep} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1 {}
set x "::test_ns_1"
list [namespace parent $x] [set y $x] [namespace parent $y]
@@ -1295,27 +1403,27 @@ catch {unset x}
catch {unset y}
test namespace-37.1 {SetNsNameFromAny, ns name found} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval test_ns_1::test_ns_2 {}
namespace eval test_ns_1 {
namespace children ::test_ns_1
}
} {::test_ns_1::test_ns_2}
-test namespace-37.2 {SetNsNameFromAny, ns name not found} {
+test namespace-37.2 {SetNsNameFromAny, ns name not found} -body {
namespace eval test_ns_1 {
- list [catch {namespace children ::test_ns_1::test_ns_foo} msg] $msg
+ namespace children ::test_ns_1::test_ns_foo
}
-} {1 {unknown namespace "::test_ns_1::test_ns_foo" in namespace children command}}
+} -returnCodes error -result {namespace "::test_ns_1::test_ns_foo" not found}
test namespace-38.1 {UpdateStringOfNsName} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
;# Tcl_NamespaceObjCmd calls UpdateStringOfNsName to get subcmd name
list [namespace eval {} {namespace current}] \
[namespace eval {} {namespace current}]
} {:: ::}
test namespace-39.1 {NamespaceExistsCmd} {
- catch {namespace delete {expand}[namespace children :: test_ns_*]}
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
namespace eval ::test_ns_z::test_me { variable foo }
list [namespace exists ::] \
[namespace exists ::bogus_namespace] \
@@ -1334,16 +1442,17 @@ test namespace-39.3 {NamespaceExistsCmd error} {
list [catch {namespace exists a b} msg] $msg
} {1 {wrong # args: should be "namespace exists name"}}
-test namespace-40.1 {Ignoring namespace proc "unknown"} {
+test namespace-40.1 {Ignoring namespace proc "unknown"} -setup {
rename unknown _unknown
+} -body {
proc unknown args {return global}
namespace eval ns {proc unknown args {return local}}
- set l [list [namespace eval ns aaa bbb] [namespace eval ns aaa]]
+ list [namespace eval ns aaa bbb] [namespace eval ns aaa]
+} -cleanup {
rename unknown {}
rename _unknown unknown
namespace delete ns
- set l
-} {global global}
+} -result {global global}
test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} {
set res {}
@@ -1361,7 +1470,6 @@ test namespace-41.1 {Shadowing byte-compiled commands, Bug: 231259} {
namespace delete ns
set res
} {0 1}
-
test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} {
set res {}
namespace eval ns {}
@@ -1375,19 +1483,16 @@ test namespace-41.2 {Shadowing byte-compiled commands, Bug: 231259} {
namespace delete ns
set res
} {New proc is called}
-
test namespace-41.3 {Shadowing byte-compiled commands, Bugs: 231259, 729692} {
set res {}
namespace eval ns {
variable b 0
}
-
proc ns::a {i} {
variable b
proc set args {return "New proc is called"}
return [set b $i]
}
-
set res [list [ns::a 1] $ns::b]
namespace delete ns
set res
@@ -1426,18 +1531,18 @@ test namespace-42.3 {ensembles: basic} {
namespace delete ns
lappend result [info command ns::x1]
} {1 2 1 {unknown or ambiguous subcommand "x": must be x1, or x2} ::ns::x1 {}}
-test namespace-42.4 {ensembles: basic} {
+test namespace-42.4 {ensembles: basic} -body {
namespace eval ns {
namespace export y*
proc x1 {} {format 1}
proc x2 {} {format 2}
namespace ensemble create
}
- set result [list [catch {ns x} msg] $msg]
+ list [catch {ns x} msg] $msg
+} -cleanup {
namespace delete ns
- set result
-} {1 {unknown subcommand "x": namespace ::ns does not export any commands}}
-test namespace-42.5 {ensembles: basic} {
+} -result {1 {unknown subcommand "x": namespace ::ns does not export any commands}}
+test namespace-42.5 {ensembles: basic} -body {
namespace eval ns {
namespace export x*
proc x1 {} {format 1}
@@ -1445,11 +1550,11 @@ test namespace-42.5 {ensembles: basic} {
proc x3 {} {format 3}
namespace ensemble create
}
- set result [list [catch {ns x} msg] $msg]
+ list [catch {ns x} msg] $msg
+} -cleanup {
namespace delete ns
- set result
-} {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}}
-test namespace-42.6 {ensembles: nested} {
+} -result {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}}
+test namespace-42.6 {ensembles: nested} -body {
namespace eval ns {
namespace export x*
namespace eval x0 {
@@ -1462,11 +1567,11 @@ test namespace-42.6 {ensembles: nested} {
proc x3 {} {format 3}
namespace ensemble create
}
- set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]]
+ list [ns x0 z] [ns x1] [ns x2] [ns x3]
+} -cleanup {
namespace delete ns
- set result
-} {0 1 2 3}
-test namespace-42.7 {ensembles: nested} {
+} -result {0 1 2 3}
+test namespace-42.7 {ensembles: nested} -body {
namespace eval ns {
namespace export x*
namespace eval x0 {
@@ -1479,10 +1584,24 @@ test namespace-42.7 {ensembles: nested} {
proc x3 {} {format 3}
namespace ensemble create
}
- set result [list [ns x0 z] [ns x1] [ns x2] [ns x3]]
+ list [ns x0 z] [ns x1] [ns x2] [ns x3]
+} -cleanup {
namespace delete ns
- set result
-} {{1 ::ns::x0::z} 1 2 3}
+} -result {{1 ::ns::x0::z} 1 2 3}
+test namespace-42.8 {ensembles: [Bug 1670091]} -setup {
+ proc demo args {}
+ variable target [list [namespace which demo] x]
+ proc trial args {variable target; string length $target}
+ trace add execution demo enter [namespace code trial]
+ namespace ensemble create -command foo -map [list bar $target]
+} -body {
+ foo bar
+} -cleanup {
+ unset target
+ rename demo {}
+ rename trial {}
+ rename foo {}
+} -result {}
test namespace-43.1 {ensembles: dict-driven} {
namespace eval ns {
@@ -1495,7 +1614,7 @@ test namespace-43.1 {ensembles: dict-driven} {
rename ns {}
lappend result [namespace ensemble exists ns]
} {1 {unknown or ambiguous subcommand "c": must be a, or b} 1 0}
-test namespace-43.2 {ensembles: dict-driven} {
+test namespace-43.2 {ensembles: dict-driven} -body {
namespace eval ns {
namespace export x*
proc x1 {args} {list 1 $args}
@@ -1504,10 +1623,10 @@ test namespace-43.2 {ensembles: dict-driven} {
a ::ns::x1 b ::ns::x2 c {::ns::x1 .} d {::ns::x2 .}
}
}
- set result [list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo]]
+ list [ns a] [ns b] [ns c] [ns c foo] [ns d] [ns d foo]
+} -cleanup {
namespace delete ns
- set result
-} {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}}
+} -result {{1 {}} {2 0} {1 .} {1 {. foo}} {2 1} {2 2}}
set SETUP {
namespace eval ns {
namespace export a b
@@ -1605,6 +1724,9 @@ test namespace-44.5 {ensemble: errors} -setup {
} -cleanup {
rename foobar {}
} -returnCodes error -result {invalid command name "::foobarconfigure"}
+test namespace-44.6 {ensemble: errors} -returnCodes error -body {
+ namespace ensemble create gorp
+} -result {wrong # args: should be "namespace ensemble create ?option value ...?"}
test namespace-45.1 {ensemble: introspection} {
namespace eval ns {
@@ -1615,7 +1737,7 @@ test namespace-45.1 {ensemble: introspection} {
}
namespace delete ns
set result
-} {-map {} -namespace ::ns -prefixes 1 -subcommands {} -unknown {}}
+} {-map {} -namespace ::ns -parameters {} -prefixes 1 -subcommands {} -unknown {}}
test namespace-45.2 {ensemble: introspection} {
namespace eval ns {
namespace export x
@@ -1631,15 +1753,12 @@ test namespace-46.1 {ensemble: modification} {
namespace eval ns {
namespace export x
proc x {} {format 123}
-
# Ensemble maps A->x
namespace ensemble create -command ns -map {A ::ns::x}
set ::result [list [namespace ensemble configure ns -map] [ns A]]
-
# Ensemble maps B->x
namespace ensemble configure ns -map {B ::ns::x}
lappend ::result [namespace ensemble configure ns -map] [ns B]
-
# Ensemble maps x->x
namespace ensemble configure ns -map {}
lappend ::result [namespace ensemble configure ns -map] [ns x]
@@ -1679,7 +1798,7 @@ test namespace-46.3 {ensemble: implementation errors} {
lappend result $ns::count
namespace delete ns
lappend result [info command p]
-} {1 {wrong # args: should be "ns subcommand ?argument ...?"} 10 3010 3010 {}}
+} {1 {wrong # args: should be "ns subcommand ?arg ...?"} 10 3010 3010 {}}
test namespace-46.4 {ensemble: implementation errors} {
namespace eval ns {
namespace ensemble create
@@ -1777,7 +1896,7 @@ test namespace-47.2 {ensemble: unknown handler} {
}
namespace ensemble create -unknown ::ns::Magic
}
- list [catch {ns spong} msg] $msg $errorInfo [namespace delete ns]
+ list [catch {ns spong} msg] $msg $::errorInfo [namespace delete ns]
} {1 foobar {foobar
while executing
"error foobar"
@@ -1810,7 +1929,7 @@ test namespace-47.4 {ensemble: unknown handler} {
}
namespace ensemble create -unknown ::ns::Magic
}
- list [catch {ns spong} msg] $msg $errorInfo [namespace delete ns]
+ list [catch {ns spong} msg] $msg $::errorInfo [namespace delete ns]
} {1 {unknown subcommand handler returned bad code: break} {unknown subcommand handler returned bad code: break
result of ensemble unknown subcommand handler: ::ns::Magic ::ns spong
invoked from within
@@ -1829,19 +1948,37 @@ test namespace-47.5 {ensemble: unknown handler} {
lappend result [catch {foo bar} msg] $msg [namespace ensemble config foo]
rename foo {}
set result
-} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -prefixes 1 -subcommands {} -unknown bar}}
+} {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo 0 {{LOG ::foo bar} 1 {unknown subcommand "bar": namespace :: does not export any commands} {LOG ::foo bar} boo hoo} {-map {} -namespace :: -parameters {} -prefixes 1 -subcommands {} -unknown bar}}
test namespace-47.6 {ensemble: unknown handler} {
namespace ensemble create -command foo -unknown bar
proc bar {args} {
return "\{"
}
- set result [list [catch {foo bar} msg] $msg $errorInfo]
+ set result [list [catch {foo bar} msg] $msg $::errorInfo]
rename foo {}
set result
} {1 {unmatched open brace in list} {unmatched open brace in list
while parsing result of ensemble unknown subcommand handler
invoked from within
"foo bar"}}
+test namespace-47.7 {ensemble: unknown handler, commands with spaces} {
+ namespace ensemble create -command foo -unknown bar
+ proc bar {args} {
+ list ::set ::x [join $args |]
+ }
+ set result [foo {one two three}]
+ rename foo {}
+ set result
+} {::foo|one two three}
+test namespace-47.8 {ensemble: unknown handler, commands with spaces} {
+ namespace ensemble create -command foo -unknown {bar boo}
+ proc bar {args} {
+ list ::set ::x [join $args |]
+ }
+ set result [foo {one two three}]
+ rename foo {}
+ set result
+} {boo|::foo|one two three}
test namespace-48.1 {ensembles and namespace import: unknown handler} {
namespace eval foo {
@@ -1878,7 +2015,7 @@ test namespace-48.1 {ensembles and namespace import: unknown handler} {
bar z 789
namespace delete foo
set result
-} {{-map {} -namespace ::foo -prefixes 1 -subcommands x -unknown ::foo::u} XXX 123 ::foo::bar {y 456} YYY 456 ::foo::bar {z 789} ZZZ 789}
+} {{-map {} -namespace ::foo -parameters {} -prefixes 1 -subcommands x -unknown ::foo::u} XXX 123 ::foo::bar {y 456} YYY 456 ::foo::bar {z 789} ZZZ 789}
test namespace-48.2 {ensembles and namespace import: exists} {
namespace eval foo {
namespace ensemble create -command ::foo::bar
@@ -1942,7 +2079,7 @@ test namespace-50.1 {ensembles affect proc arguments error messages} -body {
namespace ens cre -command a -map {b {bb foo}}
proc bb {c d {e f} args} {list $c $args}
a b
-} -returnCodes error -result "wrong # args: should be \"a b d ?e? ...\"" -cleanup {
+} -returnCodes error -result "wrong # args: should be \"a b d ?e? ?arg ...?\"" -cleanup {
rename a {}
rename bb {}
}
@@ -1959,6 +2096,7 @@ test namespace-50.3 {chained ensembles affect error messages} -body {
a b d
} -returnCodes error -result "wrong # args: should be \"a b d f\"" -cleanup {
rename a {}
+ rename c {}
}
test namespace-50.4 {chained ensembles affect error messages} -body {
namespace ens cre -command a -map {b {c d}}
@@ -1967,6 +2105,7 @@ test namespace-50.4 {chained ensembles affect error messages} -body {
a b d
} -returnCodes error -result "wrong # args: should be \"a b\"" -cleanup {
rename a {}
+ rename c {}
}
test namespace-51.1 {name resolution path control} -body {
@@ -2235,7 +2374,7 @@ test namespace-51.10 {name resolution path control} -body {
namespace eval ::test_ns_1 {
namespace path does::not::exist
}
-} -returnCodes error -result {unknown namespace "does::not::exist"} -cleanup {
+} -returnCodes error -result {namespace "does::not::exist" not found in "::test_ns_1"} -cleanup {
catch {namespace delete ::test_ns_1}
}
test namespace-51.11 {name resolution path control} -body {
@@ -2278,15 +2417,14 @@ test namespace-51.12 {name resolution path control} -body {
catch {namespace delete ::test_ns_3}
catch {namespace delete ::test_ns_4}
}
-# Fails right now due to unrelated bug...
-test namespace-51.13 {name resolution path control} -constraints knownBug -body {
+test namespace-51.13 {name resolution path control} -body {
set ::result {}
namespace eval ::test_ns_1 {
proc foo {} {lappend ::result 1}
}
namespace eval ::test_ns_2 {
proc foo {} {lappend ::result 2}
- trace add command foo delete {namespace eval ::test_ns_3 foo;#}
+ trace add command foo delete "namespace eval ::test_ns_3 foo;#"
}
namespace eval ::test_ns_3 {
proc foo {} {
@@ -2302,21 +2440,24 @@ test namespace-51.13 {name resolution path control} -constraints knownBug -body
}
bar
}
- # Should the result be "2 {} {2 3 1 1}" instead?
-} -result {2 {} {2 3 2 1}} -cleanup {
+ # Should the result be "2 {} {2 3 2 1}" instead?
+} -result {2 {} {2 3 1 1}} -cleanup {
catch {namespace delete ::test_ns_1}
catch {namespace delete ::test_ns_2}
catch {namespace delete ::test_ns_3}
catch {namespace delete ::test_ns_4}
}
-test namespace-51.14 {name resolution path control} -body {
- proc foo0 {} {}
- namespace eval ::test_ns_1 {
- proc foo1 {} {}
- }
- namespace eval ::test_ns_2 {
- proc foo2 {} {}
+test namespace-51.14 {name resolution path control} -setup {
+ foreach cmd [info commands foo*] {
+ rename $cmd {}
}
+ namespace eval ::test_ns_1 {}
+ namespace eval ::test_ns_2 {}
+ namespace eval ::test_ns_3 {}
+} -body {
+ proc foo0 {} {}
+ proc ::test_ns_1::foo1 {} {}
+ proc ::test_ns_2::foo2 {} {}
namespace eval ::test_ns_3 {
variable result {}
lappend result [info commands foo*]
@@ -2329,11 +2470,11 @@ test namespace-51.14 {name resolution path control} -body {
namespace delete ::test_ns_1
lappend result [info commands foo*]
}
-} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}} -cleanup {
+} -cleanup {
catch {namespace delete ::test_ns_1}
catch {namespace delete ::test_ns_2}
catch {namespace delete ::test_ns_3}
-}
+} -result {foo0 {foo1 foo2 foo0} {foo2 foo1 foo0} {foo1 foo2 foo0} {foo2 foo0}}
test namespace-51.15 {namespace resolution path control} -body {
namespace eval ::test_ns_2 {
proc foo {} {return 2}
@@ -2351,13 +2492,470 @@ test namespace-51.15 {namespace resolution path control} -body {
namespace delete ::test_ns_1
namespace delete ::test_ns_2
}
+test namespace-51.16 {Bug 1566526} {
+ interp create slave
+ slave eval namespace eval demo namespace path ::
+ interp delete slave
+} {}
+test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup {
+ set result {}
+ catch {namespace delete ::a}
+} -body {
+ namespace eval ::a {
+ proc c {} {lappend ::result A}
+ c
+ namespace eval b {
+ variable d c
+ lappend ::result [catch { $d }]
+ }
+ lappend ::result .
+ namespace eval b {
+ namespace path [namespace parent]
+ $d;[format %c 99]
+ }
+ lappend ::result .
+ namespace eval b {
+ proc c {} {lappend ::result B}
+ $d;[format %c 99]
+ }
+ lappend ::result .
+ }
+ namespace eval ::a::b {
+ $d;[format %c 99]
+ lappend ::result .
+ proc ::c {} {lappend ::result G}
+ $d;[format %c 99]
+ lappend ::result .
+ rename ::a::c {}
+ $d;[format %c 99]
+ lappend ::result .
+ rename ::a::b::c {}
+ $d;[format %c 99]
+ }
+} -cleanup {
+ namespace delete ::a
+ catch {rename ::c {}}
+ unset result
+} -result {A 1 . A A . B B . B B . B B . B B . G G}
+test namespace-51.18 {Bug 3185407} -setup {
+ namespace eval ::test_ns_1 {}
+} -body {
+ namespace eval ::test_ns_1 {
+ variable result {}
+ namespace eval ns {proc foo {} {}}
+ namespace eval ns2 {proc foo {} {}}
+ namespace path {ns ns2}
+ variable x foo
+ lappend result [namespace which $x]
+ proc foo {} {}
+ lappend result [namespace which $x]
+ }
+} -cleanup {
+ namespace delete ::test_ns_1
+} -result {::test_ns_1::ns::foo ::test_ns_1::foo}
+
+# TIP 181 - namespace unknown tests
+test namespace-52.1 {unknown: default handler ::unknown} {
+ set result [list [namespace eval foobar { namespace unknown }]]
+ lappend result [namespace eval :: { namespace unknown }]
+ namespace delete foobar
+ set result
+} {{} ::unknown}
+test namespace-52.2 {unknown: default resolution global} {
+ proc ::foo {} { return "GLOBAL" }
+ namespace eval ::bar { proc foo {} { return "NAMESPACE" } }
+ namespace eval ::bar::jim { proc test {} { foo } }
+ set result [::bar::jim::test]
+ namespace delete ::bar
+ rename ::foo {}
+ set result
+} {GLOBAL}
+test namespace-52.3 {unknown: default resolution local} {
+ proc ::foo {} { return "GLOBAL" }
+ namespace eval ::bar {
+ proc foo {} { return "NAMESPACE" }
+ proc test {} { foo }
+ }
+ set result [::bar::test]
+ namespace delete ::bar
+ rename ::foo {}
+ set result
+} {NAMESPACE}
+test namespace-52.4 {unknown: set handler} {
+ namespace eval foo {
+ namespace unknown [list dispatch]
+ proc dispatch {args} { return $args }
+ proc test {} {
+ UnknownCmd a b c
+ }
+ }
+ set result [foo::test]
+ namespace delete foo
+ set result
+} {UnknownCmd a b c}
+test namespace-52.5 {unknown: search path before unknown is unaltered} {
+ proc ::test2 {args} { return "TEST2: $args" }
+ namespace eval foo {
+ namespace unknown [list dispatch]
+ proc dispatch {args} { return "UNKNOWN: $args" }
+ proc test1 {args} { return "TEST1: $args" }
+ proc test {} {
+ set result [list [test1 a b c]]
+ lappend result [test2 a b c]
+ lappend result [test3 a b c]
+ return $result
+ }
+ }
+ set result [foo::test]
+ namespace delete foo
+ rename ::test2 {}
+ set result
+} {{TEST1: a b c} {TEST2: a b c} {UNKNOWN: test3 a b c}}
+test namespace-52.6 {unknown: deleting handler restores default} {
+ rename ::unknown ::_unknown_orig
+ proc ::unknown {args} { return "DEFAULT: $args" }
+ namespace eval foo {
+ namespace unknown dummy
+ namespace unknown {}
+ }
+ set result [namespace eval foo { dummy a b c }]
+ rename ::unknown {}
+ rename ::_unknown_orig ::unknown
+ namespace delete foo
+ set result
+} {DEFAULT: dummy a b c}
+test namespace-52.7 {unknown: setting global unknown handler} {
+ proc ::myunknown {args} { return "MYUNKNOWN: $args" }
+ namespace eval :: { namespace unknown ::myunknown }
+ set result [namespace eval foo { dummy a b c }]
+ namespace eval :: { namespace unknown {} }
+ rename ::myunknown {}
+ namespace delete foo
+ set result
+} {MYUNKNOWN: dummy a b c}
+test namespace-52.8 {unknown: destroying and redefining global namespace} {
+ set i [interp create]
+ $i hide proc
+ $i hide namespace
+ $i hide return
+ $i invokehidden namespace delete ::
+ $i expose return
+ $i invokehidden proc unknown args { return "FINE" }
+ $i eval { foo bar bob }
+} {FINE}
+test namespace-52.9 {unknown: refcounting} -setup {
+ proc this args {
+ unset args ;# stop sharing
+ set copy [namespace unknown]
+ string length $copy ;# shimmer away list rep
+ info level 0
+ }
+ set handler [namespace unknown]
+ namespace unknown {this is a test}
+ catch {rename noSuchCommand {}}
+} -body {
+ noSuchCommand
+} -cleanup {
+ namespace unknown $handler
+ rename this {}
+} -result {this is a test noSuchCommand}
+testConstraint testevalobjv [llength [info commands testevalobjv]]
+test namespace-52.10 {unknown: with TCL_EVAL_GLOBAL} -constraints {
+ testevalobjv
+} -setup {
+ rename ::unknown unknown.save
+ proc ::unknown args {
+ set caller [uplevel 1 {namespace current}]
+ namespace eval $caller {
+ variable foo
+ return $foo
+ }
+ }
+ catch {rename ::noSuchCommand {}}
+} -body {
+ namespace eval :: {
+ variable foo SUCCESS
+ }
+ namespace eval test_ns_1 {
+ variable foo FAIL
+ testevalobjv 1 noSuchCommand
+ }
+} -cleanup {
+ unset -nocomplain ::foo
+ namespace delete test_ns_1
+ rename ::unknown {}
+ rename unknown.save ::unknown
+} -result SUCCESS
+test namespace-52.11 {unknown: with TCL_EVAL_INVOKE} -setup {
+ set handler [namespace eval :: {namespace unknown}]
+ namespace eval :: {namespace unknown unknown}
+ rename ::unknown unknown.save
+ namespace eval :: {
+ proc unknown args {
+ return SUCCESS
+ }
+ }
+ catch {rename ::noSuchCommand {}}
+ set ::slave [interp create]
+} -body {
+ $::slave alias bar noSuchCommand
+ namespace eval test_ns_1 {
+ namespace unknown unknown
+ proc unknown args {
+ return FAIL
+ }
+ $::slave eval bar
+ }
+} -cleanup {
+ interp delete $::slave
+ unset ::slave
+ namespace delete test_ns_1
+ rename ::unknown {}
+ rename unknown.save ::unknown
+ namespace eval :: [list namespace unknown $handler]
+} -result SUCCESS
+test namespace-52.12 {unknown: error case must not reset handler} -body {
+ namespace eval foo {
+ namespace unknown ok
+ catch {namespace unknown {{}{}{}}}
+ namespace unknown
+ }
+} -cleanup {
+ namespace delete foo
+} -result ok
+# TIP 314 - ensembles with parameters
+test namespace-53.1 {ensembles: parameters} {
+ namespace eval ns {
+ namespace export x
+ proc x {para} {list 1 $para}
+ namespace ensemble create -parameters {para1}
+ }
+ list [info command ns] [ns bar x] [namespace delete ns] [info command ns]
+} {ns {1 bar} {} {}}
+test namespace-53.2 {ensembles: parameters} -setup {
+ namespace eval ns {
+ namespace export x
+ proc x {para} {list 1 $para}
+ namespace ensemble create
+ }
+} -body {
+ namespace ensemble configure ns -parameters {para1}
+ rename ns foo
+ list [info command foo] [foo bar x] [namespace delete ns] [info command foo]
+} -result {foo {1 bar} {} {}}
+test namespace-53.3 {ensembles: parameters} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {para} {list 1 $para}
+ proc x2 {para} {list 2 $para}
+ namespace ensemble create -parameters param1
+ }
+} -body {
+ set result [list [ns x2 x1] [ns x1 x2]]
+ lappend result [catch {ns x} msg] $msg
+ lappend result [catch {ns x x} msg] $msg
+ rename ns {}
+ lappend result [info command ns::x1]
+ namespace delete ns
+ lappend result [info command ns::x1]
+} -result\
+ {{1 x2} {2 x1}\
+ 1 {wrong # args: should be "ns param1 subcommand ?arg ...?"}\
+ 1 {unknown or ambiguous subcommand "x": must be x1, or x2}\
+ ::ns::x1 {}}
+test namespace-53.4 {ensembles: parameters} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {a1 a2} {list 1 $a1 $a2}
+ proc x2 {a1 a2} {list 2 $a1 $a2}
+ proc x3 {a1 a2} {list 3 $a1 $a2}
+ namespace ensemble create
+ }
+} -body {
+ set result {}
+ lappend result [ns x1 x2 x3]
+ namespace ensemble configure ns -parameters p1
+ lappend result [ns x1 x2 x3]
+ namespace ensemble configure ns -parameters {p1 p2}
+ lappend result [ns x1 x2 x3]
+} -cleanup {
+ namespace delete ns
+} -result {{1 x2 x3} {2 x1 x3} {3 x1 x2}}
+test namespace-53.5 {ensembles: parameters} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {para} {list 1 $para}
+ proc x2 {para} {list 2 $para}
+ proc x3 {para} {list 3 $para}
+ namespace ensemble create
+ }
+} -body {
+ set result [list [catch {ns x x1} msg] $msg]
+ lappend result [catch {ns x1 x} msg] $msg
+ namespace ensemble configure ns -parameters p1
+ lappend result [catch {ns x1 x} msg] $msg
+ lappend result [catch {ns x x1} msg] $msg
+} -cleanup {
+ namespace delete ns
+} -result\
+ {1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\
+ 0 {1 x}\
+ 1 {unknown or ambiguous subcommand "x": must be x1, x2, or x3}\
+ 0 {1 x}}
+test namespace-53.6 {ensembles: nested} -setup {
+ namespace eval ns {
+ namespace export x*
+ namespace eval x0 {
+ proc z {args} {list 0 $args}
+ namespace export z
+ namespace ensemble create
+ }
+ proc x1 {args} {list 1 $args}
+ proc x2 {args} {list 2 $args}
+ proc x3 {args} {list 3 $args}
+ namespace ensemble create -parameters p
+ }
+} -body {
+ list [ns z x0] [ns z x1] [ns z x2] [ns z x3]
+} -cleanup {
+ namespace delete ns
+} -result {{0 {}} {1 z} {2 z} {3 z}}
+test namespace-53.7 {ensembles: parameters & wrong # args} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {a1 a2 a3 a4} {list x1 $a1 $a2 $a3 $a4}
+ namespace ensemble create -parameters p1
+ }
+} -body {
+ set result {}
+ lappend result [catch {ns} msg] $msg
+ lappend result [catch {ns x1} msg] $msg
+ lappend result [catch {ns x1 x1} msg] $msg
+ lappend result [catch {ns x1 x1 x1} msg] $msg
+ lappend result [catch {ns x1 x1 x1 x1} msg] $msg
+ lappend result [catch {ns x1 x1 x1 x1 x1} msg] $msg
+} -cleanup {
+ namespace delete ns
+} -result\
+ {1 {wrong # args: should be "ns p1 subcommand ?arg ...?"}\
+ 1 {wrong # args: should be "ns p1 subcommand ?arg ...?"}\
+ 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\
+ 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\
+ 1 {wrong # args: should be "ns x1 x1 a2 a3 a4"}\
+ 0 {x1 x1 x1 x1 x1}}
+test namespace-53.8 {ensemble: unknown handler changing -parameters} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {a1} {list 1 $a1}
+ proc Magic {ensemble subcmd args} {
+ namespace ensemble configure $ensemble\
+ -parameters [lrange p1 [llength [
+ namespace ensemble configure $ensemble -parameters
+ ]] 0]
+ list
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+} -body {
+ set result {}
+ lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters]
+ lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters]
+ lappend result [catch {ns x2 x3} msg] $msg [namespace ensemble configure ns -parameters]
+} -cleanup {
+ namespace delete ns
+} -result\
+ {0 {1 x2} {}\
+ 0 {1 x2} p1\
+ 1 {unknown or ambiguous subcommand "x2": must be x1} {}}
+test namespace-53.9 {ensemble: unknown handler changing -parameters,\
+ thereby eating all args} -setup {
+ namespace eval ns {
+ namespace export x*
+ proc x1 {args} {list 1 $args}
+ proc Magic {ensemble subcmd args} {
+ namespace ensemble configure $ensemble\
+ -parameters {p1 p2 p3 p4 p5}
+ list
+ }
+ namespace ensemble create -unknown ::ns::Magic
+ }
+} -body {
+ set result {}
+ lappend result [catch {ns x1 x2} msg] $msg [namespace ensemble configure ns -parameters]
+ lappend result [catch {ns x2 x1} msg] $msg [namespace ensemble configure ns -parameters]
+ lappend result [catch {ns a1 a2 a3 a4 a5 x1} msg] $msg [namespace ensemble configure ns -parameters]
+} -cleanup {
+ namespace delete ns
+} -result\
+ {0 {1 x2} {}\
+ 1 {wrong # args: should be "ns p1 p2 p3 p4 p5 subcommand ?arg ...?"} {p1 p2 p3 p4 p5}\
+ 0 {1 {a1 a2 a3 a4 a5}} {p1 p2 p3 p4 p5}}
+test namespace-53.10 {ensembles: nested rewrite} -setup {
+ namespace eval ns {
+ namespace export x
+ namespace eval x {
+ proc z0 {} {list 0}
+ proc z1 {a1} {list 1 $a1}
+ proc z2 {a1 a2} {list 2 $a1 $a2}
+ proc z3 {a1 a2 a3} {list 3 $a1 $a2 $a3}
+ namespace export z*
+ namespace ensemble create
+ }
+ namespace ensemble create -parameters p
+ }
+} -body {
+ set result {}
+ # In these cases, parsing the subensemble does not grab a new word.
+ lappend result [catch {ns z0 x} msg] $msg
+ lappend result [catch {ns z1 x} msg] $msg
+ lappend result [catch {ns z2 x} msg] $msg
+ lappend result [catch {ns z2 x v} msg] $msg
+ namespace ensemble configure ns::x -parameters q1
+ # In these cases, parsing the subensemble grabs a new word.
+ lappend result [catch {ns v x z0} msg] $msg
+ lappend result [catch {ns v x z1} msg] $msg
+ lappend result [catch {ns v x z2} msg] $msg
+ lappend result [catch {ns v x z2 v2} msg] $msg
+} -cleanup {
+ namespace delete ns
+} -result\
+ {0 0\
+ 1 {wrong # args: should be "ns z1 x a1"}\
+ 1 {wrong # args: should be "ns z2 x a1 a2"}\
+ 1 {wrong # args: should be "ns z2 x a1 a2"}\
+ 1 {wrong # args: should be "::ns::x::z0"}\
+ 0 {1 v}\
+ 1 {wrong # args: should be "ns v x z2 a2"}\
+ 0 {2 v v2}}
+
+test namespace-54.1 {leak on namespace deletion} -constraints {memory} \
+-setup {
+ proc getbytes {} {
+ set lines [split [memory info] "\n"]
+ lindex $lines 3 3
+ }
+} -body {
+ set end [getbytes]
+ for {set i 0} {$i < 5} {incr i} {
+ set ns ::y$i
+ namespace eval $ns {}
+ namespace delete $ns
+ set start $end
+ set end [getbytes]
+ }
+ set leakedBytes [expr {$end - $start}]
+} -cleanup {
+ rename getbytes {}
+ unset i ns start end
+} -result 0
+
# cleanup
catch {rename cmd1 {}}
catch {unset l}
catch {unset msg}
catch {unset trigger}
-namespace delete {expand}[namespace children :: test_ns_*]
+namespace delete {*}[namespace children :: test_ns_*]
::tcltest::cleanupTests
return
generated by cgit v0.12 at 2025-10-21 20:08:10 (GMT)