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