summaryrefslogtreecommitdiffstats
path: root/tests/basic.test
diff options
context:
space:
mode:
authorrjohnson <rjohnson>1998-03-26 14:56:55 (GMT)
committerrjohnson <rjohnson>1998-03-26 14:56:55 (GMT)
commit72d823b9193f9ee2b0318563b49363cd08c11f24 (patch)
treec168cc164a71f320db9dcdfe7518ba7bd0d2c8d9 /tests/basic.test
parent2b5738da524e944cda39e24c0a87b745a43bd8c3 (diff)
downloadtcl-72d823b9193f9ee2b0318563b49363cd08c11f24.zip
tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.tar.gz
tcl-72d823b9193f9ee2b0318563b49363cd08c11f24.tar.bz2
Initial revision
Diffstat (limited to 'tests/basic.test')
-rw-r--r--tests/basic.test399
1 files changed, 399 insertions, 0 deletions
diff --git a/tests/basic.test b/tests/basic.test
new file mode 100644
index 0000000..502e3e5
--- /dev/null
+++ b/tests/basic.test
@@ -0,0 +1,399 @@
+# This file contains tests for the tclBasic.c source file. Tests appear in
+# the same order as the C code that they test. The set of tests is
+# currently incomplete since it currently includes only new tests for
+# code changed for the addition of Tcl namespaces. Other variable-
+# related tests appear in several other test files including
+# assocd.test, cmdInfo.test, eval.test, expr.test, interp.test,
+# and trace.test.
+#
+# 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.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) basic.test 1.19 97/10/31 16:02:26
+#
+
+if {[string compare test [info procs test]] == 1} then {source defs}
+
+catch {namespace delete test_ns_basic}
+catch {interp delete test_interp}
+catch {rename p ""}
+catch {rename q ""}
+catch {rename cmd ""}
+catch {unset x}
+
+test basic-1.1 {Tcl_CreateInterp, creates interp's global namespace} {
+ catch {interp delete test_interp}
+ interp create test_interp
+ interp eval test_interp {
+ namespace eval test_ns_basic {
+ proc p {} {
+ return [namespace current]
+ }
+ }
+ }
+ list [interp eval test_interp {test_ns_basic::p}] \
+ [interp delete test_interp]
+} {::test_ns_basic {}}
+
+test basic-2.1 {DeleteInterpProc, destroys interp's global namespace} {
+ catch {interp delete test_interp}
+ interp create test_interp
+ interp eval test_interp {
+ namespace eval test_ns_basic {
+ namespace export p
+ proc p {} {
+ return [namespace current]
+ }
+ }
+ namespace eval test_ns_2 {
+ namespace import ::test_ns_basic::p
+ variable v 27
+ proc q {} {
+ variable v
+ return "[p] $v"
+ }
+ }
+ }
+ list [interp eval test_interp {test_ns_2::q}] \
+ [interp eval test_interp {namespace delete ::}] \
+ [catch {interp eval test_interp {set a 123}} msg] $msg \
+ [interp delete test_interp]
+} {{::test_ns_basic 27} {} 1 {invalid command name "set"} {}}
+
+test basic-3.1 {HiddenCmdsDeleteProc, invalidate cached refs to deleted hidden cmd} {
+ catch {interp delete test_interp}
+ interp create test_interp
+ interp eval test_interp {
+ proc p {} {
+ return 27
+ }
+ }
+ interp alias {} localP test_interp p
+ list [interp eval test_interp {p}] \
+ [localP] \
+ [test_interp hide p] \
+ [catch {localP} msg] $msg \
+ [interp delete test_interp] \
+ [catch {localP} msg] $msg
+} {27 27 {} 1 {invalid command name "p"} {} 1 {invalid command name "localP"}}
+
+# NB: More tests about hide/expose are found in interp.test
+
+test basic-4.1 {Tcl_HideCommand, names of hidden cmds can't have namespace qualifiers} {
+ catch {interp delete test_interp}
+ interp create test_interp
+ interp eval test_interp {
+ namespace eval test_ns_basic {
+ proc p {} {
+ return [namespace current]
+ }
+ }
+ }
+ list [catch {test_interp hide test_ns_basic::p x} msg] $msg \
+ [catch {test_interp hide x test_ns_basic::p} msg1] $msg1 \
+ [interp delete test_interp]
+} {1 {can only hide global namespace commands (use rename then hide)} 1 {cannot use namespace qualifiers as hidden commandtoken (rename)} {}}
+
+test basic-4.2 {Tcl_HideCommand, a hidden cmd remembers its containing namespace} {
+ catch {namespace delete test_ns_basic}
+ catch {rename cmd ""}
+ proc cmd {} { ;# note that this is global
+ return [namespace current]
+ }
+ namespace eval test_ns_basic {
+ proc hideCmd {} {
+ interp hide {} cmd
+ }
+ proc exposeCmd {} {
+ interp expose {} cmd
+ }
+ proc callCmd {} {
+ cmd
+ }
+ }
+ list [test_ns_basic::callCmd] \
+ [test_ns_basic::hideCmd] \
+ [catch {cmd} msg] $msg \
+ [test_ns_basic::exposeCmd] \
+ [test_ns_basic::callCmd] \
+ [namespace delete test_ns_basic]
+} {:: {} 1 {invalid command name "cmd"} {} :: {}}
+
+test basic-5.1 {Tcl_ExposeCommand, a command stays in the global namespace and can not go to another namespace} {
+ catch {namespace delete test_ns_basic}
+ catch {rename cmd ""}
+ proc cmd {} { ;# note that this is global
+ return [namespace current]
+ }
+ namespace eval test_ns_basic {
+ proc hideCmd {} {
+ interp hide {} cmd
+ }
+ proc exposeCmdFailing {} {
+ interp expose {} cmd ::test_ns_basic::newCmd
+ }
+ proc exposeCmdWorkAround {} {
+ interp expose {} cmd;
+ rename cmd ::test_ns_basic::newCmd;
+ }
+ proc callCmd {} {
+ cmd
+ }
+ }
+ list [test_ns_basic::callCmd] \
+ [test_ns_basic::hideCmd] \
+ [catch {test_ns_basic::exposeCmdFailing} msg] $msg \
+ [test_ns_basic::exposeCmdWorkAround] \
+ [test_ns_basic::newCmd] \
+ [namespace delete test_ns_basic]
+} {:: {} 1 {can not expose to a namespace (use expose to toplevel, then rename)} {} ::test_ns_basic {}}
+test basic-5.2 {Tcl_ExposeCommand, invalidate cached refs to cmd now being exposed} {
+ catch {rename p ""}
+ catch {rename cmd ""}
+ proc p {} {
+ cmd
+ }
+ proc cmd {} {
+ return 42
+ }
+ list [p] \
+ [interp hide {} cmd] \
+ [proc cmd {} {return Hello}] \
+ [cmd] \
+ [rename cmd ""] \
+ [interp expose {} cmd] \
+ [p]
+} {42 {} {} Hello {} {} 42}
+
+if {[info commands testcreatecommand] != {}} {
+ test basic-6.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ list [testcreatecommand create] \
+ [test_ns_basic::createdcommand] \
+ [testcreatecommand delete]
+ } {{} {CreatedCommandProc in ::test_ns_basic} {}}
+ test basic-6.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {rename value:at: ""}
+ list [testcreatecommand create2] \
+ [value:at:] \
+ [testcreatecommand delete2]
+ } {{} {CreatedCommandProc2 in ::} {}}
+}
+test basic-6.3 {Tcl_CreateObjCommand, new cmd goes into a namespace specified in its name, if any} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval test_ns_basic {}
+ proc test_ns_basic::cmd {} { ;# proc requires that ns already exist
+ return [namespace current]
+ }
+ list [test_ns_basic::cmd] \
+ [namespace delete test_ns_basic]
+} {::test_ns_basic {}}
+
+test basic-7.1 {TclRenameCommand, name of existing cmd can have namespace qualifiers} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {rename cmd ""}
+ namespace eval test_ns_basic {
+ proc p {} {
+ return "p in [namespace current]"
+ }
+ }
+ list [test_ns_basic::p] \
+ [rename test_ns_basic::p test_ns_basic::q] \
+ [test_ns_basic::q]
+} {{p in ::test_ns_basic} {} {p in ::test_ns_basic}}
+test basic-7.2 {TclRenameCommand, existing cmd must be found} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ list [catch {rename test_ns_basic::p test_ns_basic::q} msg] $msg
+} {1 {can't rename "test_ns_basic::p": command doesn't exist}}
+test basic-7.3 {TclRenameCommand, delete cmd if new name is empty} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval test_ns_basic {
+ proc p {} {
+ return "p in [namespace current]"
+ }
+ }
+ list [info commands test_ns_basic::*] \
+ [rename test_ns_basic::p ""] \
+ [info commands test_ns_basic::*]
+} {::test_ns_basic::p {} {}}
+test basic-7.4 {TclRenameCommand, bad new name} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval test_ns_basic {
+ proc p {} {
+ return "p in [namespace current]"
+ }
+ }
+ rename test_ns_basic::p :::george::martha
+} {}
+test basic-7.5 {TclRenameCommand, new name must not already exist} {
+ namespace eval test_ns_basic {
+ proc q {} {
+ return 42
+ }
+ }
+ list [catch {rename test_ns_basic::q :::george::martha} msg] $msg
+} {1 {can't rename to ":::george::martha": command already exists}}
+test basic-7.6 {TclRenameCommand, check for command shadowing by newly renamed cmd} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {rename p ""}
+ catch {rename q ""}
+ proc p {} {
+ return "p in [namespace current]"
+ }
+ proc q {} {
+ return "q in [namespace current]"
+ }
+ namespace eval test_ns_basic {
+ proc callP {} {
+ p
+ }
+ }
+ list [test_ns_basic::callP] \
+ [rename q test_ns_basic::p] \
+ [test_ns_basic::callP]
+} {{p in ::} {} {q in ::test_ns_basic}}
+
+test basic-8.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {rename p ""}
+ catch {rename q ""}
+ catch {unset x}
+ set x [namespace eval test_ns_basic::test_ns_basic2 {
+ # the following creates a cmd in the global namespace
+ testcmdtoken create p
+ }]
+ list [testcmdtoken name $x] \
+ [rename ::p q] \
+ [testcmdtoken name $x]
+} {{p ::p} {} {q ::q}}
+test basic-8.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {
+ catch {rename q ""}
+ set x [testcmdtoken create test_ns_basic::test_ns_basic2::p]
+ list [testcmdtoken name $x] \
+ [rename test_ns_basic::test_ns_basic2::p q] \
+ [testcmdtoken name $x]
+} {{p ::test_ns_basic::test_ns_basic2::p} {} {q ::q}}
+
+test basic-9.1 {Tcl_GetCommandFullName} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ namespace eval test_ns_basic1 {
+ namespace export cmd*
+ proc cmd1 {} {}
+ proc cmd2 {} {}
+ }
+ namespace eval test_ns_basic2 {
+ namespace export *
+ namespace import ::test_ns_basic1::*
+ proc p {} {}
+ }
+ namespace eval test_ns_basic3 {
+ namespace import ::test_ns_basic2::*
+ proc q {} {}
+ list [namespace which -command foreach] \
+ [namespace which -command q] \
+ [namespace which -command p] \
+ [namespace which -command cmd1] \
+ [namespace which -command ::test_ns_basic2::cmd2]
+ }
+} {::foreach ::test_ns_basic3::q ::test_ns_basic3::p ::test_ns_basic3::cmd1 ::test_ns_basic2::cmd2}
+
+test basic-10.1 {Tcl_DeleteCommandFromToken, invalidate all compiled code if cmd has compile proc} {
+ catch {interp delete test_interp}
+ catch {unset x}
+ interp create test_interp
+ interp eval test_interp {
+ proc useSet {} {
+ return [set a 123]
+ }
+ }
+ set x [interp eval test_interp {useSet}]
+ interp eval test_interp {
+ rename set ""
+ proc set {args} {
+ return "set called with $args"
+ }
+ }
+ list $x \
+ [interp eval test_interp {useSet}] \
+ [interp delete test_interp]
+} {123 {set called with a 123} {}}
+test basic-10.2 {Tcl_DeleteCommandFromToken, deleting commands changes command epoch} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {rename p ""}
+ proc p {} {
+ return "global p"
+ }
+ namespace eval test_ns_basic {
+ proc p {} {
+ return "namespace p"
+ }
+ proc callP {} {
+ p
+ }
+ }
+ list [test_ns_basic::callP] \
+ [rename test_ns_basic::p ""] \
+ [test_ns_basic::callP]
+} {{namespace p} {} {global p}}
+test basic-10.3 {Tcl_DeleteCommandFromToken, delete imported cmds that refer to a deleted cmd} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {rename p ""}
+ namespace eval test_ns_basic {
+ namespace export p
+ proc p {} {return 42}
+ }
+ namespace eval test_ns_basic2 {
+ namespace import ::test_ns_basic::*
+ proc callP {} {
+ p
+ }
+ }
+ list [test_ns_basic2::callP] \
+ [info commands test_ns_basic2::*] \
+ [rename test_ns_basic::p ""] \
+ [catch {test_ns_basic2::callP} msg] $msg \
+ [info commands test_ns_basic2::*]
+} {42 {::test_ns_basic2::callP ::test_ns_basic2::p} {} 1 {invalid command name "p"} ::test_ns_basic2::callP}
+
+test basic-11.1 {TclObjInvoke, lookup of "unknown" command} {
+ catch {eval namespace delete [namespace children :: test_ns_*]}
+ catch {interp delete test_interp}
+ interp create test_interp
+ interp eval test_interp {
+ proc unknown {args} {
+ return "global unknown"
+ }
+ namespace eval test_ns_basic {
+ proc unknown {args} {
+ return "namespace unknown"
+ }
+ }
+ }
+ list [interp alias test_interp newAlias test_interp doesntExist] \
+ [catch {interp eval test_interp {newAlias}} msg] $msg \
+ [interp delete test_interp]
+} {newAlias 0 {global unknown} {}}
+
+test basic-12.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+ testcmdtrace tracetest {set stuff [info tclversion]}
+} {{info tclversion} {info tclversion} {set stuff [info tclversion]} {set stuff 8.0}}
+test basic-12.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {
+ testcmdtrace deletetest {set stuff [info tclversion]}
+} 8.0
+
+catch {eval namespace delete [namespace children :: test_ns_*]}
+catch {namespace delete george}
+catch {interp delete test_interp}
+catch {rename p ""}
+catch {rename q ""}
+catch {rename cmd ""}
+catch {rename value:at: ""}
+catch {unset x}
+set x 0
+unset x