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
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
|
# Commands covered: rename
#
# 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 © 1991-1993 The Regents of the University of California.
# Copyright © 1994 Sun Microsystems, Inc.
# Copyright © 1998-1999 Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
if {"::tcltest" ni [namespace children]} {
package require tcltest 2.5
namespace import -force ::tcltest::*
}
::tcltest::loadTestedCommands
catch [list package require -exact tcl::test [info patchlevel]]
testConstraint testdel [llength [info commands testdel]]
# Must eliminate the "unknown" command while the test is running, especially
# if the test is being run in a program with its own special-purpose unknown
# command.
catch {rename unknown unknown.old}
catch {rename r2 {}}
proc r1 {} {return "procedure r1"}
rename r1 r2
test rename-1.1 {simple renaming} {
r2
} {procedure r1}
test rename-1.2 {simple renaming} {
list [catch r1 msg] $msg
} {1 {invalid command name "r1"}}
rename r2 {}
test rename-1.3 {simple renaming} {
list [catch r2 msg] $msg
} {1 {invalid command name "r2"}}
# The test below is tricky because it renames a built-in command. It's
# possible that the test procedure uses this command, so must restore the
# command before calling test again.
rename list l.new
set a [catch list msg1]
set b [l.new a b c]
rename l.new list
set c [catch l.new msg2]
set d [list 111 222]
test rename-2.1 {renaming built-in command} {
list $a $msg1 $b $c $msg2 $d
} {1 {invalid command name "list"} {a b c} 1 {invalid command name "l.new"} {111 222}}
test rename-3.1 {error conditions} {
list [catch {rename r1} msg] $msg $errorCode
} {1 {wrong # args: should be "rename oldName newName"} {TCL WRONGARGS}}
test rename-3.2 {error conditions} {
list [catch {rename r1 r2 r3} msg] $msg $errorCode
} {1 {wrong # args: should be "rename oldName newName"} {TCL WRONGARGS}}
test rename-3.3 {error conditions} -setup {
proc r1 {} {}
proc r2 {} {}
} -returnCodes error -body {
rename r1 r2
} -result {can't rename to "r2": command already exists}
test rename-3.4 {error conditions} -setup {
catch {rename r1 {}}
catch {rename r2 {}}
} -returnCodes error -body {
rename r1 r2
} -result {can't rename "r1": command doesn't exist}
test rename-3.5 {error conditions} -setup {
catch {rename _non_existent_command {}}
} -returnCodes error -body {
rename _non_existent_command {}
} -result {can't delete "_non_existent_command": command doesn't exist}
catch {rename unknown {}}
catch {rename unknown.old unknown}
catch {rename bar {}}
test rename-4.1 {reentrancy issues with command deletion and renaming} testdel {
set x {}
testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]}
rename foo bar
lappend x |
rename bar {}
set x
} {| deleted {}}
test rename-4.2 {reentrancy issues with command deletion and renaming} testdel {
set x {}
testdel {} foo {lappend x deleted; rename foo bar}
rename foo {}
set x
} {deleted}
test rename-4.3 {reentrancy issues with command deletion and renaming} testdel {
set x {}
testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}}
rename foo {}
lappend x |
rename foo {}
set x
} {deleted | deleted2}
test rename-4.4 {reentrancy issues with command deletion and renaming} testdel {
set x {}
testdel {} foo {lappend x deleted; rename foo bar}
rename foo {}
lappend x | [info command bar]
} {deleted | {}}
test rename-4.5 {reentrancy issues with command deletion and renaming} testdel {
set env(value) before
interp create foo
testdel foo cmd {set env(value) deleted}
interp delete foo
set env(value)
} {deleted}
test rename-4.6 {reentrancy issues with command deletion and renaming} testdel {
proc kill args {
interp delete foo
}
set env(value) before
interp create foo
foo alias kill kill
testdel foo cmd {set env(value) deleted; kill}
list [catch {foo eval {rename cmd {}}} msg] $msg $env(value)
} {0 {} deleted}
test rename-4.7 {reentrancy issues with command deletion and renaming} testdel {
proc kill args {
interp delete foo
}
set env(value) before
interp create foo
foo alias kill kill
testdel foo cmd {set env(value) deleted; kill}
list [catch {interp delete foo} msg] $msg $env(value)
} {0 {} deleted}
if {[info exists env(value)]} {
unset env(value)
}
test rename-4.8 {Bug a16752c252} testdel {
set x broken
testdel {} foo {set x ok}
proc foo args {}
rename foo {}
return -level 0 $x[unset x]
} ok
# Save the unknown procedure which is modified by the following test.
catch {rename unknown unknown.old}
set SAVED_UNKNOWN "proc unknown "
append SAVED_UNKNOWN [list [info args unknown.old] [info body unknown.old]]
test rename-5.1 {repeated rename deletion and redefinition of same command} {
for {set i 0} {$i < 10} {incr i} {
eval $SAVED_UNKNOWN
tcl_wordBreakBefore "" 0
rename tcl_wordBreakBefore {}
rename unknown {}
}
} {}
catch {rename unknown {}}
catch {rename unknown.old unknown}
test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed} -body {
proc x {} {
set a 123
set b [incr a]
}
x
rename incr incr.old
proc incr {} {puts "new incr called!"}
x
} -cleanup {
rename incr {}
rename incr.old incr
} -returnCodes error -result {wrong # args: should be "incr"}
if {[info commands incr.old] != {}} {
catch {rename incr {}}
catch {rename incr.old incr}
}
::tcltest::cleanupTests
return
# Local Variables:
# mode: tcl
# End:
|
