1# Commands covered:  apply
2#
3# This file contains a collection of tests for one or more of the Tcl
4# built-in commands.  Sourcing this file into Tcl runs the tests and
5# generates output for errors.  No output means no errors were found.
6#
7# Copyright © 1991-1993 The Regents of the University of California.
8# Copyright © 1994-1996 Sun Microsystems, Inc.
9# Copyright © 1998-1999 Scriptics Corporation.
10# Copyright © 2005-2006 Miguel Sofer
11#
12# See the file "license.terms" for information on usage and redistribution
13# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14
15if {"::tcltest" ni [namespace children]} {
16    package require tcltest 2.5
17    namespace import -force ::tcltest::*
18}
19
20if {[info commands ::apply] eq {}} {
21    return
22}
23
24testConstraint memory [llength [info commands memory]]
25
26# Tests for wrong number of arguments
27
28test apply-1.1 {not enough arguments} -returnCodes error -body {
29    apply
30} -result {wrong # args: should be "apply lambdaExpr ?arg ...?"}
31
32# Tests for malformed lambda
33
34test apply-2.0 {malformed lambda} -returnCodes error -body {
35    set lambda a
36    apply $lambda
37} -result {can't interpret "a" as a lambda expression}
38test apply-2.1 {malformed lambda} -returnCodes error -body {
39    set lambda [list a b c d]
40    apply $lambda
41} -result {can't interpret "a b c d" as a lambda expression}
42test apply-2.2 {malformed lambda} {
43    set lambda [list {{}} boo]
44    list [catch {apply $lambda} msg] $msg $::errorInfo
45} {1 {argument with no name} {argument with no name
46    (parsing lambda expression "{{}} boo")
47    invoked from within
48"apply $lambda"}}
49test apply-2.3 {malformed lambda} {
50    set lambda [list {{a b c}} boo]
51    list [catch {apply $lambda} msg] $msg $::errorInfo
52} {1 {too many fields in argument specifier "a b c"} {too many fields in argument specifier "a b c"
53    (parsing lambda expression "{{a b c}} boo")
54    invoked from within
55"apply $lambda"}}
56test apply-2.4 {malformed lambda} {
57    set lambda [list a(1) boo]
58    list [catch {apply $lambda} msg] $msg $::errorInfo
59} {1 {formal parameter "a(1)" is an array element} {formal parameter "a(1)" is an array element
60    (parsing lambda expression "a(1) boo")
61    invoked from within
62"apply $lambda"}}
63test apply-2.5 {malformed lambda} {
64    set lambda [list a::b boo]
65    list [catch {apply $lambda} msg] $msg $::errorInfo
66} {1 {formal parameter "a::b" is not a simple name} {formal parameter "a::b" is not a simple name
67    (parsing lambda expression "a::b boo")
68    invoked from within
69"apply $lambda"}}
70
71# Tests for runtime errors in the lambda expression
72
73test apply-3.1 {non-existing namespace} -body {
74    apply [list x {set x 1} ::NONEXIST::FOR::SURE] x
75} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
76test apply-3.2 {non-existing namespace} -body {
77    namespace eval ::NONEXIST::FOR::SURE {}
78    set lambda [list x {set x 1} ::NONEXIST::FOR::SURE]
79    apply $lambda x
80    namespace delete ::NONEXIST
81    apply $lambda x
82} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
83test apply-3.3 {non-existing namespace} -body {
84    apply [list x {set x 1} NONEXIST::FOR::SURE] x
85} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
86test apply-3.4 {non-existing namespace} -body {
87    namespace eval ::NONEXIST::FOR::SURE {}
88    set lambda [list x {set x 1} NONEXIST::FOR::SURE]
89    apply $lambda x
90    namespace delete ::NONEXIST
91    apply $lambda x
92} -returnCodes error -result {namespace "::NONEXIST::FOR::SURE" not found}
93
94test apply-4.1 {error in arguments to lambda expression} -body {
95    set lambda [list x {set x 1}]
96    apply $lambda
97} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"}
98test apply-4.2 {error in arguments to lambda expression} -body {
99    set lambda [list x {set x 1}]
100    apply $lambda a b
101} -returnCodes error -result {wrong # args: should be "apply lambdaExpr x"}
102test apply-4.3 {error in arguments to lambda expression} -body {
103    interp alias {} foo {} ::apply [list x {set x 1}]
104    foo a b
105} -cleanup {
106    rename foo {}
107} -returnCodes error -result {wrong # args: should be "foo x"}
108test apply-4.4 {error in arguments to lambda expression} -body {
109    interp alias {} foo {} ::apply [list x {set x 1}] a
110    foo b
111} -cleanup {
112    rename foo {}
113} -returnCodes error -result {wrong # args: should be "foo"}
114test apply-4.5 {error in arguments to lambda expression} -body {
115    set lambda [list x {set x 1}]
116    namespace eval a {
117	namespace ensemble create -command ::bar -map {id {::a::const foo}}
118	proc const val { return $val }
119	proc alias {object slot = command args} {
120	    set map [namespace ensemble configure $object -map]
121	    dict set map $slot [linsert $args 0 $command]
122	    namespace ensemble configure $object -map $map
123	}
124	proc method {object name params body} {
125	    set params [linsert $params 0 self]
126	    alias $object $name = ::apply [list $params $body] $object
127	}
128	method ::bar boo x {return "[expr {$x*$x}] - $self"}
129    }
130    bar boo
131} -cleanup {
132    namespace delete ::a
133} -returnCodes error -result {wrong # args: should be "bar boo x"}
134
135test apply-5.1 {runtime error in lambda expression} {
136    set lambda [list {} {error foo}]
137    set res [catch {apply $lambda}]
138    list $res $::errorInfo
139} {1 {foo
140    while executing
141"error foo"
142    (lambda term "{} {error foo}" line 1)
143    invoked from within
144"apply $lambda"}}
145
146# Tests for correct execution; as the implementation is the same as that for
147# procs, the general functionality is mostly tested elsewhere
148
149test apply-6.1 {info level} {
150    set lev [info level]
151    set lambda [list {} {info level}]
152    expr {[apply $lambda] - $lev}
153} 1
154test apply-6.2 {info level} {
155    set lambda [list {} {info level 0}]
156    apply $lambda
157} {apply {{} {info level 0}}}
158test apply-6.3 {info level} {
159    set lambda [list args {info level 0}]
160    apply $lambda x y
161} {apply {args {info level 0}} x y}
162
163# Tests for correct namespace scope
164
165namespace eval ::testApply {
166    proc testApply args {return testApply}
167}
168
169test apply-7.1 {namespace access} {
170    set ::testApply::x 0
171    set body {set x 1; set x}
172    list [apply [list args $body ::testApply]] $::testApply::x
173} {1 0}
174test apply-7.2 {namespace access} {
175    set ::testApply::x 0
176    set body {variable x; set x}
177    list [apply [list args $body ::testApply]] $::testApply::x
178} {0 0}
179test apply-7.3 {namespace access} {
180    set ::testApply::x 0
181    set body {variable x; set x 1}
182    list [apply [list args $body ::testApply]] $::testApply::x
183} {1 1}
184test apply-7.4 {namespace access} {
185    set ::testApply::x 0
186    set body {testApply}
187    apply [list args $body ::testApply]
188} testApply
189test apply-7.5 {namespace access} {
190    set ::testApply::x 0
191    set body {set x 1; set x}
192    list [apply [list args $body testApply]] $::testApply::x
193} {1 0}
194test apply-7.6 {namespace access} {
195    set ::testApply::x 0
196    set body {variable x; set x}
197    list [apply [list args $body testApply]] $::testApply::x
198} {0 0}
199test apply-7.7 {namespace access} {
200    set ::testApply::x 0
201    set body {variable x; set x 1}
202    list [apply [list args $body testApply]] $::testApply::x
203} {1 1}
204test apply-7.8 {namespace access} {
205    set ::testApply::x 0
206    set body {testApply}
207    apply [list args $body testApply]
208} testApply
209
210# Tests for correct argument treatment
211
212set applyBody {
213    set res {}
214    foreach v [info locals] {
215	if {$v eq "res"} continue
216	lappend res [list $v [set $v]]
217    }
218    set res
219}
220
221test apply-8.1 {args treatment} {
222    apply [list args $applyBody] 1 2 3
223} {{args {1 2 3}}}
224test apply-8.2 {args treatment} {
225    apply [list {x args} $applyBody] 1 2
226} {{x 1} {args 2}}
227test apply-8.3 {args treatment} {
228    apply [list {x args} $applyBody] 1 2 3
229} {{x 1} {args {2 3}}}
230test apply-8.4 {default values} {
231    apply [list {{x 1} {y 2}} $applyBody]
232} {{x 1} {y 2}}
233test apply-8.5 {default values} {
234    apply [list {{x 1} {y 2}} $applyBody] 3 4
235} {{x 3} {y 4}}
236test apply-8.6 {default values} {
237    apply [list {{x 1} {y 2}} $applyBody] 3
238} {{x 3} {y 2}}
239test apply-8.7 {default values} {
240    apply [list {x {y 2}} $applyBody] 1
241} {{x 1} {y 2}}
242test apply-8.8 {default values} {
243    apply [list {x {y 2}} $applyBody] 1 3
244} {{x 1} {y 3}}
245test apply-8.9 {default values} {
246    apply [list {x {y 2} args} $applyBody] 1
247} {{x 1} {y 2} {args {}}}
248test apply-8.10 {default values} {
249    apply [list {x {y 2} args} $applyBody] 1 3
250} {{x 1} {y 3} {args {}}}
251
252# Tests for leaks
253
254test apply-9.1 {leaking internal rep} -setup {
255    proc getbytes {} {
256	set lines [split [memory info] "\n"]
257	lindex $lines 3 3
258    }
259    set lam [list {} {set a 1}]
260} -constraints memory -body {
261    set end [getbytes]
262    for {set i 0} {$i < 5} {incr i} {
263	::apply [lrange $lam 0 end]
264	set tmp $end
265	set end [getbytes]
266    }
267    set leakedBytes [expr {$end - $tmp}]
268} -cleanup {
269    rename getbytes {}
270    unset -nocomplain lam end i tmp leakedBytes
271} -result 0
272test apply-9.2 {leaking internal rep} -setup {
273    proc getbytes {} {
274	set lines [split [memory info] "\n"]
275	lindex $lines 3 3
276    }
277} -constraints memory -body {
278    set end [getbytes]
279    for {set i 0} {$i < 5} {incr i} {
280	::apply [list {} {set a 1}]
281	set tmp $end
282	set end [getbytes]
283    }
284    set leakedBytes [expr {$end - $tmp}]
285} -cleanup {
286    rename getbytes {}
287    unset -nocomplain end i tmp leakedBytes
288} -result 0
289test apply-9.3 {leaking internal rep} -setup {
290    proc getbytes {} {
291	set lines [split [memory info] "\n"]
292	lindex $lines 3 3
293    }
294} -constraints memory -body {
295    set end [getbytes]
296    for {set i 0} {$i < 5} {incr i} {
297	set x [list {} {set a 1} ::NS::THAT::DOES::NOT::EXIST]
298	catch {::apply $x}
299	set x {}
300	set tmp $end
301	set end [getbytes]
302    }
303    set leakedBytes [expr {$end - $tmp}]
304} -cleanup {
305    rename getbytes {}
306    unset -nocomplain end i x tmp leakedBytes
307} -result 0
308
309# Tests for the avoidance of recompilation
310
311# cleanup
312
313namespace delete testApply
314
315::tcltest::cleanupTests
316return
317
318# Local Variables:
319# mode: tcl
320# fill-column: 78
321# End:
322