[25] | 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.12 2004/05/19 20:15:32 dkf Exp $ |
---|
| 15 | |
---|
| 16 | if {[lsearch [namespace children] ::tcltest] == -1} { |
---|
| 17 | package require tcltest |
---|
| 18 | namespace import -force ::tcltest::* |
---|
| 19 | } |
---|
| 20 | |
---|
| 21 | testConstraint testdel [llength [info commands testdel]] |
---|
| 22 | |
---|
| 23 | # Must eliminate the "unknown" command while the test is running, |
---|
| 24 | # especially if the test is being run in a program with its |
---|
| 25 | # own special-purpose unknown command. |
---|
| 26 | |
---|
| 27 | catch {rename unknown unknown.old} |
---|
| 28 | |
---|
| 29 | catch {rename r2 {}} |
---|
| 30 | proc r1 {} {return "procedure r1"} |
---|
| 31 | rename r1 r2 |
---|
| 32 | test rename-1.1 {simple renaming} { |
---|
| 33 | r2 |
---|
| 34 | } {procedure r1} |
---|
| 35 | test rename-1.2 {simple renaming} { |
---|
| 36 | list [catch r1 msg] $msg |
---|
| 37 | } {1 {invalid command name "r1"}} |
---|
| 38 | rename r2 {} |
---|
| 39 | test rename-1.3 {simple renaming} { |
---|
| 40 | list [catch r2 msg] $msg |
---|
| 41 | } {1 {invalid command name "r2"}} |
---|
| 42 | |
---|
| 43 | # The test below is tricky because it renames a built-in command. |
---|
| 44 | # It's possible that the test procedure uses this command, so must |
---|
| 45 | # restore the command before calling test again. |
---|
| 46 | |
---|
| 47 | rename list l.new |
---|
| 48 | set a [catch list msg1] |
---|
| 49 | set b [l.new a b c] |
---|
| 50 | rename l.new list |
---|
| 51 | set c [catch l.new msg2] |
---|
| 52 | set d [list 111 222] |
---|
| 53 | test 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 | |
---|
| 57 | test rename-3.1 {error conditions} { |
---|
| 58 | list [catch {rename r1} msg] $msg $errorCode |
---|
| 59 | } {1 {wrong # args: should be "rename oldName newName"} NONE} |
---|
| 60 | test rename-3.2 {error conditions} { |
---|
| 61 | list [catch {rename r1 r2 r3} msg] $msg $errorCode |
---|
| 62 | } {1 {wrong # args: should be "rename oldName newName"} NONE} |
---|
| 63 | test rename-3.3 {error conditions} { |
---|
| 64 | proc r1 {} {} |
---|
| 65 | proc r2 {} {} |
---|
| 66 | list [catch {rename r1 r2} msg] $msg |
---|
| 67 | } {1 {can't rename to "r2": command already exists}} |
---|
| 68 | test rename-3.4 {error conditions} { |
---|
| 69 | catch {rename r1 {}} |
---|
| 70 | catch {rename r2 {}} |
---|
| 71 | list [catch {rename r1 r2} msg] $msg |
---|
| 72 | } {1 {can't rename "r1": command doesn't exist}} |
---|
| 73 | test rename-3.5 {error conditions} { |
---|
| 74 | catch {rename _non_existent_command {}} |
---|
| 75 | list [catch {rename _non_existent_command {}} msg] $msg |
---|
| 76 | } {1 {can't delete "_non_existent_command": command doesn't exist}} |
---|
| 77 | |
---|
| 78 | catch {rename unknown {}} |
---|
| 79 | catch {rename unknown.old unknown} |
---|
| 80 | catch {rename bar {}} |
---|
| 81 | |
---|
| 82 | test rename-4.1 {reentrancy issues with command deletion and renaming} testdel { |
---|
| 83 | set x {} |
---|
| 84 | testdel {} foo {lappend x deleted; rename bar {}; lappend x [info command bar]} |
---|
| 85 | rename foo bar |
---|
| 86 | lappend x | |
---|
| 87 | rename bar {} |
---|
| 88 | set x |
---|
| 89 | } {| deleted {}} |
---|
| 90 | test rename-4.2 {reentrancy issues with command deletion and renaming} testdel { |
---|
| 91 | set x {} |
---|
| 92 | testdel {} foo {lappend x deleted; rename foo bar} |
---|
| 93 | rename foo {} |
---|
| 94 | set x |
---|
| 95 | } {deleted} |
---|
| 96 | test rename-4.3 {reentrancy issues with command deletion and renaming} testdel { |
---|
| 97 | set x {} |
---|
| 98 | testdel {} foo {lappend x deleted; testdel {} foo {lappend x deleted2}} |
---|
| 99 | rename foo {} |
---|
| 100 | lappend x | |
---|
| 101 | rename foo {} |
---|
| 102 | set x |
---|
| 103 | } {deleted | deleted2} |
---|
| 104 | test rename-4.4 {reentrancy issues with command deletion and renaming} testdel { |
---|
| 105 | set x {} |
---|
| 106 | testdel {} foo {lappend x deleted; rename foo bar} |
---|
| 107 | rename foo {} |
---|
| 108 | lappend x | [info command bar] |
---|
| 109 | } {deleted | {}} |
---|
| 110 | test rename-4.5 {reentrancy issues with command deletion and renaming} testdel { |
---|
| 111 | set env(value) before |
---|
| 112 | interp create foo |
---|
| 113 | testdel foo cmd {set env(value) deleted} |
---|
| 114 | interp delete foo |
---|
| 115 | set env(value) |
---|
| 116 | } {deleted} |
---|
| 117 | test rename-4.6 {reentrancy issues with command deletion and renaming} testdel { |
---|
| 118 | proc kill args { |
---|
| 119 | interp delete foo |
---|
| 120 | } |
---|
| 121 | set env(value) before |
---|
| 122 | interp create foo |
---|
| 123 | foo alias kill kill |
---|
| 124 | testdel foo cmd {set env(value) deleted; kill} |
---|
| 125 | list [catch {foo eval {rename cmd {}}} msg] $msg $env(value) |
---|
| 126 | } {0 {} deleted} |
---|
| 127 | test rename-4.7 {reentrancy issues with command deletion and renaming} testdel { |
---|
| 128 | proc kill args { |
---|
| 129 | interp delete foo |
---|
| 130 | } |
---|
| 131 | set env(value) before |
---|
| 132 | interp create foo |
---|
| 133 | foo alias kill kill |
---|
| 134 | testdel foo cmd {set env(value) deleted; kill} |
---|
| 135 | list [catch {interp delete foo} msg] $msg $env(value) |
---|
| 136 | } {0 {} deleted} |
---|
| 137 | if {[info exists env(value)]} { |
---|
| 138 | unset env(value) |
---|
| 139 | } |
---|
| 140 | |
---|
| 141 | # Save the unknown procedure which is modified by the following test. |
---|
| 142 | |
---|
| 143 | catch {rename unknown unknown.old} |
---|
| 144 | |
---|
| 145 | test 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 | |
---|
| 158 | catch {rename unknown {}} |
---|
| 159 | catch {rename unknown.old unknown} |
---|
| 160 | |
---|
| 161 | |
---|
| 162 | test 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 | rename incr {} |
---|
| 172 | rename incr.old incr |
---|
| 173 | set msg |
---|
| 174 | } {wrong # args: should be "incr"} |
---|
| 175 | |
---|
| 176 | if {[info commands incr.old] != {}} { |
---|
| 177 | catch {rename incr {}} |
---|
| 178 | catch {rename incr.old incr} |
---|
| 179 | } |
---|
| 180 | ::tcltest::cleanupTests |
---|
| 181 | return |
---|