merged tcl 8.1 branch back into the main trunk

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