Posted to tcl by colin at Wed Nov 17 00:49:24 GMT 2010view raw

  1. namespace eval tcl::unsupported namespace export yieldm
  2. namespace import tcl::unsupported::yieldm
  3.  
  4. proc reader {} {
  5. while {1} {
  6. ::yieldm
  7. }
  8. }
  9.  
  10. oo::class create ::Lamb {
  11. # reader - main coroutine supervising connection
  12. method reader {} {
  13. while {1} {
  14. ::yieldm
  15. }
  16. }
  17.  
  18. constructor {args} {
  19. variable ns [info object namespace [self]]
  20. variable coro ${ns}::coro
  21. ::coroutine $coro [self] reader ;# will crash
  22. #::coroutine $coro ::reader ;# will not crash
  23. }
  24. }
  25.  
  26. proc every {interval script} {
  27. global everyIds
  28. if {$interval eq "cancel"} {
  29. after cancel $everyIds($script)
  30. return
  31. }
  32. set everyIds($script) [after $interval [info level 0]]
  33. set rc [catch {uplevel #0 $script} result]
  34. if {$rc == [catch break]} {
  35. after cancel $everyIds($script)
  36. set rc 0
  37. } elseif {$rc == [catch continue]} {
  38. # Ignore - just consume the return code
  39. set rc 0
  40. }
  41. # TODO: Need better handling of errorInfo etc...
  42. return -code $rc $result
  43. }
  44.  
  45. every 100 {
  46. set obj [Lamb new]
  47. puts stderr "New Lamb: $obj"
  48. }
  49.  
  50. every 1000 {
  51. foreach o [info class instances ::Lamb] {
  52. catch {$o destroy}
  53. }
  54. }
  55.  
  56. every 2000 {
  57. foreach o [info class instances ::Lamb] {
  58. if {[catch {info object namespace $o} ns]} {
  59. error "$o is undead"
  60. } else {
  61. if {![namespace exists $ns]} {
  62. puts stderr "$o namespace nonexistent"
  63. }
  64. if {![llength [info commands $o]]} {
  65. puts stderr "$o no command"
  66. }
  67. }
  68. }
  69. }
  70.  
  71. set forever 0
  72. ::vwait forever