Posted to tcl by JMN at Wed Jul 30 18:09:50 GMT 2025view raw

  1. chan configure stdin -blocking 0 -buffering none
  2. #puts stderr "stdinconf: [chan configure stdin]"
  3. set RST \x1b\[0m
  4. set C \x1b\[32m ;#child colour green
  5. set P \x1b\[33m ;#parent colour yellow
  6.  
  7.  
  8. proc usage {args} {
  9. puts stderr "rcvd : [info script] $args"
  10. puts stderr "usage:"
  11. puts stderr " [info script] pump <persecond> <maxcount>"
  12. puts stderr " [info script] parent"
  13. puts stderr " [info script] child <delay_ms>"
  14. puts stderr \n
  15. puts stderr "e.g:"
  16. puts stderr " >tclsh"
  17. puts stderr " %chan configure stdin -blocking 0"
  18. puts stderr " %tclsh [info script] pump 35 50 | tclsh [info script] parent"
  19. exit 0
  20. }
  21.  
  22. proc read_child {chan} {
  23. if {![eof $chan]} {
  24. puts stdout [read $chan]
  25. flush stdout
  26. } else {
  27. set ::done 1
  28. }
  29. }
  30.  
  31. proc pump_schedule {} {
  32. upvar ::counter c
  33. upvar ::maxcount maxcount
  34. if {$::forever_pump} {
  35. if {$maxcount > 0 && $c >= $maxcount} {
  36. set ::forever_pump 0
  37. } else {
  38. after idle [list after 0 ::pump_emit]
  39. }
  40. tailcall after $::ms ::pump_schedule
  41. } else {
  42. after idle [list ::pump_end]
  43. }
  44. }
  45. proc pump_emit {} {
  46. upvar ::counter c
  47. if {[catch {
  48. puts -nonewline stdout .[incr c]
  49. }]} {
  50. set ::forever_pump 0
  51. }
  52. flush stdout
  53. }
  54. proc pump_end {} {
  55. puts stderr "pump-done"
  56. flush stderr
  57. flush stdout
  58. }
  59.  
  60. switch -- [lindex $::argv 0] {
  61. pump {
  62. if {$::argc != 3} {usage {*}$::argv}
  63. set persec [lindex $::argv 1]
  64. set maxcount [lindex $::argv 2]
  65. if {$persec > 1000} {
  66. puts stderr "WARNING: (>1000) sub millisecond scheduling not available - will go full speed"
  67. flush stderr
  68. after 500
  69. }
  70. chan configure stdout -blocking 1 -buffering none
  71. set counter -1
  72. set ms [expr {1000 / $persec}]
  73. set ::forever_pump 1
  74.  
  75. pump_schedule
  76. vwait ::forever_pump
  77. }
  78. parent {
  79. if {$::argc != 1} {usage {*}$::argv}
  80. puts stderr "${::P}parent$RST"
  81. after 250
  82. set parent_chunk1 [read stdin 8]
  83. set rdout [open |[concat tclsh [info script] child 150 2>@stderr <@stdin] RDONLY]
  84. chan conf $rdout -blocking 0 -buffersize 1
  85. chan event $rdout readable [list ::read_child $rdout]
  86.  
  87. puts -nonewline stderr $::P$parent_chunk1$::RST
  88. flush stderr
  89.  
  90. after 10000 {set ::done 1}
  91. vwait ::done
  92. puts stderr parent-tail-read
  93. while {![eof stdin]} {
  94. puts -nonewline stderr [read stdin]
  95. flush stderr
  96. }
  97. puts stdout \n${::P}parent-done$::RST
  98. flush stdout
  99. }
  100. child {
  101. if {$::argc != 2} {usage $::argv}
  102. set delay_ms [lindex $::argv 1]
  103. puts stderr "\n${::C}child$::RST"
  104. after $delay_ms
  105. puts stderr ${::C}[read stdin 16]$::RST
  106. #puts stderr ${::C}[read stdin]$::RST
  107. puts stderr "child-done"
  108. flush stderr
  109. exit 0
  110. }
  111. default {usage $::argv}
  112. }
  113. exit 0
  114.  

Add a comment

Please note that this site uses the meta tags nofollow,noindex for all pages that contain comments.
Items are closed for new comments after 1 week