1# This file contains tests for the tclProc.c source file. Tests appear in
2# the same order as the C code that they test. The set of tests is
3# currently incomplete since it includes only new tests, in particular
4# tests for code changed for the addition of Tcl namespaces. Other
5# procedure-related tests appear in other test files such as proc-old.test.
6#
7# Sourcing this file into Tcl runs the tests and generates output for
8# errors.  No output means no errors were found.
9#
10# Copyright (c) 1997 Sun Microsystems, Inc.
11# Copyright (c) 1998-1999 by Scriptics Corporation.
12#
13# See the file "license.terms" for information on usage and redistribution
14# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
15#
16# RCS: @(#) $Id: proc.test,v 1.11.2.1 2004/05/02 21:07:16 msofer Exp $
17
18if {[lsearch [namespace children] ::tcltest] == -1} {
19    package require tcltest
20    namespace import -force ::tcltest::*
21}
22
23testConstraint memory     [llength [info commands memory]]
24
25catch {eval namespace delete [namespace children :: test_ns_*]}
26catch {rename p ""}
27catch {rename {} ""}
28catch {unset msg}
29
30test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} {
31    catch {eval namespace delete [namespace children :: test_ns_*]}
32    namespace eval test_ns_1 {
33        namespace eval baz {}
34    }
35    proc test_ns_1::baz::p {} {
36        return "p in [namespace current]"
37    }
38    list [test_ns_1::baz::p] \
39         [namespace eval test_ns_1 {baz::p}] \
40         [info commands test_ns_1::baz::*]
41} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}
42test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} {
43    catch {eval namespace delete [namespace children :: test_ns_*]}
44    list [catch {proc test_ns_1::baz::p {} {}} msg] $msg
45} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}}
46test proc-1.3 {Tcl_ProcObjCmd, empty proc name} {
47    catch {eval namespace delete [namespace children :: test_ns_*]}
48    proc :: {} {
49        return "empty called"
50    }
51    list [::] \
52         [info body {}]
53} {{empty called} {
54        return "empty called"
55    }}
56test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
57    catch {eval namespace delete [namespace children :: test_ns_*]}
58    namespace eval test_ns_1 {
59        namespace eval baz {
60            proc p {} {
61                return "p in [namespace current]"
62            }
63        }
64    }
65    list [test_ns_1::baz::p] \
66         [info commands test_ns_1::baz::*]
67} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}
68test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} {
69    catch {eval namespace delete [namespace children :: test_ns_*]}
70    namespace eval test_ns_1::baz {}
71    namespace eval test_ns_1 {
72        proc baz::p {} {
73            return "p in [namespace current]"
74        }
75    }
76    list [test_ns_1::baz::p] \
77         [info commands test_ns_1::baz::*] \
78         [namespace eval test_ns_1::baz {namespace which p}]
79} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}
80test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} {
81    catch {eval namespace delete [namespace children :: test_ns_*]}
82    namespace eval test_ns_1 {
83        proc q: {} {return "q:"}
84        proc value:at: {} {return "value:at:"}
85    }
86    list [namespace eval test_ns_1 {q:}] \
87         [namespace eval test_ns_1 {value:at:}] \
88         [test_ns_1::q:] \
89         [test_ns_1::value:at:] \
90         [lsort [info commands test_ns_1::*]] \
91         [namespace eval test_ns_1 {namespace which q:}] \
92         [namespace eval test_ns_1 {namespace which value:at:}]
93} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}
94test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} {
95    catch {rename p ""}
96    list [catch {proc p {a(1) a(2)} { 
97            set z [expr $a(1)+$a(2)]
98            puts "$z=z, $a(1)=$a(1)"
99        }} msg] $msg
100} {1 {procedure "p" has formal parameter "a(1)" that is an array element}}
101test proc-1.8 {Tcl_ProcObjCmd, check that formal parameter names are simple names} {
102    catch {rename p ""}
103    list [catch {proc p {b:a b::a} { 
104    }} msg] $msg
105} {1 {procedure "p" has formal parameter "b::a" that is not a simple name}}
106
107test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
108    catch {eval namespace delete [namespace children :: test_ns_*]}
109    catch {rename p ""}
110    proc p {} {return "p in [namespace current]"}
111    info body p
112} {return "p in [namespace current]"}
113test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} {
114    catch {eval namespace delete [namespace children :: test_ns_*]}
115    namespace eval test_ns_1 {
116        namespace eval baz {
117            proc p {} {return "p in [namespace current]"}
118        }
119    }
120    namespace eval test_ns_1::baz {info body p}
121} {return "p in [namespace current]"}
122test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} {
123    catch {eval namespace delete [namespace children :: test_ns_*]}
124    namespace eval test_ns_1::baz {}
125    namespace eval test_ns_1 {
126        proc baz::p {} {return "p in [namespace current]"}
127    }
128    namespace eval test_ns_1 {info body baz::p}
129} {return "p in [namespace current]"}
130test proc-2.4 {TclFindProc, global proc and executing in namespace} {
131    catch {eval namespace delete [namespace children :: test_ns_*]}
132    catch {rename p ""}
133    proc p {} {return "global p"}
134    namespace eval test_ns_1::baz {info body p}
135} {return "global p"}
136
137test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} {
138    catch {eval namespace delete [namespace children :: test_ns_*]}
139    proc p {} {return "p in [namespace current]"}
140    p
141} {p in ::}
142test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} {
143    catch {eval namespace delete [namespace children :: test_ns_*]}
144    namespace eval test_ns_1::baz {
145        proc p {} {return "p in [namespace current]"}
146        p
147    }
148} {p in ::test_ns_1::baz}
149test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} {
150    catch {eval namespace delete [namespace children :: test_ns_*]}
151    catch {rename p ""}
152    proc p {} {return "p in [namespace current]"}
153    namespace eval test_ns_1::baz {
154        p
155    }
156} {p in ::}
157test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
158    catch {eval namespace delete [namespace children :: test_ns_*]}
159    catch {rename p ""}
160    namespace eval test_ns_1::baz {
161        proc p {} {return "p in [namespace current]"}
162        rename ::test_ns_1::baz::p ::p
163        list [p] [namespace which p]
164    }
165} {{p in ::} ::p}
166test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
167    proc p {x} {info commands 3m}
168    list [catch {p} msg] $msg
169} {1 {wrong # args: should be "p x"}}
170
171test proc-3.6 {TclObjInterpProc, proper quoting of proc name, Bug 942757} {
172    proc {a b  c} {x} {info commands 3m}
173    list [catch {{a b  c}} msg] $msg
174} {1 {wrong # args: should be "{a b  c} x"}}
175
176catch {eval namespace delete [namespace children :: test_ns_*]}
177catch {rename p ""}
178catch {rename {} ""}
179catch {rename {a b  c} {}}
180catch {unset msg}
181
182if {[catch {package require procbodytest}]} {
183    puts "This application couldn't load the \"procbodytest\" package, so I"
184    puts "can't test creation of procs whose bodies have type \"procbody\"."
185    ::tcltest::cleanupTests
186    return
187}
188
189catch {rename p ""}
190catch {rename t ""}
191
192# Note that the test require that procedures whose body is used to create
193# procbody objects must be executed before the procbodytest::proc command
194# is executed, so that the Proc struct is populated correctly (CompiledLocals
195# are added at compile time).
196
197test proc-4.1 {TclCreateProc, procbody obj} {
198    catch {
199	proc p x {return "$x:$x"}
200	set rv [p P]
201	procbodytest::proc t x p
202	lappend rv [t T]
203	set rv
204    } result
205    catch {rename p ""}
206    catch {rename t ""}
207    set result
208} {P:P T:T}
209
210test proc-4.2 {TclCreateProc, procbody obj, use compiled locals} {
211    catch {
212	proc p x {
213	    set y [string tolower $x]
214	    return "$x:$y"
215	}
216	set rv [p P]
217	procbodytest::proc t x p
218	lappend rv [t T]
219	set rv
220    } result
221    catch {rename p ""}
222    catch {rename t ""}
223    set result
224} {P:p T:t}
225
226test proc-4.3 {TclCreateProc, procbody obj, too many args} {
227    catch {
228	proc p x {
229	    set y [string tolower $x]
230	    return "$x:$y"
231	}
232	set rv [p P]
233	procbodytest::proc t {x x1 x2} p
234	lappend rv [t T]
235	set rv
236    } result
237    catch {rename p ""}
238    catch {rename t ""}
239    set result
240} {procedure "t": arg list contains 3 entries, precompiled header expects 1}
241
242test proc-4.4 {TclCreateProc, procbody obj, inconsistent arg name} {
243    catch {
244	proc p {x y z} {
245	    set v [join [list $x $y $z]]
246	    set w [string tolower $v]
247	    return "$v:$w"
248	}
249	set rv [p P Q R]
250	procbodytest::proc t {x x1 z} p
251	lappend rv [t S T U]
252	set rv
253    } result
254    catch {rename p ""}
255    catch {rename t ""}
256    set result
257} {procedure "t": formal parameter 1 is inconsistent with precompiled body}
258
259test proc-4.5 {TclCreateProc, procbody obj, inconsistent arg default type} {
260    catch {
261	proc p {x y {z Z}} {
262	    set v [join [list $x $y $z]]
263	    set w [string tolower $v]
264	    return "$v:$w"
265	}
266	set rv [p P Q R]
267	procbodytest::proc t {x y z} p
268	lappend rv [t S T U]
269	set rv
270    } result
271    catch {rename p ""}
272    catch {rename t ""}
273    set result
274} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
275
276test proc-4.6 {TclCreateProc, procbody obj, inconsistent arg default type} {
277    catch {
278	proc p {x y z} {
279	    set v [join [list $x $y $z]]
280	    set w [string tolower $v]
281	    return "$v:$w"
282	}
283	set rv [p P Q R]
284	procbodytest::proc t {x y {z Z}} p
285	lappend rv [t S T U]
286	set rv
287    } result
288    catch {rename p ""}
289    catch {rename t ""}
290    set result
291} {procedure "t": formal parameter 2 is inconsistent with precompiled body}
292
293test proc-4.7 {TclCreateProc, procbody obj, inconsistent arg default value} {
294    catch {
295	proc p {x y {z Z}} {
296	    set v [join [list $x $y $z]]
297	    set w [string tolower $v]
298	    return "$v:$w"
299	}
300	set rv [p P Q R]
301	procbodytest::proc t {x y {z ZZ}} p
302	lappend rv [t S T U]
303	set rv
304    } result
305    catch {rename p ""}
306    catch {rename t ""}
307    set result
308} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
309
310test proc-4.8 {TclCreateProc, procbody obj, no leak on multiple iterations} -setup {
311    proc getbytes {} {
312	set lines [split [memory info] "\n"]
313	lindex $lines 3 3
314    }
315    proc px x {
316	set y [string tolower $x]
317	return "$x:$y"
318    }
319    px x
320} -constraints memory -body {
321    set end [getbytes]
322    for {set i 0} {$i < 5} {incr i} {
323
324	procbodytest::proc tx x px
325
326	set tmp $end
327	set end [getbytes]
328    }
329    set leakedBytes [expr {$end - $tmp}]
330} -cleanup {
331    rename getbytes {}
332} -result 0
333
334test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
335    proc p args {} ; # this will be bytecompiled into t
336    proc t {} {
337	set res {}
338	set a 0
339	set b 0
340	trace add variable a read {append res a ;#}
341	trace add variable b write {append res b ;#}
342	p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello
343	set res
344    }
345    set result [t]
346    catch {rename p ""}
347    catch {rename t ""}
348    set result
349} {aba}    
350
351test proc-6.1 {ProcessProcResultCode: Bug 647307 (negative return code)} {
352    proc a {} {return -code -5}
353    proc b {} a
354    set result [catch b]
355    rename a {}
356    rename b {}
357    set result
358} -5
359
360# cleanup
361catch {rename p ""}
362catch {rename t ""}
363::tcltest::cleanupTests
364return
365
366
367
368
369
370
371
372
373
374
375
376
377