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]}
    }
}