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
|
# 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.8.2.1 2001/09/12 20:34:59 dgp Exp $
source [file dirname [info script]]/testing.tcl
# 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
} {1 {wrong # args: should be "rename oldName newName"}}
test rename-3.2 {error conditions} {
list [catch {rename r1 r2 r3} msg] $msg
} {1 {wrong # args: should be "rename oldName newName"}}
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}
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 killx args {
interp delete foo
}
set env(value) before
interp create foo
foo alias killx killx
testdel foo cmd {set env(value) deleted; killx}
list [catch {foo eval {rename cmd {}}} msg] $msg $env(value)
} {0 {} deleted}
test rename-4.7 {reentrancy issues with command deletion and renaming} {
proc killx args {
interp delete foo
}
set env(value) before
interp create foo
foo alias killx killx
testdel foo cmd {set env(value) deleted; killx}
list [catch {interp delete foo} msg] $msg $env(value)
} {0 {} deleted}
if {[info exists env(value)]} {
unset env(value)
}
}
test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed } {
proc x {} {
set a 123
set b [split a 2]
}
x
rename split split.old
proc split {} {puts "new split called!"}
catch {x} msg
} 1
if {[info commands split.old] != {}} {
catch {rename split {}}
catch {rename split.old split}
}
catch {rename x {}}
catch {rename killx {}}
testreport
|
