Richard Suchenwirth 2006-02-07 - For doing some OO sugar, I needed a way that interp aliases are cleaned up when the proc scope where they were defined is left. Here's my solution with a guard variable, to which an unset trace is tied:
proc alias {name = args} {
upvar 1 __$name __$name
eval [list interp alias {} $name {}] $args
set __$name ""
trace var __$name u "interp alias {} $name {} ;#"
}
proc test {} {
alias up = string toupper
return [up hello],[up world]
}
146 % test
HELLO,WORLD
277 % up this
invalid command name "up"NEM cautions though that the scope of aliases aren't really proc local, e.g.:
% proc test2 {} {
alias up = string toupper
return [test],[up more]
}
% test2
invalid command name "up"RS Right. I should better have said "short-lived". But in my use case, accidentally reusing a name is less of a concern - it will be unambiguous handles to objects, for the popular
$obj method arg arg...
style. My worry was that the alias table would run full, if 10,000s of such were created every hour...
male 2006-02-08: perhabs the code below solves some issues:
namespace eval ::alias {
namespace eval cache {
}
proc this {} [list return [namespace current]];
proc parent {} [list return [namespace parent [this]]];
proc scope {command args} {
return [concat [namespace code $command] $args];
}
proc resolve {varName {element ""}} {
set varName [namespace which -variable $varName];
if {[array exists $varName] == 1} {
set varName [format {%s(%s)} $varName $element];
}
return $varName;
}
variable aliases;
variable contexts;
array unset aliases;
array set aliases [list];
array unset contexts;
array set contexts [list];
proc evalCB {alias args} {
variable aliases;
variable contexts;
# get the current context
#
set context [lindex [info level -2] 0];
# check if an alias in this context is really defined
#
if {[info exists contexts($context.$alias)] == 0} {
error "no such defined proc-local alias \"$alias\" in the procedure \"$context\"";
}
# evaluate the alias inside the context
#
return [uplevel 2 $contexts($context.$alias) $args];
}
proc deleteCB {context alias} {
variable aliases;
# remove the definition context from the list of alias definition contexts
#
set aliases($alias) [lreplace \
$aliases($alias) \
[set idx [lsearch -exact $aliases($alias) $context] $idx \
];
if {[llength $aliases($alias)] == 0} {
unset aliases($alias);
unset contexts($context.$alias);
interp alias [list] $alias [list];
}
return;
}
proc alias {alias args} {
variable aliases;
variable contexts;
# requesting the proc-local context
#
set context [lindex [info level -1] 0];
# save the context in the list of contexts to prevent an alias deletion
# before the last context defining the same alias collapses
#
lappend aliases($alias) $context;
set contexts($context.$alias) $args;
# set our deletion "flag"
#
upvar 1 [resolve cache::$alias] deleteFlag;
set deleteFlag "";
# define the "real" alias
#
eval [list interp alias [list] $alias [list]] [scope evalCB $alias];
# activate the alias deletion callback
#
trace add variable deleteFlag unset [scope deleteCB $context $alias];
}
namespace export -clear alias;
}
namespace import -force ::alias::*;
# define an alias in test
#
proc test {} {
alias up string toupper
return [up hello],[up world]
}
# define an alias in test2
# with the same name than in test
#
proc test2 {} {
alias up string toupper
return [test],[up more]
}
# define an alias in test3
# with the same name than in test and test2,
# but with a different "meaning"
#
proc test3 {} {
alias up string totitle
return [test2],[up less]
}Here the examples:
% test; HELLO,WORLD % test2; HELLO,WORLD,MORE % test3; HELLO,WORLD,MORE,Less