1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
|
# This file contains tests for the tclProc.c source file. Tests appear in
# the same order as the C code that they test. The set of tests is
# currently incomplete since it includes only new tests, in particular
# tests for code changed for the addition of Tcl namespaces. Other
# procedure-related tests appear in other test files such as proc-old.test.
#
# Sourcing this file into Tcl runs the tests and generates output for
# errors. No output means no errors were found.
#
# Copyright (c) 1997 Sun Microsystems, Inc.
#
# 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.2 1998/09/14 18:40:12 stanton Exp $
if {[string compare test [info procs test]] == 1} then {source defs}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
test proc-1.1 {Tcl_ProcObjCmd, put proc in namespace specified in name, if any} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {}
}
proc test_ns_1::baz::p {} {
return "p in [namespace current]"
}
list [test_ns_1::baz::p] \
[namespace eval test_ns_1 {baz::p}] \
[info commands test_ns_1::baz::*]
} {{p in ::test_ns_1::baz} {p in ::test_ns_1::baz} ::test_ns_1::baz::p}
test proc-1.2 {Tcl_ProcObjCmd, namespace specified in proc name must exist} {
catch {eval namespace delete [namespace children :: test_ns_*]}
list [catch {proc test_ns_1::baz::p {} {}} msg] $msg
} {1 {can't create procedure "test_ns_1::baz::p": unknown namespace}}
test proc-1.3 {Tcl_ProcObjCmd, empty proc name} {
catch {eval namespace delete [namespace children :: test_ns_*]}
proc :: {} {
return "empty called"
}
list [::] \
[info body {}]
} {{empty called} {
return "empty called"
}}
test proc-1.4 {Tcl_ProcObjCmd, simple proc name and proc defined in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {
return "p in [namespace current]"
}
}
}
list [test_ns_1::baz::p] \
[info commands test_ns_1::baz::*]
} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p}
test proc-1.5 {Tcl_ProcObjCmd, qualified proc name and proc defined in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {
return "p in [namespace current]"
}
}
list [test_ns_1::baz::p] \
[info commands test_ns_1::baz::*] \
[namespace eval test_ns_1::baz {namespace which p}]
} {{p in ::test_ns_1::baz} ::test_ns_1::baz::p ::test_ns_1::baz::p}
test proc-1.6 {Tcl_ProcObjCmd, namespace code ignores single ":"s in middle or end of command names} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
proc q: {} {return "q:"}
proc value:at: {} {return "value:at:"}
}
list [namespace eval test_ns_1 {q:}] \
[namespace eval test_ns_1 {value:at:}] \
[test_ns_1::q:] \
[test_ns_1::value:at:] \
[lsort [info commands test_ns_1::*]] \
[namespace eval test_ns_1 {namespace which q:}] \
[namespace eval test_ns_1 {namespace which value:at:}]
} {q: value:at: q: value:at: {::test_ns_1::q: ::test_ns_1::value:at:} ::test_ns_1::q: ::test_ns_1::value:at:}
test proc-1.7 {Tcl_ProcObjCmd, check that formal parameter names are not array elements} {
catch {rename p ""}
list [catch {proc p {a(1) a(2)} {
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}}
test proc-2.1 {TclFindProc, simple proc name and proc not in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "p in [namespace current]"}
info body p
} {return "p in [namespace current]"}
test proc-2.2 {TclFindProc, simple proc name and proc defined in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1 {
namespace eval baz {
proc p {} {return "p in [namespace current]"}
}
}
namespace eval test_ns_1::baz {info body p}
} {return "p in [namespace current]"}
test proc-2.3 {TclFindProc, qualified proc name and proc defined in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {}
namespace eval test_ns_1 {
proc baz::p {} {return "p in [namespace current]"}
}
namespace eval test_ns_1 {info body baz::p}
} {return "p in [namespace current]"}
test proc-2.4 {TclFindProc, global proc and executing in namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "global p"}
namespace eval test_ns_1::baz {info body p}
} {return "global p"}
test proc-3.1 {TclObjInterpProc, proc defined and executing in same namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
proc p {} {return "p in [namespace current]"}
p
} {p in ::}
test proc-3.2 {TclObjInterpProc, proc defined and executing in same namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
namespace eval test_ns_1::baz {
proc p {} {return "p in [namespace current]"}
p
}
} {p in ::test_ns_1::baz}
test proc-3.3 {TclObjInterpProc, proc defined and executing in different namespaces} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
proc p {} {return "p in [namespace current]"}
namespace eval test_ns_1::baz {
p
}
} {p in ::}
test proc-3.4 {TclObjInterpProc, procs execute in the namespace in which they were defined unless renamed into new namespace} {
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
namespace eval test_ns_1::baz {
proc p {} {return "p in [namespace current]"}
rename ::test_ns_1::baz::p ::p
list [p] [namespace which p]
}
} {{p in ::} ::p}
test proc-3.5 {TclObjInterpProc, any old result is reset before appending error msg about missing arguments} {
proc p {x} {info commands 3m}
list [catch {p} msg] $msg
} {1 {no value given for parameter "x" to "p"}}
catch {eval namespace delete [namespace children :: test_ns_*]}
catch {rename p ""}
catch {rename {} ""}
catch {unset msg}
|
