diff options
Diffstat (limited to 'tests/apply.test')
| -rw-r--r-- | tests/apply.test | 114 |
1 files changed, 53 insertions, 61 deletions
diff --git a/tests/apply.test b/tests/apply.test index 24b27cc..31fe918 100644 --- a/tests/apply.test +++ b/tests/apply.test @@ -4,69 +4,72 @@ # built-in commands. Sourcing this file into Tcl runs the tests and # generates output for errors. No output means no errors were found. # -# Copyright © 1991-1993 The Regents of the University of California. -# Copyright © 1994-1996 Sun Microsystems, Inc. -# Copyright © 1998-1999 Scriptics Corporation. -# Copyright © 2005-2006 Miguel Sofer +# Copyright (c) 1991-1993 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# Copyright (c) 2005-2006 Miguel Sofer # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. -if {"::tcltest" ni [namespace children]} { - package require tcltest 2.5 +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2.2 namespace import -force ::tcltest::* } -::tcltest::loadTestedCommands -catch [list package require -exact tcl::test [info patchlevel]] if {[info commands ::apply] eq {}} { return } testConstraint memory [llength [info commands memory]] -testConstraint applylambda [llength [info commands testapplylambda]] - # Tests for wrong number of arguments -test apply-1.1 {not enough arguments} -returnCodes error -body { - apply -} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"} +test apply-1.1 {too few arguments} { + set res [catch apply msg] + list $res $msg +} {1 {wrong # args: should be "apply lambdaExpr ?arg1 arg2 ...?"}} # Tests for malformed lambda -test apply-2.0 {malformed lambda} -returnCodes error -body { +test apply-2.0 {malformed lambda} { set lambda a - apply $lambda -} -result {can't interpret "a" as a lambda expression} -test apply-2.1 {malformed lambda} -returnCodes error -body { + set res [catch {apply $lambda} msg] + list $res $msg +} {1 {can't interpret "a" as a lambda expression}} +test apply-2.1 {malformed lambda} { set lambda [list a b c d] - apply $lambda -} -result {can't interpret "a b c d" as a lambda expression} + set res [catch {apply $lambda} msg] + list $res $msg +} {1 {can't interpret "a b c d" as a lambda expression}} test apply-2.2 {malformed lambda} { set lambda [list {{}} boo] - list [catch {apply $lambda} msg] $msg $::errorInfo + set res [catch {apply $lambda} msg] + list $res $msg $::errorInfo } {1 {argument with no name} {argument with no name (parsing lambda expression "{{}} boo") invoked from within "apply $lambda"}} test apply-2.3 {malformed lambda} { set lambda [list {{a b c}} boo] - list [catch {apply $lambda} msg] $msg $::errorInfo + set res [catch {apply $lambda} msg] + list $res $msg $::errorInfo } {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c" (parsing lambda expression "{{a b c}} boo") invoked from within "apply $lambda"}} test apply-2.4 {malformed lambda} { set lambda [list a(1) boo] - list [catch {apply $lambda} msg] $msg $::errorInfo + set res [catch {apply $lambda} msg] + list $res $msg $::errorInfo } {1 {formal parameter "a(1)" is an array element} {formal parameter "a(1)" is an array element (parsing lambda expression "a(1) boo") invoked from within "apply $lambda"}} test apply-2.5 {malformed lambda} { set lambda [list a::b boo] - list [catch {apply $lambda} msg] $msg $::errorInfo + set res [catch {apply $lambda} msg] + list $res $msg $::errorInfo } {1 {formal parameter "a::b" is not a simple name} {formal parameter "a::b" is not a simple name (parsing lambda expression "a::b boo") invoked from within @@ -95,27 +98,29 @@ test apply-3.4 {non-existing namespace} -body { apply $lambda x } -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found} -test apply-4.1 {error in arguments to lambda expression} -body { +test apply-4.1 {error in arguments to lambda expression} { set lambda [list x {set x 1}] - apply $lambda -} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"} -test apply-4.2 {error in arguments to lambda expression} -body { + set res [catch {apply $lambda} msg] + list $res $msg +} {1 {wrong # args: should be "apply lambdaExpr x"}} +test apply-4.2 {error in arguments to lambda expression} { set lambda [list x {set x 1}] - apply $lambda a b -} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"} -test apply-4.3 {error in arguments to lambda expression} -body { - interp alias {} foo {} ::apply [list x {set x 1}] - foo a b -} -cleanup { - rename foo {} -} -returnCodes error -result {wrong # args: should be "foo x"} -test apply-4.4 {error in arguments to lambda expression} -body { - interp alias {} foo {} ::apply [list x {set x 1}] a - foo b -} -cleanup { - rename foo {} -} -returnCodes error -result {wrong # args: should be "foo"} -test apply-4.5 {error in arguments to lambda expression} -body { + set res [catch {apply $lambda a b} msg] + list $res $msg +} {1 {wrong # args: should be "apply lambdaExpr 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}} @@ -131,10 +136,9 @@ test apply-4.5 {error in arguments to lambda expression} -body { } method ::bar boo x {return "[expr {$x*$x}] - $self"} } - bar boo -} -cleanup { - namespace delete ::a -} -returnCodes error -result {wrong # args: should be "bar boo x"} + 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}] @@ -232,7 +236,7 @@ test apply-8.3 {args treatment} { apply [list {x args} $applyBody] 1 2 3 } {{x 1} {args {2 3}}} test apply-8.4 {default values} { - apply [list {{x 1} {y 2}} $applyBody] + apply [list {{x 1} {y 2}} $applyBody] } {{x 1} {y 2}} test apply-8.5 {default values} { apply [list {{x 1} {y 2}} $applyBody] 3 4 @@ -261,7 +265,7 @@ test apply-9.1 {leaking internal rep} -setup { lindex $lines 3 3 } set lam [list {} {set a 1}] -} -constraints {memory} -body { +} -constraints memory -body { set end [getbytes] for {set i 0} {$i < 5} {incr i} { ::apply [lrange $lam 0 end] @@ -310,23 +314,11 @@ test apply-9.3 {leaking internal rep} -setup { unset -nocomplain end i x tmp leakedBytes } -result 0 -# Tests for specific bugs -test apply-10.1 {Test for precompiled bytecode body} -constraints { - applylambda -} -body { - testapplylambda -} -result 42 - # Tests for the avoidance of recompilation - + # cleanup namespace delete testApply ::tcltest::cleanupTests return - -# Local Variables: -# mode: tcl -# fill-column: 78 -# End: |