stacking

Changes edit

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 edit

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 edit

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

Metaprogramming