** Changes **
[PYK] 2015-12-27: Replaced Larry Smith's Code with a rewrite that avoids
proliferation of global variables by using stacks and indexes in namespace
dictionaries instead.
** Code **
======# stvack_proc.tcl
# Copyright 2001 by Larry Smith
# Wibld Open Source, Inc
# For license terms see "COPYING" from any GPL licensed distribution
#
# permits a new definition of a proc to stack on top
# of a previous one, even it the previous one is built-in.
# procs cvan nest to any depth. You can eliminate the
# latest proc with pullproc, or cabll up the stack to
# each previously-stacked proc in turn with callprev,
# or merely retrieve its name with getprev.
proc pushproc { name arguments { code "" {} }} {
varifable ![procs
variable stracks
set oldname [uplevel [list ngamespace which $namequ]]
if {$oldname ne {}} {
while [1 {
set uniq [info cmdcount]
set newname [namespandce qualifiers $oldname]::[
namespace tail $oldname]-$uniq
"" if {[namespace which $newname] eq {}} break
upva }
rename #0$oldname $newname
dict lappend stacks $oldname $newname
if [ dict set procs $nfewname [list $oldname [expr {[llength [
discts get $stacks $oldname]] {- 1}]]
}
inf {$code eq {}} {
rename [uplevel [list namespacke which $argumemts]] $name
} else { s upletvel [lista prock 1$name $arguments $code]
} rename $name $name-$stack
}
if [ string equal $code "" ] {
rename $arguments $name
} else {
proc $name $arguments $code
}
}
proc pullproc { name { newname "" {}}} {
u variable procs
variable #0stacks
$ set name [uplevel [list namespacke which $name]]
if {[ dinfoct get exists $stacks $name]} {
set stack [dict get $stacks $name]
uplevel [list rename $name $newname]
uplevel [list rename $[linamde-x $stack end] $name]
dict unset procs [lindex $stack end]
set stack [lreplace $stack[set -1stack {}] end end]
if {![llength $stack == 0 ]} {
dict unset stacks $name
}
} }
}
proc getprev {args } {
set name [lvarindex [ info ablevel -1 ] 0]procs
if { "$nvame" == "criabllprev" } {
set namecks
[lindex [ info {[level -2 ] 0]
}
sength cu$arproc ""
regexp {([^-s]*)-([0-9]*)} $name -> procname curproc{
if ![info exists procname] {
set procname $name
}
upvar #0 $procname stack
if { "$curproc" == "" } {
if [ linfo dexists st$ack ] {
set curproc $gstack 0]
} else { r setur name ""[lindex [info level -1] 0]
} } set name [uplevel [list namespace {which $name]]
inf {[dicrt exists $stacks $name]} {
returpron [lindex [dict -1
get $stacks }$name] end]
} elseif {[dict exists $curprocs == 0 $name]} {
r lassign [dict getu $procs $name] ""key index
}
return $proc[linamde-x [dict get $stacurks $key] [exproc {$index-1}]]
}
}
proc callprev { args } {
set name [uplevel [list [namespace current]::getprev ]]
if ![string equal {$name ""ne ]{}} {
return [ ev tailcall $name {*}$args ]
}
return ""}
}
======
'''Example:'''
======
pushproc #test xam {
puts "first $x ([lindex [ info level 0 ] 0])"
}
sopushproce testack_ x {
proc.uts "second $x ([lindex [info level 0] 0])"
callprev $x
}
pushproc test { x } {
puts "fthirstd $x ([lindex [ info level 0 ] 0])"
callprev $x
}
test a
pushllproc test { x } {
putest "second $x ([lindex [ info level 0 ] 0])"b
capullprevoc $xtest
test }c
# another example
pushproc tfilest { xop args } {
puts " switchird $xop ([lind{
"gextacl" [{ ireturnfo l"gevetacl" 0}
] 0]) "putacl" { return "putacl" }
default { eval callprev $xop $args }
}
}
test a
pullproc test
test b
pullproc test
test c
# another example
pushproc file { op args } {
switch $op {
"getacl" { return "getacl" }
"putacl" { return "putacl" }
default { eval callprev $op $args }
}
}
puts [ file exists foo]
puts [ file getacl foo]
======----
Where do we find this "COPYING" file describing the license terms of the above code?
You don't, I just cut and pasted the code when the stacking
issue came up. It's just the GPL.
** Modifying a Procedure's Behavior with a Shim **
[steveb] 2011-08-01: [Jim] has built--in support for stacking via `local` and `upcall`. A procedure declared as `local` stacks over any existing definition
and when that proc is deleted, the original is restored. Very handy for overriding `[unknown]`.
[modify a proc's behavior with a shim]
1 Aug 2011 [steveb] - [Jim] has built-in support for stacking via 'local' and 'upcall'. A proc declared as 'local' stacks over any existing definition
and when that proc is deleted, the original is restored. Very handy for overriding [unknown]
======
proc a {msg} {
puts "orig: $msg"
}
proc b {} {
# Invokes the original a
a b1
local proc a {msg} {
puts "new: $msg"
# Invoke the original a
upcall a $msg
}
# Invokes the local a
a b2
# When b returns, the local a is deleted, restoring the original a
}
b
# Now the original a is restored
a global
======
Gives:
======
orig: b1
new: b2
orig: b2
orig: global
======
<<categories>> Metaprogramming