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