Posted to tcl by dgood` at Mon Nov 25 20:40:05 GMT 2013view pretty
package require log namespace import log::log* package provide replace 1.0 namespace eval replace { namespace export replace namespace export restore namespace export restoreAll proc replace {procName newProc} { uplevel 1 set procName [namespace which $procName] set newProc [namespace which $newProc] set name [namespace tail $procName] set ns [namespace qualifiers $procName] set newName ${ns}::_$name log debug "procName = $procName, newProc = $newProc, name = $name, newName = $newName, ns = $ns, which = [namespace which _$name]" # Only save the original procName, but always substitute the new body if {[info commands $newName] eq {}} { log debug "saving $procName to $newName" rename $procName $newName } else { log debug "$procName is already replaced" } proc $procName [info args $newProc] [info body $newProc] } # Restores a command which was renamed by replace proc restore {origName} { set modName [namespace which _$origName]; # Current fully qualified name if {$modName eq {}} { log debug "can't restore $origName, _$origName doesn't exist" return } set ns [namespace qualifiers $modName] set origName ${ns}::[namespace tail $origName]; # Original fully qualified name if {[info procs $origName] ne ""} { rename $origName {} } rename $modName $origName log debug "restored $origName" } proc restoreAll {} { foreach proc [info commands _*] {restore [string range $proc 1 end]} } }