# 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.
# Copyright (c) 1998-1999 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: @(#) basic.test,v 1.5 2003/01/21 19:40:13 hunt Exp
#
package require tcltest 2
namespace import -force ::tcltest::*
testConstraint testcmdtoken [llength [info commands testcmdtoken]]
testConstraint testcmdtrace [llength [info commands testcmdtrace]]
testConstraint testcreatecommand [llength [info commands testcreatecommand]]
testConstraint exec [llength [info commands exec]]
# This variable needs to be changed when the major or minor version number for
# Tcl changes.
set tclvers 8.4
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 {TclHideUnsafeCommands} {emptyTest} {
} {}
test basic-3.1 {Tcl_CallWhenDeleted: see dcall.test} {emptyTest} {
} {}
test basic-4.1 {Tcl_DontCallWhenDeleted: see dcall.test} {emptyTest} {
} {}
test basic-5.1 {Tcl_SetAssocData: see assoc.test} {emptyTest} {
} {}
test basic-6.1 {Tcl_DeleteAssocData: see assoc.test} {emptyTest} {
} {}
test basic-7.1 {Tcl_GetAssocData: see assoc.test} {emptyTest} {
} {}
test basic-8.1 {Tcl_InterpDeleted} {emptyTest} {
} {}
test basic-9.1 {Tcl_DeleteInterp: see interp.test} {emptyTest} {
} {}
test basic-10.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-11.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-12.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-12.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-13.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-13.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}
test basic-14.1 {Tcl_CreateCommand, new cmd goes into a namespace specified in its name, if any} {testcreatecommand} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [testcreatecommand create] \
[test_ns_basic::createdcommand] \
[testcreatecommand delete]
} {{} {CreatedCommandProc in ::test_ns_basic} {}}
test basic-14.2 {Tcl_CreateCommand, namespace code ignore single ":"s in middle or end of names} {testcreatecommand} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename value:at: ""}
list [testcreatecommand create2] \
[value:at:] \
[testcreatecommand delete2]
} {{} {CreatedCommandProc2 in ::} {}}
test basic-15.1 {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-16.1 {TclInvokeStringCommand} {emptyTest} {
} {}
test basic-17.1 {TclInvokeObjCommand} {emptyTest} {
} {}
test basic-18.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-18.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-18.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-18.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-18.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-18.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-19.1 {Tcl_SetCommandInfo} {emptyTest} {
} {}
test basic-20.1 {Tcl_GetCommandInfo, names for commands created inside namespaces} {testcmdtoken} {
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-20.2 {Tcl_GetCommandInfo, names for commands created outside namespaces} {testcmdtoken} {
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-21.1 {Tcl_GetCommandName} {emptyTest} {
} {}
test basic-22.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-23.1 {Tcl_DeleteCommand} {emptyTest} {
} {}
test basic-24.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-24.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-24.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-25.1 {TclCleanupCommand} {emptyTest} {
} {}
test basic-26.1 {Tcl_EvalObj: preserve object while evaling it} {
# If object isn't preserved, errorInfo would be set to
# "foo\n while executing\n\"garbage bytes\"" because the object's
# string would have been freed, leaving garbage bytes for the error
# message.
proc bgerror {args} {set ::x $::errorInfo}
set fName [makeFile {} test1]
set f [open $fName w]
fileevent $f writable "fileevent $f writable {}; error foo"
set x {}
vwait x
close $f
removeFile test1
rename bgerror {}
set x
} "foo\n while executing\n\"error foo\""
test basic-27.1 {Tcl_ExprLong} {emptyTest} {
} {}
test basic-28.1 {Tcl_ExprDouble} {emptyTest} {
} {}
test basic-29.1 {Tcl_ExprBoolean} {emptyTest} {
} {}
test basic-30.1 {Tcl_ExprLongObj} {emptyTest} {
} {}
test basic-31.1 {Tcl_ExprDoubleObj} {emptyTest} {
} {}
test basic-32.1 {Tcl_ExprBooleanObj} {emptyTest} {
} {}
test basic-33.1 {TclInvoke} {emptyTest} {
} {}
test basic-34.1 {TclGlobalInvoke} {emptyTest} {
} {}
test basic-35.1 {TclObjInvokeGlobal} {emptyTest} {
} {}
test basic-36.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-37.1 {Tcl_ExprString: see expr.test} {emptyTest} {
} {}
test basic-38.1 {Tcl_ExprObj} {emptyTest} {
} {}
test basic-39.1 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace tracetest {set stuff [expr 14 + 16]}
} {{expr 14 + 16} {expr 14 + 16} {set stuff [expr 14 + 16]} {set stuff 30}}
test basic-39.2 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace tracetest {set stuff [info tclversion]}
} [list {info tclversion} {info tclversion} {set stuff [info tclversion]} "set stuff $tclvers"]
test basic-39.3 {Tcl_CreateTrace, correct command and argc/argv arguments of trace proc} {testcmdtrace} {
testcmdtrace deletetest {set stuff [info tclversion]}
} $tclvers
test basic-39.4 {Tcl_CreateTrace, check that tracing doesn't cause memory faults} {testcmdtrace} {
# Note that the proc call is the same as the variable name, and that
# the call can be direct or indirect by way of another procedure
proc tracer {args} {}
proc tracedLoop {level} {
incr level
tracer
foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}
}
testcmdtrace tracetest {tracedLoop 0}
} {{tracedLoop 0} {tracedLoop 0} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {1 2} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}} {tracedLoop $level} {tracedLoop 1} {incr level} {incr level} tracer {tracer} {expr {$level==1 ? {1 2} : {}}} {expr {$level==1 ? {1 2} : {}}} {foreach tracer [expr {$level==1 ? {1 2} : {}}] {tracedLoop $level}} {foreach tracer {} {tracedLoop $level}}}
catch {rename tracer {}}
catch {rename tracedLoop {}}
test basic-39.5 {Tcl_CreateObjTrace, status return TCL_ERROR} {testcmdtrace} {
proc Error { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {Error $x}} result] [set result]
} {1 {Error $x}}
test basic-39.6 {Tcl_CreateObjTrace, status return TCL_RETURN} {testcmdtrace} {
proc Return { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {Return $x}} result] [set result]
} {2 {}}
test basic-39.7 {Tcl_CreateObjTrace, status return TCL_BREAK} {testcmdtrace} {
proc Break { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {Break $x}} result] [set result]
} {3 {}}
test basic-39.8 {Tcl_CreateObjTrace, status return TCL_CONTINUE} {testcmdtrace} {
proc Continue { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {Continue $x}} result] [set result]
} {4 {}}
test basic-39.9 {Tcl_CreateObjTrace, status return unknown} {testcmdtrace} {
proc OtherStatus { args } { error "Shouldn't get here" }
set x 1;
list [catch {testcmdtrace resulttest {OtherStatus $x}} result] [set result]
} {6 {}}
test basic-40.1 {Tcl_DeleteTrace} {emptyTest} {
# the above tests have tested Tcl_DeleteTrace
} {}
test basic-41.1 {Tcl_AddErrorInfo} {emptyTest} {
} {}
test basic-42.1 {Tcl_AddObjErrorInfo} {emptyTest} {
} {}
test basic-43.1 {Tcl_VarEval} {emptyTest} {
} {}
test basic-44.1 {Tcl_GlobalEval} {emptyTest} {
} {}
test basic-45.1 {Tcl_SetRecursionLimit: see interp.test} {emptyTest} {
} {}
test basic-46.1 {Tcl_AllowExceptions: exception return not allowed} {stdio} {
catch {close $f}
set res [catch {
set f [open |[list [interpreter]] w+]
fconfigure $f -buffering line
puts $f {fconfigure stdout -buffering line}
puts $f continue
puts $f {puts $errorInfo}
puts $f {puts DONE}
set newMsg {}
set msg {}
while {$newMsg != "DONE"} {
set newMsg [gets $f]
append msg "${newMsg}\n"
}
close $f
} error]
list $res $msg
} {1 {invoked "continue" outside of a loop
while executing
"continue
"
DONE
}}
test basic-46.2 {Tcl_AllowExceptions: exception return not allowed} {exec} {
set fName [makeFile {
puts hello
break
} BREAKtest]
set res [list [catch {exec [interpreter] $fName} msg] $msg]
removeFile BREAKtest
regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
set res
} {1 {hello
invoked "break" outside of a loop
while executing
"break"
(file "BREAKtest" line 3)}}
test basic-46.3 {Tcl_AllowExceptions: exception return not allowed} {exec} {
set fName [makeFile {
interp alias {} patch {} info patchlevel
patch
break
} BREAKtest]
set res [list [catch {exec [interpreter] $fName} msg] $msg]
removeFile BREAKtest
regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
set res
} {1 {invoked "break" outside of a loop
while executing
"break"
(file "BREAKtest" line 4)}}
test basic-46.4 {Tcl_AllowExceptions: exception return not allowed} {exec} {
set fName [makeFile {
foo [set a 1] [break]
} BREAKtest]
set res [list [catch {exec [interpreter] $fName} msg] $msg]
removeFile BREAKtest
regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
set res
} {1 {invoked "break" outside of a loop
while executing
"break"
invoked from within
"foo [set a 1] [break]"
(file "BREAKtest" line 2)}}
test basic-46.5 {Tcl_AllowExceptions: exception return not allowed} {exec} {
set fName [makeFile {
return -code return
} BREAKtest]
set res [list [catch {exec [interpreter] $fName} msg] $msg]
removeFile BREAKtest
regsub {"[^ ]*BREAKtest"} $res {"BREAKtest"} res
set res
} {1 {command returned bad code: 2
while executing
"return -code return"
(file "BREAKtest" line 2)}}
# cleanup
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}
::tcltest::cleanupTests
return