Posted to tcl by dgood` at Mon Nov 25 20:40:05 GMT 2013view raw
- 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]}
- }
- }