diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/apply.test | 218 | ||||
| -rw-r--r-- | tests/proc-old.test | 6 | ||||
| -rw-r--r-- | tests/proc.test | 6 |
3 files changed, 224 insertions, 6 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 diff --git a/tests/proc-old.test b/tests/proc-old.test index 860279e..fe33ef4 100644 --- a/tests/proc-old.test +++ b/tests/proc-old.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: proc-old.test,v 1.13 2004/10/29 15:39:10 dkf Exp $ +# RCS: @(#) $Id: proc-old.test,v 1.14 2006/02/01 19:26:02 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -274,10 +274,10 @@ test proc-old-5.4 {error conditions} { } {1 {unmatched open brace in list}} test proc-old-5.5 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg -} {1 {procedure "tproc" has argument with no name}} +} {1 {argument with no name}} test proc-old-5.6 {error conditions} { list [catch {proc tproc {{} y} {return foo}} msg] $msg -} {1 {procedure "tproc" has argument with no name}} +} {1 {argument with no name}} test proc-old-5.7 {error conditions} { list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg } {1 {too many fields in argument specifier "x 1 2"}} diff --git a/tests/proc.test b/tests/proc.test index bef0948..49f9a7b 100644 --- a/tests/proc.test +++ b/tests/proc.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: proc.test,v 1.17 2004/09/22 15:48:23 msofer Exp $ +# RCS: @(#) $Id: proc.test,v 1.18 2006/02/01 19:26:02 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -101,12 +101,12 @@ test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array e set z [expr $a(1)+$a(2)] puts "$z=z, $a(1)=$a(1)" }} msg] $msg -} {1 {procedure "p" has formal parameter "a(1)" that is an array element}} +} {1 {formal parameter "a(1)" is an array element}} test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} { catch {rename p ""} list [catch {proc p {b:a b::a} { }} msg] $msg -} {1 {procedure "p" has formal parameter "b::a" that is not a simple name}} +} {1 {formal parameter "b::a" is not a simple name}} test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} { catch {namespace delete {expand}[namespace children :: test_ns_*]} |