Posted to tcl by dgood` at Mon Nov 25 20:40:05 GMT 2013view raw

  1. package require log
  2. namespace import log::log*
  3.  
  4. package provide replace 1.0
  5.  
  6. namespace eval replace {
  7.  
  8. namespace export replace
  9. namespace export restore
  10. namespace export restoreAll
  11.  
  12. proc replace {procName newProc} {
  13. uplevel 1
  14. set procName [namespace which $procName]
  15. set newProc [namespace which $newProc]
  16. set name [namespace tail $procName]
  17. set ns [namespace qualifiers $procName]
  18. set newName ${ns}::_$name
  19. log debug "procName = $procName, newProc = $newProc, name = $name, newName = $newName, ns = $ns, which = [namespace which _$name]"
  20. # Only save the original procName, but always substitute the new body
  21. if {[info commands $newName] eq {}} {
  22. log debug "saving $procName to $newName"
  23. rename $procName $newName
  24. } else {
  25. log debug "$procName is already replaced"
  26. }
  27. proc $procName [info args $newProc] [info body $newProc]
  28. }
  29.  
  30. # Restores a command which was renamed by replace
  31. proc restore {origName} {
  32. set modName [namespace which _$origName]; # Current fully qualified name
  33. if {$modName eq {}} {
  34. log debug "can't restore $origName, _$origName doesn't exist"
  35. return
  36. }
  37. set ns [namespace qualifiers $modName]
  38. set origName ${ns}::[namespace tail $origName]; # Original fully qualified name
  39. if {[info procs $origName] ne ""} {
  40. rename $origName {}
  41. }
  42. rename $modName $origName
  43. log debug "restored $origName"
  44. }
  45.  
  46. proc restoreAll {} {
  47. foreach proc [info commands _*] {restore [string range $proc 1 end]}
  48. }
  49. }
  50.