Posted to tcl by aspect at Mon Jul 27 00:38:35 GMT 2015view raw

  1. #
  2. # I'm not sure how useful this is yet, but it's a little hack for reloadable classes with persistent objects
  3. # Inspiration from sdw's "Lifecycle of Objects" presentation
  4. #
  5. # It relies on some TclOO magic sauce:
  6. #
  7. # * the class of an object can be changed during its lifetime without affecting the rest of the object's state
  8. # * when a class is destroyed, its own destructor is run before its instances are destroyed
  9. # * subclassing oo::class to make a metaclass is trivial (if a little mind-bending)
  10. #
  11. # Once these are established, all that remains is how to keep track of the zombies' original class for later
  12. # resuscitation. It's tempting to try and store this in the zombie class, but a regular namespace variable
  13. # proves simpler.
  14. #
  15. #pkg -export {lazarus} zombies
  16. namespace eval zombies {
  17.  
  18. oo::class create zombie {
  19. method unknown {cmd args} {
  20. puts "Unknown method call on zombie! [self] [list $cmd] $args"
  21. throw [list TCL LOOKUP METHOD $cmd] "Zombie methods cannot be called!"
  22. }
  23. }
  24.  
  25. variable Horde ;# where zombies are arranged by (former) class
  26.  
  27. proc infect {cls} {
  28. variable Horde
  29. foreach obj [info class instances $cls] {
  30. puts "Burying $cls $obj"
  31. oo::objdefine $obj class zombie
  32. dict lappend Horde $cls $obj
  33. }
  34. }
  35.  
  36. proc come_forth {cls} {
  37. variable Horde
  38. if {[info exists Horde] && [dict exists $Horde $cls]} {
  39. foreach obj [dict get $Horde $cls] {
  40. puts "Waking zombie $cls $obj"
  41. oo::objdefine $obj class $cls
  42. }
  43. dict unset Horde $cls
  44. }
  45. }
  46.  
  47. oo::class create lazarus {
  48. superclass oo::class ;# Lazarus is a metaclass
  49. constructor args {
  50. next {*}$args ;# create the class normally
  51. ::zombies::come_forth [self object] ;# raise the dead!
  52. }
  53. destructor {
  54. ::zombies::infect [self]
  55. }
  56. }
  57.  
  58. namespace export lazarus
  59. }; namespace import zombies::*
  60.  
  61.  
  62. proc mkclass {} {
  63. lazarus create C {
  64. variable V
  65. constructor {v} {set V $v}
  66. method v {args} {set V {*}$args}
  67. }
  68. }
  69.  
  70. mkclass
  71. C create a "Hello"
  72. C create b "World"
  73. puts "[a v] [b v]; [a v] [b v Tcl!]"
  74. try {a v} on error {e o} {puts "ERROR: $e"}
  75. C destroy
  76. mkclass
  77. puts "[a v] [b v]"
  78.