blob: a33afaab5fdd9a485e80912b6927a8e9ab2003f8 (
plain)
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
|
# 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 (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994 Sun Microsystems, Inc.
# Copyright (c) 1998-1999 by Scriptics Corporation.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
# RCS: @(#) $Id: rename.test,v 1.11 2004/03/30 16:22:22 msofer Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
namespace import -force ::tcltest::*
}
# 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"} NONE}
test rename-3.2 {error conditions} {
list [catch {rename r1 r2 r3} msg] $msg $errorCode
} {1 {wrong # args: should be "rename oldName newName"} NONE}
test rename-3.3 {error conditions} {
proc r1 {} {}
proc r2 {} {}
list [catch {rename r1 r2} msg] $msg
} {1 {can't rename to "r2": command already exists}}
test rename-3.4 {error conditions} {
catch {rename r1 {}}
catch {rename r2 {}}
list [catch {rename r1 r2} msg] $msg
} {1 {can't rename "r1": command doesn't exist}}
test rename-3.5 {error conditions} {
catch {rename _non_existent_command {}}
list [catch {rename _non_existent_command {}} msg] $msg
} {1 {can't delete "_non_existent_command": command doesn't exist}}
catch {rename unknown {}}
catch {rename unknown.old unknown}
catch {rename bar {}}
if {[info command testdel] == "testdel"} {
test rename-4.1 {reentrancy issues with command deletion and renaming} {
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} {
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} {
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} {
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} {
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} {
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} {
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)
}
}
# Save the unknown procedure which is modified by the following test.
catch {rename unknown unknown.old}
test rename-5.1 {repeated rename deletion and redefinition of same command} {
set SAVED_UNKNOWN "proc unknown "
append SAVED_UNKNOWN "\{[info args unknown.old]\} "
append SAVED_UNKNOWN "\{[info body unknown.old]\}"
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 } {
proc x {} {
set a 123
set b [incr a]
}
x
rename incr incr.old
proc incr {} {puts "new incr called!"}
catch {x} msg
rename incr {}
rename incr.old incr
set msg
} {wrong # args: should be "incr"}
if {[info commands incr.old] != {}} {
catch {rename incr {}}
catch {rename incr.old incr}
}
::tcltest::cleanupTests
return
|
