stacking

# stack_proc.tcl
 # Copyright 2001 by Larry Smith
 # Wild 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 can nest to any depth.  You can eliminate the
 # latest proc with pullproc, or call up the stack to
 # each previously-stacked proc in turn with callprev,
 # or merely retrieve its name with getprev.

 proc pushproc { name arguments { code "" } } {
  if ![ string equal [ info commands $name ] "" ] {
    upvar #0 $name stack
    if [ info exists stack ] {
      incr stack
    } else {
      set stack 1
    }
    rename $name $name-$stack
  }
  if [ string equal $code "" ] {
    rename $arguments $name
  } else {
    proc $name $arguments $code
  }
 }

 proc pullproc { name { newname "" }} {
  upvar #0 $name stack
  if [ info exists stack ] {
    rename $name $newname
    rename $name-$stack $name
    incr stack -1
    if { $stack == 0 } {
      unset stack
    }
  }
 }

 proc getprev { } {
  set name [lindex [ info level -1 ] 0]
  if { "$name" == "callprev" } {
    set name [lindex [ info level -2 ] 0]
  }
  set curproc ""
  regexp {([^-]*)-([0-9]*)} $name -> procname curproc
  if ![info exists procname] {
    set procname $name
  }
  upvar #0 $procname stack
  if { "$curproc" == "" } {
    if [ info exists stack ] {
      set curproc $stack
    } else {
      return ""
    }
  } else {
    incr curproc -1
  }
  if { $curproc == 0 } {
    return ""
  }
  return $procname-$curproc
 }

 proc callprev { args } {
  set name [ getprev ]
  if ![string equal $name "" ] {
    return [ eval $name $args ]
  }
  return ""
 }



 #example

 source stack_proc.tcl

 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]

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.

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

Metaprogramming