scripts/process.itcl

   1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4
   2
   3 # Handlers invoked:
   4 #       output(channel, data)   - When output arrives from the child, channel is
   5 #                                                         one of {stdout, stderr}
   6 #       reaped(result)                  - When the child dies and has been reaped.  result
   7 #                                                         is the numeric result from the child.
   8 #       death_by_signal(childpid, sigal_name, msg)
   9 #                                                       - When a child is killed by a signal.  signame
  10 #                                                         is something like SIGTERM, msg is something
  11 #                                                         like "software termination signal"
  12
  13 class tlc::Process {
  14         inherit tlc::Baselog tlc::Signalsource tlc::Handlers
  15
  16         constructor {args} {}
  17         destructor {}
  18
  19         public {
  20                 variable cmd    ""
  21
  22                 method pids {}
  23                 method output {}
  24                 method stdout {}
  25                 method stderr {}
  26                 method result {}
  27                 method waitfor_output {match}
  28         }
  29
  30         private {
  31                 variable pids                   {}
  32                 variable res
  33                 variable handle
  34                 variable stderr_handle
  35                 variable buf                    {}
  36                 variable output_matches
  37                 variable output_vwaits
  38                 variable dominos
  39                 variable seq                    0
  40
  41                 method readable {}
  42                 method stderr_handler {subcmd channelId args}
  43                 method check_output_vwaits {}
  44                 method abort_waits {}
  45         }
  46 }
  47
  48
  49 body tlc::Process::constructor {args} { #<<<
  50         package require Tcl 8.5
  51
  52         array set output_matches        {}
  53         array set output_vwaits         {}
  54         array set dominos                       {}
  55
  56         tlc::Signal ::#auto signals(running) -name "$this running"
  57         tlc::Signal ::#auto signals(finished) -name "$this finished"
  58         tlc::Domino ::#auto dominos(check_output_vwaits) -name "$this check_output_vwaits"
  59
  60         configure {*}$args
  61
  62         foreach reqf {cmd} {
  63                 if {$reqf == ""} {
  64                         error "Must specify -$reqf"
  65                 }
  66         }
  67
  68         set stderr_handle       [chan create write [code $this stderr_handler]]
  69
  70         #set cmdline    [list {*}$cmd 2>@ $stderr_handle]
  71         #set cmdline    [list {*}$cmd >@ $stderr_handle]
  72         #set cmdline    [list {*}$cmd 2>@ stdout]
  73         set cmdline     [list {*}$cmd 2>@1]
  74         #set cmdline    [list {*}$cmd]
  75         #puts $stderr_handle "hello, world"; flush $stderr_handle
  76         set handle      [open |$cmdline r]
  77         chan configure $handle \
  78                         -buffering none \
  79                         -blocking 0 \
  80                         -translation binary \
  81                         -encoding binary
  82         set pids                [pid $handle]
  83         chan event $handle readable [code $this readable]
  84         $signals(running) set_state 1
  85
  86         $dominos(check_output_vwaits) attach_output [code $this check_output_vwaits]
  87 }
  88
  89 #>>>
  90 body tlc::Process::destructor {} { #<<<
  91         tlc::try {
  92                 $signals(running) set_state 0
  93         } onerr {
  94                 default {STDMSG}
  95         }
  96         if {[info exists handle]} {
  97                 tlc::try {
  98                         chan close $handle
  99                 } onerr {
 100                         default {STDMSG}
 101                 }
 102                 unset handle
 103         }
 104         if {[info exists stderr_handle]} {
 105                 tlc::try {
 106                         chan close $stderr_handle
 107                 } onerr {
 108                         default {STDMSG}
 109                 }
 110                 unset stderr_handle
 111         }
 112
 113         if {$::tcl_platform(platform) == "unix"} {
 114                 foreach pid $pids {
 115                         catch {exec kill -15 $pid}
 116                 }
 117         }
 118
 119         abort_waits
 120 }
 121
 122 #>>>
 123 body tlc::Process::readable {} { #<<<
 124         set dat [read $handle]
 125         if {$dat != ""} {
 126                 lappend buf [list stdout $dat]
 127         }
 128         if {[chan eof $handle]} {
 129                 tlc::try {
 130                         chan configure $handle -blocking 1
 131                         chan close $handle
 132                 } onerr {
 133                         CHILDSTATUS {
 134                                 lassign $::errorCode code childpid res
 135                         }
 136
 137                         CHILDKILLED {
 138                                 lassign $::errorCode code childpid sig msg
 139                                 invoke_handlers death_by_signal $childpid $sig $msg
 140                                 set res ""
 141                         }
 142
 143                         default {
 144                                 log error "Child died in an interesting way: $errmsg ($::errorCode)"
 145                                 set res ""
 146                         }
 147                 } onok {
 148                         set res 0
 149                 }
 150                 set pids                {}
 151                 unset handle
 152                 $signals(running) set_state 0
 153                 invoke_handlers reaped $res
 154                 $signals(finished) set_state 1
 155                 abort_waits
 156                 return
 157         }
 158
 159         $dominos(check_output_vwaits) tip
 160
 161         invoke_handlers output stdout $dat
 162 }
 163
 164 #>>>
 165 body tlc::Process::stderr_handler {subcmd channelId args} { #<<<
 166         switch -- $subcmd {
 167                 initialize {
 168                         lassign $args mode
 169                         if {$mode != "write"} {
 170                                 error "Only writing is supported"
 171                         }
 172                         return {
 173                                 initialize
 174                                 finalize
 175                                 watch
 176
 177                                 write
 178                                 blocking
 179                         }
 180                 }
 181
 182                 finalize {
 183                 }
 184
 185                 watch {
 186                 }
 187
 188                 write {
 189                         lassign $args data
 190                         lappend buf     [list stderr $data]
 191                         invoke_handlers output stderr $data
 192
 193                         $dominos(check_output_vwaits) tip
 194
 195                         return [string length $data]
 196                 }
 197
 198                 blocking {
 199                         lassign $args mode
 200                 }
 201
 202                 default {
 203                         error "Unsupported subcommand: ($subcmd)"
 204                 }
 205         }
 206 }
 207
 208 #>>>
 209 body tlc::Process::output {} { #<<<
 210         set build       ""
 211         foreach chunk $buf {
 212                 lassign $chunk channel data
 213                 append build $data
 214         }
 215         return $build
 216 }
 217
 218 #>>>
 219 body tlc::Process::stdout {} { #<<<
 220         set build       ""
 221         foreach chunk $buf {
 222                 lassign $chunk channel data
 223                 if {$channel != "stdout"} continue
 224                 append build $data
 225         }
 226         return $build
 227 }
 228
 229 #>>>
 230 body tlc::Process::stderr {} { #<<<
 231         set build       ""
 232         foreach chunk $buf {
 233                 lassign $chunk channel data
 234                 if {$channel != "stderr"} continue
 235                 append build $data
 236         }
 237         return $build
 238 }
 239
 240 #>>>
 241 body tlc::Process::result {} { #<<<
 242         if {![$signals(finished) state]} {
 243                 error "Child yet lives"
 244         }
 245         return $res
 246 }
 247
 248 #>>>
 249 body tlc::Process::waitfor_output {match} { #<<<
 250         if {[string match "*$match*" $buf]} {
 251                 return
 252         }
 253         set myseq       [incr seq]
 254         set output_matches($myseq)      $match
 255         set output_vwaits($myseq)       ""
 256         vwait [scope output_vwaits($myseq)]
 257         set result      $output_vwaits($myseq)
 258         array unset output_vwaits $myseq
 259
 260         switch -- [lindex $result 0] {
 261                 ok              {return}
 262                 error   {error [lindex $result 1] "" [lindex $result 2]}
 263         }
 264 }
 265
 266 #>>>
 267 body tlc::Process::check_output_vwaits {} { #<<<
 268         set plain       [output]
 269         foreach {matchseq match} [array get output_matches] {
 270                 if {[string match "*$match*" $plain]} {
 271                         array unset output_matches      $matchseq
 272                         set output_vwaits($matchseq)    [list ok]
 273                 }
 274         }
 275 }
 276
 277 #>>>
 278 body tlc::Process::abort_waits {} { #<<<
 279         $dominos(check_output_vwaits) force_if_pending
 280         foreach {matchseq match} [array get output_matches] {
 281                 array unset output_matches      $matchseq
 282                 set output_vwaits($matchseq)    [list error "child died while waiting for \"$match\"" [list child_died $match]]
 283         }
 284 }
 285
 286 #>>>
 287 body tlc::Process::pids {} { #<<<
 288         return $pids
 289 }
 290
 291 #>>>