1# Commands covered: rename 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright (c) 1991-1993 The Regents of the University of California. 8# Copyright (c) 1994 Sun Microsystems, Inc. 9# Copyright (c) 1998-1999 by Scriptics Corporation. 10# 11# See the file "license.terms" for information on usage and redistribution 12# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 13# 14# RCS: @(#) $Id: rename.test,v 1.10 2001/09/12 20:28:50 dgp Exp $ 15 16if {[lsearch [namespace children] ::tcltest] == -1} { 17 package require tcltest 18 namespace import -force ::tcltest::* 19} 20 21# Must eliminate the "unknown" command while the test is running, 22# especially if the test is being run in a program with its 23# own special-purpose unknown command. 24 25catch {rename unknown unknown.old} 26 27catch {rename r2 {}} 28proc r1 {} {return "procedure r1"} 29rename r1 r2 30test rename-1.1 {simple renaming} { 31 r2 32} {procedure r1} 33test rename-1.2 {simple renaming} { 34 list [catch r1 msg] $msg 35} {1 {invalid command name "r1"}} 36rename r2 {} 37test rename-1.3 {simple renaming} { 38 list [catch r2 msg] $msg 39} {1 {invalid command name "r2"}} 40 41# The test below is tricky because it renames a built-in command. 42# It's possible that the test procedure uses this command, so must 43# restore the command before calling test again. 44 45rename list l.new 46set a [catch list msg1] 47set b [l.new a b c] 48rename l.new list 49set c [catch l.new msg2] 50set d [list 111 222] 51test rename-2.1 {renaming built-in command} { 52 list $a $msg1 $b $c $msg2 $d 53} {1 {invalid command name "list"} {a b c} 1 {invalid command name "l.new"} {111 222}} 54 55test rename-3.1 {error conditions} { 56 list [catch {rename r1} msg] $msg $errorCode 57} {1 {wrong # args: should be "rename oldName newName"} NONE} 58test rename-3.2 {error conditions} { 59 list [catch {rename r1 r2 r3} msg] $msg $errorCode 60} {1 {wrong # args: should be "rename oldName newName"} NONE} 61test rename-3.3 {error conditions} { 62 proc r1 {} {} 63 proc r2 {} {} 64 list [catch {rename r1 r2} msg] $msg 65} {1 {can't rename to "r2": command already exists}} 66test rename-3.4 {error conditions} { 67 catch {rename r1 {}} 68 catch {rename r2 {}} 69 list [catch {rename r1 r2} msg] $msg 70} {1 {can't rename "r1": command doesn't exist}} 71test rename-3.5 {error conditions} { 72 catch {rename _non_existent_command {}} 73 list [catch {rename _non_existent_command {}} msg] $msg 74} {1 {can't delete "_non_existent_command": command doesn't exist}} 75 76catch {rename unknown {}} 77catch {rename unknown.old unknown} 78catch {rename bar {}} 79 80if {[info command testdel] == "testdel"} { 81 test rename-4.1 {reentrancy issues with command deletion and renaming} { 82 set x {} 83 testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]} 84 rename foo bar 85 lappend x | 86 rename bar {} 87 set x 88 } {| deleted {}} 89 test rename-4.2 {reentrancy issues with command deletion and renaming} { 90 set x {} 91 testdel {} foo {lappend x deleted; rename foo bar} 92 rename foo {} 93 set x 94 } {deleted} 95 test rename-4.3 {reentrancy issues with command deletion and renaming} { 96 set x {} 97 testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}} 98 rename foo {} 99 lappend x | 100 rename foo {} 101 set x 102 } {deleted | deleted2} 103 test rename-4.4 {reentrancy issues with command deletion and renaming} { 104 set x {} 105 testdel {} foo {lappend x deleted; rename foo bar} 106 rename foo {} 107 lappend x | [info command bar] 108 } {deleted | {}} 109 test rename-4.5 {reentrancy issues with command deletion and renaming} { 110 set env(value) before 111 interp create foo 112 testdel foo cmd {set env(value) deleted} 113 interp delete foo 114 set env(value) 115 } {deleted} 116 test rename-4.6 {reentrancy issues with command deletion and renaming} { 117 proc kill args { 118 interp delete foo 119 } 120 set env(value) before 121 interp create foo 122 foo alias kill kill 123 testdel foo cmd {set env(value) deleted; kill} 124 list [catch {foo eval {rename cmd {}}} msg] $msg $env(value) 125 } {0 {} deleted} 126 test rename-4.7 {reentrancy issues with command deletion and renaming} { 127 proc kill args { 128 interp delete foo 129 } 130 set env(value) before 131 interp create foo 132 foo alias kill kill 133 testdel foo cmd {set env(value) deleted; kill} 134 list [catch {interp delete foo} msg] $msg $env(value) 135 } {0 {} deleted} 136 if {[info exists env(value)]} { 137 unset env(value) 138 } 139} 140 141# Save the unknown procedure which is modified by the following test. 142 143catch {rename unknown unknown.old} 144 145test rename-5.1 {repeated rename deletion and redefinition of same command} { 146 set SAVED_UNKNOWN "proc unknown " 147 append SAVED_UNKNOWN "\{[info args unknown.old]\} " 148 append SAVED_UNKNOWN "\{[info body unknown.old]\}" 149 150 for {set i 0} {$i < 10} {incr i} { 151 eval $SAVED_UNKNOWN 152 tcl_wordBreakBefore "" 0 153 rename tcl_wordBreakBefore {} 154 rename unknown {} 155 } 156} {} 157 158catch {rename unknown {}} 159catch {rename unknown.old unknown} 160 161 162test rename-6.1 {old code invalidated (epoch incremented) when cmd with compile proc is renamed } { 163 proc x {} { 164 set a 123 165 set b [incr a] 166 } 167 x 168 rename incr incr.old 169 proc incr {} {puts "new incr called!"} 170 catch {x} msg 171 set msg 172} {wrong # args: should be "incr"} 173 174if {[info commands incr.old] != {}} { 175 catch {rename incr {}} 176 catch {rename incr.old incr} 177} 178::tcltest::cleanupTests 179return 180