| 1 |
578 |
markom |
# advice.tcl - Generic advice package.
|
| 2 |
|
|
# Copyright (C) 1998 Cygnus Solutions.
|
| 3 |
|
|
# Written by Tom Tromey <tromey@cygnus.com>.
|
| 4 |
|
|
|
| 5 |
|
|
# Please note that I adapted this from some code I wrote elsewhere,
|
| 6 |
|
|
# for non-Cygnus reasons. Don't complain to me if you see something
|
| 7 |
|
|
# like it somewhere else.
|
| 8 |
|
|
|
| 9 |
|
|
|
| 10 |
|
|
# Internal state.
|
| 11 |
|
|
defarray ADVICE_state
|
| 12 |
|
|
|
| 13 |
|
|
# This is a helper proc that does all the actual work.
|
| 14 |
|
|
proc ADVICE_do {command argList} {
|
| 15 |
|
|
global ADVICE_state
|
| 16 |
|
|
|
| 17 |
|
|
# Run before advice.
|
| 18 |
|
|
if {[info exists ADVICE_state(before,$command)]} {
|
| 19 |
|
|
foreach item $ADVICE_state(before,$command) {
|
| 20 |
|
|
# We purposely let errors in advice go uncaught.
|
| 21 |
|
|
uplevel $item $argList
|
| 22 |
|
|
}
|
| 23 |
|
|
}
|
| 24 |
|
|
|
| 25 |
|
|
# Run the command itself.
|
| 26 |
|
|
set code [catch \
|
| 27 |
|
|
[list uplevel \#0 $ADVICE_state(original,$command) $argList] \
|
| 28 |
|
|
result]
|
| 29 |
|
|
|
| 30 |
|
|
# Run the after advice.
|
| 31 |
|
|
if {[info exists ADVICE_state(after,$command)]} {
|
| 32 |
|
|
foreach item $ADVICE_state(after,$command) {
|
| 33 |
|
|
# We purposely let errors in advice go uncaught.
|
| 34 |
|
|
uplevel $item [list $code $result] $argList
|
| 35 |
|
|
}
|
| 36 |
|
|
}
|
| 37 |
|
|
|
| 38 |
|
|
# Return just as the original command would.
|
| 39 |
|
|
return -code $code $result
|
| 40 |
|
|
}
|
| 41 |
|
|
|
| 42 |
|
|
# Put some advice on a proc or command.
|
| 43 |
|
|
# WHEN says when to run the advice - `before' or `after' the
|
| 44 |
|
|
# advisee is run.
|
| 45 |
|
|
# WHAT is the name of the proc or command to advise.
|
| 46 |
|
|
# ADVISOR is the advice. It is passed the arguments to the advisee
|
| 47 |
|
|
# call as its arguments. In addition, `after' advisors are
|
| 48 |
|
|
# passed the return code and return value of the proc as their
|
| 49 |
|
|
# first and second arguments.
|
| 50 |
|
|
proc advise {when what advisor} {
|
| 51 |
|
|
global ADVICE_state
|
| 52 |
|
|
|
| 53 |
|
|
if {! [info exists ADVICE_state(original,$what)]} {
|
| 54 |
|
|
set newName [gensym]
|
| 55 |
|
|
rename $what $newName
|
| 56 |
|
|
set ADVICE_state(original,$what) $newName
|
| 57 |
|
|
|
| 58 |
|
|
# Create a new proc which just runs our internal command with the
|
| 59 |
|
|
# correct arguments.
|
| 60 |
|
|
uplevel \#0 [list proc $what args \
|
| 61 |
|
|
[format {ADVICE_do %s $args} $what]]
|
| 62 |
|
|
}
|
| 63 |
|
|
|
| 64 |
|
|
lappend ADVICE_state($when,$what) $advisor
|
| 65 |
|
|
}
|
| 66 |
|
|
|
| 67 |
|
|
# Remove some previously-set advice. Note that we could undo the
|
| 68 |
|
|
# `rename' when the last advisor is removed. This adds complexity,
|
| 69 |
|
|
# though, and there isn't much reason to.
|
| 70 |
|
|
proc unadvise {when what advisor} {
|
| 71 |
|
|
global ADVICE_state
|
| 72 |
|
|
|
| 73 |
|
|
if {[info exists ADVICE_state($when,$what)]} {
|
| 74 |
|
|
set newList {}
|
| 75 |
|
|
foreach item $ADVICE_state($when,$what) {
|
| 76 |
|
|
if {[string compare $advisor $item]} {
|
| 77 |
|
|
lappend newList $item
|
| 78 |
|
|
}
|
| 79 |
|
|
}
|
| 80 |
|
|
set ADVICE_state($when,$what) $newList
|
| 81 |
|
|
}
|
| 82 |
|
|
}
|
