diff options
Diffstat (limited to 'tests/apply.test')
| -rw-r--r-- | tests/apply.test | 218 |
1 files changed, 218 insertions, 0 deletions
diff --git a/tests/apply.test b/tests/apply.test new file mode 100644 index 0000000..c000c6e --- /dev/null +++ b/tests/apply.test @@ -0,0 +1,218 @@ +# Commands covered: apply +# +# This file contains a collection of tests for one or more of the Tcl +# built-in commands. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. +# +# 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. +# +# RCS: @(#) $Id: apply.test,v 1.1 2006/02/01 19:26:02 dgp Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest + namespace import -force ::tcltest::* +} + +if {[info commands ::apply] eq {}} { + return +} + +# Tests for wrong number of arguments + +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} { + set lambda a + 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] + 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] + 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] + 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] + 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] + 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 +"apply $lambda"}} + + +# Tests for runtime errors in the lambda expression + +test apply-3.1 {non-existing namespace} { + set lambda [list x {set x 1} ::NONEXIST::FOR::SURE] + set res [catch {apply $lambda x} msg] + list $res $msg +} {1 {cannot find namespace "::::NONEXIST::FOR::SURE"}} + +test apply-3.2 {non-existing namespace} { + namespace eval ::NONEXIST::FOR::SURE {} + set lambda [list x {set x 1} ::NONEXIST::FOR::SURE] + apply $lambda x + namespace delete ::NONEXIST + set res [catch {apply $lambda x} msg] + list $res $msg +} {1 {cannot find namespace "::::NONEXIST::FOR::SURE"}} + +test apply-4.1 {error in arguments to lambda expression} { + set lambda [list x {set x 1}] + set res [catch {apply $lambda} msg] + list $res $msg +} {1 {wrong # args: should be "apply {x {set x 1}} x"}} + +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] + list $res $msg +} {1 {wrong # args: should be "apply {x {set x 1}} x"}} + +# Tests for correct execution; as the implementation is the same as that for +# procs, the general functionality is mostly tested elsewhere + +test apply-5.1 {info level} { + set lev [info level] + set lambda [list {} {info level}] + expr {[apply $lambda] - $lev} +} 1 + +test apply-5.2 {info level} { + set lambda [list {} {info level 0}] + apply $lambda +} {apply {{} {info level 0}}} + +test apply-5.3 {info level} { + set lambda [list args {info level 0}] + apply $lambda x y +} {apply {args {info level 0}} x y} + +# Tests for correct namespace scope + +namespace eval ::testApply { + set x 0 + proc testApply args {return testApply} +} + +test apply-6.1 {namespace access} { + set body {set x 1; set x} + list [apply [list args $body ::testApply]] $::testApply::x +} {1 0} + +test apply-6.2 {namespace access} { + set body {variable x; set x} + list [apply [list args $body ::testApply]] $::testApply::x +} {0 0} + +test apply-6.3 {namespace access} { + set body {variable x; set x 1} + list [apply [list args $body ::testApply]] $::testApply::x +} {1 1} + +test apply-6.3 {namespace access} { + set body {testApply} + apply [list args $body ::testApply] +} testApply + + +# Tests for correct argument treatment + +set applyBody { + set res {} + foreach v [info locals] { + if {$v eq "res"} continue + lappend res [list $v [set $v]] + } + set res +} + +test apply-7.1 {args treatment} { + apply [list args $applyBody] 1 2 3 +} {{args {1 2 3}}} + +test apply-7.2 {args treatment} { + apply [list {x args} $applyBody] 1 2 +} {{x 1} {args 2}} + +test apply-7.3 {args treatment} { + apply [list {x args} $applyBody] 1 2 3 +} {{x 1} {args {2 3}}} + +test apply-7.4 {default values} { + apply [list {{x 1} {y 2}} $applyBody] +} {{x 1} {y 2}} + +test apply-7.5 {default values} { + apply [list {{x 1} {y 2}} $applyBody] 3 4 +} {{x 3} {y 4}} + +test apply-7.6 {default values} { + apply [list {{x 1} {y 2}} $applyBody] 3 +} {{x 3} {y 2}} + +test apply-7.7 {default values} { + apply [list {x {y 2}} $applyBody] 1 +} {{x 1} {y 2}} + +test apply-7.8 {default values} { + apply [list {x {y 2}} $applyBody] 1 3 +} {{x 1} {y 3}} + +test apply-7.9 {default values} { + apply [list {x {y 2} args} $applyBody] 1 +} {{x 1} {y 2} {args {}}} + +test apply-7.10 {default values} { + apply [list {x {y 2} args} $applyBody] 1 3 +} {{x 1} {y 3} {args {}}} + +# Tests for the avoidance of recompilation + +# cleanup + +namespace delete testApply + +::tcltest::cleanupTests +return |