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

AltStyle によって変換されたページ (->オリジナル) /