** 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 **


======
variable stacks
variable procs

proc pushproc {name arguments {code {}}} {
    variable procs
    variable stacks
    set oldname [uplevel [list namespace which $name]]
    if {$oldname ne {}} {
        while 1 {
            set uniq [info cmdcount]
            set newname [namespace qualifiers $oldname]::[
                namespace tail $oldname]-$uniq
            if {[namespace which $newname] eq {}} break
        }
        rename $oldname $newname
        dict lappend stacks $oldname $newname
        dict set procs $newname [list $oldname [expr {[llength [
            dict get $stacks $oldname]] - 1}]]
    }
    if {$code eq {}} {
        rename [uplevel [list namespace which $argumemts]] $name
    } else {
        uplevel [list proc $name $arguments $code]
    }
}

proc pullproc {name {newname {}}} {
    variable procs
    variable stacks
    set name [uplevel [list namespace which $name]]
    if {[dict get exists $stacks $name]} {
        set stack [dict get $stacks $name]
        uplevel [list rename $name $newname]
        uplevel [list rename [lindex $stack end] $name]
        dict unset procs [lindex $stack end] 
        set stack [lreplace $stack[set stack {}] end end]
        if {![llength $stack]} {
            dict unset stacks $name
        }
    }
}

proc getprev args {
    variable procs
    variable stacks
    if {[llength $args]} {
        set name [lindex $args 0]
    } else {
        set name [lindex [info level -1] 0]
    }
    set name [uplevel [list namespace which $name]]
    if {[dict exists $stacks $name]} {
        return [lindex [dict get $stacks $name] end]
    } elseif {[dict exists $procs $name]} {
        lassign [dict get $procs $name] key index
        return [lindex [dict get $stacks $key] [expr {$index-1}]]
    }
}

proc callprev args {
    set name [uplevel [list [namespace current]::getprev]]
    if {$name ne {}} {
        tailcall $name {*}$args
    }
}
======


'''Example:'''

======
pushproc test x {
    puts "first $x ([lindex [ info level 0 ] 0])"
}

pushproc test x {
    puts "second $x ([lindex [info level 0] 0])"
    callprev $x
}

pushproc test x {
    puts "third $x ([lindex [info level 0] 0])"
    callprev $x
}

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]
======



** 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]`.

======
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