wrapping commands is a rather common activity in Tcl. 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 and 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]
}
}
}PYK: [tailcall], new in version 8.6, makes wrapping easier. This example combines [tailcall] with hidden commands.
interp hide {} set
proc set args {
puts "invoking the real set with args: $args"
tailcall interp invokehidden {} set {*}$args
}
set a 5
puts $aCMcC has written a little proc to extend a command using ensemble.
# extend a command with a new subcommand
proc extend {cmd body} {
set wrapper [string map [list %C $cmd %B $body] {
namespace eval %C {}
rename %C %C::%C
namespace eval %C {
proc _unknown {junk subc args} {
return [list %C::%C $subc]
}
%B
namespace export -clear *
namespace ensemble create -unknown %C::_unknown
}
}]
uplevel \#0 $wrapper
}
extend file {
proc newer {a b} {
return [expr {[file mtime $a] > [file mtime $b]}]
}
}
puts [file newer WubUtils.tcl Timer.tcl]glennj I really like that. However, one drawback is that it does not "register" the new subcommand in an error message:
% file foobar bad option "foobar": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mtime, mkdir, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable
The error message does not contain the new subcommand "newer".
This extend procedure will examine the command for it's subcommands (badly). It will also allow you to extend the command with multiple subcommands, and it will use [namespace ensemble]'s error reporting to show all of the subcommands:
package require Tcl 8.5
proc extend {cmd subcmd arglist body} {
if {[namespace exists _extend::$cmd]} {
set namespace_script {
namespace eval _extend::%CMD% {
proc %SUB% {%ARGS%} {%BODY%}
namespace ensemble configure ::%CMD% -subcommands \
[concat [namespace ensemble conf ::%CMD% -sub] %SUB%]
}
}
} else {
set namespace_script {
namespace eval _extend::%CMD% {
proc %SUB% {%ARGS%} {%BODY%}
rename %CMD% _extend::%CMD%::%CMD%
# introspect the [%CMD%] subcommands (clumsily)
catch {_extend::%CMD%::%CMD% asdfasdfasdf} errmsg
regsub {^bad option ".*?": must be } $errmsg {} errmsg
regsub { or } $errmsg { } errmsg
foreach subcmd [regexp -all -inline {\w+} $errmsg] {
dict set d $subcmd [list _extend::%CMD%::%CMD% $subcmd]
}
namespace ensemble create -command ::%CMD% \
-map $d \
-subcommands [concat [dict keys $d] %SUB%]
}
}
}
set repl [list %CMD% $cmd %SUB% $subcmd %ARGS% $arglist %BODY% $body]
uplevel #0 [string map $repl $namespace_script]
}So that:
% close [open file1 w]
% close [open file2 w]
% extend file newer {a b} {expr {[file mtime $a] > [file mtime $b]}}
::file
% extend file older {a b} {expr {![file newer $a $b]}}
% file newer file1 file2
0
% file older file1 file2
1Note the "unknown subcommand" error message includes the new subcommands "newer" and "older":
% file foobar unknown or ambiguous subcommand "foobar": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, newer, normalize, older, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, type, volumes, or writable
And I get to implement my pet TIP 65 [L1 ] like so:
extend info formalargs {procname} {
set argspec [list]
foreach arg [info args $procname] {
if {[info default $procname $arg value]} {
lappend argspec [list $arg $value]
} else {
lappend argspec $arg
}
}
return $argspec
}Although, based on chan mode, here's the way to do it with namespace ensemble
set map [namespace ensemble configure ::info -map] dict set map formalargs ::path::to::proc_that_implements_formalargs namespace ensemble configure ::info -map $map
Now the ensemble includes the new subcommand, and the unknown subcommand error message contains it as well.