Because Tcl shows no favor to its built-in commands, it is easy to replace them with your own customized or extended versions. This can be useful in providing forward compatibility.
Typically, one [rename]s the built-in command, then defines a [proc] to replace the built-in command. The proc implements new features, and calls on the renamed command to perform the functions already supplied by the renamed command.
As an example, consider replacing the built-in command [string] with a new version that provides the subcommand [string reverse].
rename string Tcl_string
proc string {option args} {
switch -glob -- $option {
rev* {
if {[string first $option reverse] != 0} {
return [uplevel 1 [list Tcl_string $option] $args]
}
if {[llength $args] != 1} {
return -code error "wrong # args: should be\
\"[lindex [info level 0] 0] reverse string\""
}
set returnValue ""
set string [lindex $args 0]
set length [string length $string]
while {[incr length -1] >= 0} {
append returnValue [string index $string $length]
}
return $returnValue
}
default {
uplevel 1 [list Tcl_string $option] $args
}
}
}This accomplishes the task,...
% string reverse foo oof % string length foo 3
... but does not quite leave the new [string] as a perfect replacement for the built-in string. In particular, the error messages and $errorInfo generated by the replacement [string] will not match the original.
% string length foo bar
wrong # args: should be "Tcl_string length string"
% set errorInfo
wrong # args: should be "Tcl_string length string"
while executing
"Tcl_string length foo bar"
("uplevel" body line 1)
invoked from within
"uplevel 1 [list Tcl_string $option] $args"
("default" arm line 2)
invoked from within
"switch -glob -- $option {
rev* {
if {[string first $option reverse] != 0} {
return [uplevel 1 [list Tcl_stri..."
(procedure "string" line 2)
invoked from within
"string length foo bar"
% string revurse foo
bad option "revurse": must be bytelength, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, tolower, toupper, totitle, trim, trimleft, trimright, wordend, or wordstartFixing up these details is straightforward, but tedious, so it pays to factor out the work into a utility procedure:
proc Wrap {rename map {len 0}} {
return [format {
global errorInfo
set cmd [lreplace [info level 0] 0 %d %s]
if {[set code [catch {uplevel 1 $cmd} msg]] == 1} {
set errList [split $errorInfo \n]
set errList [lrange $errList 0 [expr {[llength $errList] \
- [llength [split $cmd \n]] - 5}]]
set newErrorInfo [join $errList \n]
foreach var {msg newErrorInfo} {
regsub -all {%s} [set $var] \
[lrange [info level 0] 0 %d] $var
foreach {pre post} {%s} {
regsub -all $pre [set $var] $post $var
}
}
return -code error -errorinfo $newErrorInfo $msg
}
return -code $code $msg} $len $rename $rename $len $map]
}The rename argument is the name of the renamed command. The map argument is a list with an even number of elements. When broken into pairs, the first element should be replaced by the second element in all error and stack trace messages. Finally the len argument is the list index of the last word in the original command that is being replaced by wrapping. This lets one replace [string reverse] with [myStringReverse].
Here is the [string reverse] example making use of [Wrap]:
rename string Tcl_string
proc myStringReverse {args} {
if {[llength $args] != 1} {
return -code error "wrong # args: should be\
\"[lindex [info level 0] 0] string\""
}
set returnValue ""
set string [lindex $args 0]
set length [string length $string]
while {[incr length -1] >= 0} {
append returnValue [string index $string $length]
}
return $returnValue
}
proc string {option args} {
set errorMap {
"replace, tolower" "replace, reverse, tolower"
}
switch -glob -- $option {
rev* {
if {[string first $option reverse] != 0} {
eval [Wrap Tcl_string $errorMap]
}
eval [Wrap myStringReverse $errorMap 1]
}
default {
eval [Wrap Tcl_string $errorMap]
}
}
}