summaryrefslogtreecommitdiffstats
path: root/tests/interp.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/interp.test')
-rw-r--r--tests/interp.test179
1 files changed, 135 insertions, 44 deletions
diff --git a/tests/interp.test b/tests/interp.test
index da0c433..817ef99 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -5,21 +5,23 @@
# generates output for errors. No output means no errors were found.
#
# Copyright (c) 1995-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998 by Scriptics Corporation.
+# 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: @(#) $Id: interp.test,v 1.6 1999/02/03 02:58:41 stanton Exp $
+# RCS: @(#) $Id: interp.test,v 1.7 1999/04/16 00:47:29 stanton Exp $
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
# The set of hidden commands is platform dependent:
if {"$tcl_platform(platform)" == "macintosh"} {
- set hidden_cmds {beep cd echo exit fconfigure file glob load ls open pwd socket source}
+ set hidden_cmds {beep cd echo encoding exit fconfigure file glob load ls open pwd socket source}
} else {
- set hidden_cmds {cd exec exit fconfigure file glob load open pwd socket source}
+ set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source}
}
foreach i [interp slaves] {
@@ -40,7 +42,7 @@ test interp-1.3 {options for interp command} {
} ""
test interp-1.4 {options for interp command} {
list [catch {interp delete foo bar} msg] $msg
-} {1 {interpreter named "foo" not found}}
+} {1 {could not find interpreter "foo"}}
test interp-1.5 {options for interp command} {
list [catch {interp exists foo bar} msg] $msg
} {1 {wrong # args: should be "interp exists ?path?"}}
@@ -84,7 +86,7 @@ test interp-2.6 {basic interpreter creation} {
} d
test interp-2.7 {basic interpreter creation} {
list [catch {interp create -froboz} msg] $msg
-} {1 {bad option "-froboz": should be -safe}}
+} {1 {bad option "-froboz": must be -safe or --}}
test interp-2.8 {basic interpreter creation} {
interp create -- -froboz
} -froboz
@@ -100,17 +102,15 @@ test interp-2.11 {anonymous interps vs existing procs} {
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
- incr thenum
proc interp$thenum {} {}
set x [interp create]
regexp "interp(\[0-9]+)" $x dummy anothernum
- expr $anothernum - $thenum
+ expr $anothernum > $thenum
} 1
test interp-2.12 {anonymous interps vs existing procs} {
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy thenum
interp delete $x
- incr thenum
proc interp$thenum {} {}
set x [interp create -safe]
regexp "interp(\[0-9]+)" $x dummy anothernum
@@ -165,10 +165,10 @@ test interp-4.1 {testing interp delete} {
} ""
test interp-4.2 {testing interp delete} {
list [catch {interp delete nonexistent} msg] $msg
-} {1 {interpreter named "nonexistent" not found}}
+} {1 {could not find interpreter "nonexistent"}}
test interp-4.3 {testing interp delete} {
list [catch {interp delete x y z} msg] $msg
-} {1 {interpreter named "x" not found}}
+} {1 {could not find interpreter "x"}}
test interp-4.4 {testing interp delete} {
interp delete
} ""
@@ -188,10 +188,10 @@ test interp-4.7 {testing interp delete} {
interp create c1
interp create c2
list [catch {interp delete c1 c2 c3} msg] $msg
-} {1 {interpreter named "c3" not found}}
+} {1 {could not find interpreter "c3"}}
test interp-4.8 {testing interp delete} {
list [catch {interp delete {}} msg] $msg
-} {1 {interpreter named "" not found}}
+} {1 {cannot delete the current interpreter}}
foreach i [interp slaves] {
interp delete $i
@@ -1598,7 +1598,7 @@ test interp-22.5 {testing interp marktrusted} {
catch {a eval {interp marktrusted b}} msg
interp delete a
set msg
-} {"interp marktrusted" can only be invoked from a trusted interpreter}
+} {permission denied: safe interpreter cannot mark trusted}
test interp-22.6 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
@@ -1606,7 +1606,7 @@ test interp-22.6 {testing interp marktrusted} {
catch {a eval {b marktrusted}} msg
interp delete a
set msg
-} {"b marktrusted" can only be invoked from a trusted interpreter}
+} {permission denied: safe interpreter cannot mark trusted}
test interp-22.7 {testing interp marktrusted} {
catch {interp delete a}
interp create a -safe
@@ -1666,7 +1666,7 @@ test interp-23.1 {testing hiding vs aliases} {
interp delete a
set l
} {{} bar {} bar bar {} {}}
-test interp-23.2 {testing hiding vs aliases} {pc || unix} {
+test interp-23.2 {testing hiding vs aliases} {unixOrPc} {
catch {interp delete a}
interp create a -safe
set l ""
@@ -1682,7 +1682,7 @@ test interp-23.2 {testing hiding vs aliases} {pc || unix} {
lappend l [lsort [interp hidden a]]
interp delete a
set l
-} {{cd exec exit fconfigure file glob load open pwd socket source} bar {cd exec exit fconfigure file glob load open pwd socket source} bar {bar cd exec exit fconfigure file glob load open pwd socket source} {} {cd exec exit fconfigure file glob load open pwd socket source}}
+} {{cd encoding exec exit fconfigure file glob load open pwd socket source} bar {cd encoding exec exit fconfigure file glob load open pwd socket source} bar {bar cd encoding exec exit fconfigure file glob load open pwd socket source} {} {cd encoding exec exit fconfigure file glob load open pwd socket source}}
test interp-23.3 {testing hiding vs aliases} {macOnly} {
catch {interp delete a}
@@ -1933,31 +1933,94 @@ test interp-25.1 {testing aliasing of string commands} {
} ""
+#
# Interps result transmission
-test interp-26.1 {result code transmission 1} {knownBug} {
- # This test currently fails ! (only ok/error are passed, not the other
- # codes). Fixing the code is thus needed... -- dl
- # (the only other acceptable result list would be
- # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
- # test that all the possibles error codes from Tcl get passed
+#
+
+test interp-26.1 {result code transmission : interp eval direct} {
+ # Test that all the possibles error codes from Tcl get passed up
+ # from the slave interp's context to the master, even though the
+ # slave nominally thinks the command is running at the root level.
+
catch {interp delete a}
interp create a
- interp eval a {proc ret {code} {return -code $code $code}}
set res {}
# use a for so if a return -code break 'escapes' we would notice
for {set code -1} {$code<=5} {incr code} {
- lappend res [catch {interp eval a ret $code} msg]
+ lappend res [catch {interp eval a return -code $code} msg]
}
interp delete a
set res
} {-1 0 1 2 3 4 5}
-test interp-26.2 {result code transmission 2} {knownBug} {
- # This test currently fails ! (error is cleared)
- # Code fixing is needed... -- dl
- # (the only other acceptable result list would be
- # {-1 0 1 0 3 4 5} because of the way return -code return(=2) works)
- # test that all the possibles error codes from Tcl get passed
+
+test interp-26.2 {result code transmission : interp eval indirect} {
+ # retcode == 2 == return is special
+ catch {interp delete a}
+ interp create a
+ interp eval a {proc retcode {code} {return -code $code ret$code}}
+ set res {}
+ # use a for so if a return -code break 'escapes' we would notice
+ for {set code -1} {$code<=5} {incr code} {
+ lappend res [catch {interp eval a retcode $code} msg] $msg
+ }
+ interp delete a
+ set res
+} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
+
+test interp-26.3 {result code transmission : aliases} {
+ # Test that all the possibles error codes from Tcl get passed up
+ # from the slave interp's context to the master, even though the
+ # slave nominally thinks the command is running at the root level.
+
+ catch {interp delete a}
+ interp create a
+ set res {}
+ proc MyTestAlias {code} {
+ return -code $code ret$code
+ }
+ interp alias a Test {} MyTestAlias
+ for {set code -1} {$code<=5} {incr code} {
+ lappend res [interp eval a [list catch [list Test $code] msg]]
+ }
+ interp delete a
+ set res
+} {-1 0 1 2 3 4 5}
+
+test interp-26.4 {result code transmission: invoke hidden direct--bug 1637} \
+ {knownBug} {
+ # The known bug is that code 2 is returned, not the -code argument
+ catch {interp delete a}
+ interp create a
+ set res {}
+ interp hide a return
+ for {set code -1} {$code<=5} {incr code} {
+ lappend res [catch {interp invokehidden a return -code $code ret$code}]
+ }
+ interp delete a
+ set res
+} {-1 0 1 2 3 4 5}
+
+test interp-26.5 {result code transmission: invoke hidden indirect--bug 1637} \
+ {knownBug} {
+ # The known bug is that the break and continue should raise errors
+ # that they are used outside a loop.
+ catch {interp delete a}
+ interp create a
+ set res {}
+ interp eval a {proc retcode {code} {return -code $code ret$code}}
+ interp hide a retcode
+ for {set code -1} {$code<=5} {incr code} {
+ lappend res [catch {interp invokehidden a retcode $code} msg] $msg
+ }
+ interp delete a
+ set res
+} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
+
+test interp-26.6 {result code transmission: all combined--bug 1637} \
+ {knownBug} {
+ # Test that all the possibles error codes from Tcl get passed
+ # In both directions. This doesn't work.
set interp [interp create];
proc MyTestAlias {interp args} {
global aliasTrace;
@@ -1968,17 +2031,22 @@ test interp-26.2 {result code transmission 2} {knownBug} {
interp hide $interp $c;
interp alias $interp $c {} MyTestAlias $interp $c;
}
- interp eval $interp {proc ret {code} {return -code $code $code}}
+ interp eval $interp {proc ret {code} {return -code $code ret$code}}
set res {}
set aliasTrace {}
for {set code -1} {$code<=5} {incr code} {
- lappend res [catch {interp eval $interp ret $code} msg]
+ lappend res [catch {interp eval $interp ret $code} msg] $msg
}
interp delete $interp;
- list $res
-} {-1 0 1 2 3 4 5}
+ set res
+} {-1 ret-1 0 ret0 1 ret1 0 ret2 3 ret3 4 ret4 5 ret5}
+
+# Some tests might need to be added to check for difference between
+# toplevel and non toplevel evals.
+
+# End of return code transmission section
-test interp-26.3 {errorInfo transmission : regular interps} {
+test interp-26.7 {errorInfo transmission: regular interps} {
set interp [interp create];
proc MyError {secret} {
return -code error "msg"
@@ -1993,14 +2061,15 @@ test interp-26.3 {errorInfo transmission : regular interps} {
} {msg
while executing
"MyError "some secret""
- (procedure "test" line 2)
+ (procedure "MyTestAlias" line 2)
invoked from within
-"catch test"}
+"test"}
-test interp-26.4 {errorInfo transmission : safe interps} {knownBug} {
+test interp-26.8 {errorInfo transmission: safe interps--bug 1637} {knownBug} {
# this test fails because the errorInfo is fully transmitted
- # whether the interp is safe or not. this is maybe a feature
- # and not a bug.
+ # whether the interp is safe or not. The errorInfo should never
+ # report data from the master interpreter because it could
+ # contain sensitive information.
set interp [interp create -safe];
proc MyError {secret} {
return -code error "msg"
@@ -2014,7 +2083,7 @@ test interp-26.4 {errorInfo transmission : safe interps} {knownBug} {
set res
} {msg
while executing
-"catch test"}
+"test"}
# Interps & Namespaces
test interp-27.1 {interp aliases & namespaces} {
@@ -2163,7 +2232,7 @@ test interp-27.4 {interp aliases & namespaces} {
# namespace delete mfoo;
# interp delete $i;
# set res
-# } {{slave bar called (foo-slave) (bar test1) (::test) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}
+# } {{slave bar called (foo-slave) (bar test1) (::tcltest) (::foo) (test1)} {master bar called (foo-master) (::mfoo) (test2)} {slave bar called (foo-slave) (test::bar test2) (::) (::foo) (test2)}}
#test interp-27.8 {hiding, namespaces and integrity} {
# namespace eval foo {
@@ -2264,6 +2333,28 @@ test interp-30.1 {deletion of aliases inside namespaces} {
$i alias ns::cmd {}
} {}
+test interp-31.1 {alias invocation scope} {
+ proc mySet {varName value} {
+ upvar 1 $varName localVar
+ set localVar $value
+ }
+
+ interp alias {} myNewSet {} mySet
+ proc testMyNewSet {value} {
+ myNewSet a $value
+ return $a
+ }
+ catch {unset a}
+ set result [testMyNewSet "ok"]
+ rename testMyNewSet {}
+ rename mySet {}
+ rename myNewSet {}
+ set result
+} ok
+
+# cleanup
foreach i [interp slaves] {
interp delete $i
}
+::tcltest::cleanupTests
+return