Artifact
7fc113cfddd84ab2f9ffcfed888492f0487884cd:
Attachment "apply.test" to
ticket [944803ffff]
added by
msofer
2006-01-22 09:03:33.
# 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.7 2001/07/03 23:39:24 hobbs 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
