diff options
| -rw-r--r-- | ChangeLog | 3 | ||||
| -rw-r--r-- | tests/apply.test | 38 | ||||
| -rw-r--r-- | tests/info.test | 21 |
3 files changed, 59 insertions, 3 deletions
@@ -1,5 +1,8 @@ 2006-10-24 Miguel Sofer <msofer@users.sf.net> + * tests/info.test (info-9.11-12): tests for [Bug 1577492] + * tests/apply.test (apply-4.3-5): tests for [Bug 1574835] + * generic/tclProc.c (ObjInterpProcEx): disable itcl hacks for calls from ApplyObjCmd (islambda==1), as they mess apply's error messages [Bug 1583266] diff --git a/tests/apply.test b/tests/apply.test index 563210c..e639638 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: apply.test,v 1.7 2006/10/16 20:36:19 msofer Exp $ +# RCS: @(#) $Id: apply.test,v 1.8 2006/10/24 23:13:07 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -123,10 +123,44 @@ test apply-4.1 {error in arguments to lambda expression} { test apply-4.2 {error in arguments to lambda expression} { set lambda [list x {set x 1}] - set res [catch {apply $lambda x y} msg] + set res [catch {apply $lambda a b} msg] list $res $msg } {1 {wrong # args: should be "apply {x {set x 1}} x"}} +test apply-4.3 {error in arguments to lambda expression} { + set lambda [list x {set x 1}] + interp alias {} foo {} ::apply $lambda + set res [catch {foo a b} msg] + list $res $msg [rename foo {}] +} {1 {wrong # args: should be "foo x"} {}} + +test apply-4.4 {error in arguments to lambda expression} { + set lambda [list x {set x 1}] + interp alias {} foo {} ::apply $lambda a + set res [catch {foo b} msg] + list $res $msg [rename foo {}] +} {1 {wrong # args: should be "foo"} {}} + +test apply-4.5 {error in arguments to lambda expression} { + set lambda [list x {set x 1}] + namespace eval a { + namespace ensemble create -command ::bar -map {id {::a::const foo}} + proc const val { return $val } + proc alias {object slot = command args} { + set map [namespace ensemble configure $object -map] + dict set map $slot [linsert $args 0 $command] + namespace ensemble configure $object -map $map + } + proc method {object name params body} { + set params [linsert $params 0 self] + alias $object $name = ::apply [list $params $body] $object + } + method ::bar boo x {return "[expr {$x*$x}] - $self"} + } + set res [catch {bar boo} msg] + list $res $msg [namespace delete ::a] +} {1 {wrong # args: should be "bar boo x"} {}} + test apply-5.1 {runtime error in lambda expression} { set lambda [list {} {error foo}] set res [catch {apply $lambda}] diff --git a/tests/info.test b/tests/info.test index 8a8417e..1a4f1cd 100644 --- a/tests/info.test +++ b/tests/info.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.37 2006/10/20 15:16:47 dkf Exp $ +# RCS: @(#) $Id: info.test,v 1.38 2006/10/24 23:13:07 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -357,6 +357,25 @@ test info-9.10 {info level option, namespaces} { namespace delete t set msg } {namespace eval t {info level 0}} +test info-9.11 {info level option, aliases} -setup { + proc w {x y z} {info level 0} + interp alias {} a {} w a b +} -body { + a c +} -cleanup { + rename a {} + rename w {} +} -result {a c} +test info-9.12 {info level option, ensembles} -setup { + proc w {x y z} {info level 0} + namespace ensemble create -command a -map {foo ::w} +} -body { + a foo 1 2 3 +} -cleanup { + rename a {} + rename w {} +} -result {a foo 1 2 3} + set savedLibrary $tcl_library test info-10.1 {info library option} { |