Fix too many ]s in try

[tcl-tlc-base.git] / scripts / process.itcl

# vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> ts=4 shiftwidth=4

# Handlers invoked:
#       output(channel, data)   - When output arrives from the child, channel is
#                                                         one of {stdout, stderr}
#       reaped(result)                  - When the child dies and has been reaped.  result
#                                                         is the numeric result from the child.
#       death_by_signal(childpid, sigal_name, msg)
#                                                       - When a child is killed by a signal.  signame
#                                                         is something like SIGTERM, msg is something
#                                                         like "software termination signal"

class tlc::Process {
        inherit tlc::Baselog tlc::Signalsource tlc::Handlers

        constructor {args} {}
        destructor {}

        public {
                variable cmd    ""

                method pids {}
                method output {}
                method stdout {}
                method stderr {}
                method result {}
                method waitfor_output {match}
        }

        private {
                variable pids                   {}
                variable res
                variable handle
                variable stderr_handle
                variable buf                    {}
                variable output_matches
                variable output_vwaits
                variable dominos
                variable seq                    0

                method readable {}
                method stderr_handler {subcmd channelId args}
                method check_output_vwaits {}
                method abort_waits {}
        }
}


body tlc::Process::constructor {args} { #<<<
        package require Tcl 8.5

        array set output_matches        {}
        array set output_vwaits         {}
        array set dominos                       {}

        tlc::Signal ::#auto signals(running) -name "$this running"
        tlc::Signal ::#auto signals(finished) -name "$this finished"
        tlc::Domino ::#auto dominos(check_output_vwaits) -name "$this check_output_vwaits"

        configure {*}$args

        foreach reqf {cmd} {
                if {$reqf == ""} {
                        error "Must specify -$reqf"
                }
        }

        set stderr_handle       [chan create write [code $this stderr_handler]]

        #set cmdline    [list {*}$cmd 2>@ $stderr_handle]
        #set cmdline    [list {*}$cmd >@ $stderr_handle]
        #set cmdline    [list {*}$cmd 2>@ stdout]
        set cmdline     [list {*}$cmd 2>@1]
        #set cmdline    [list {*}$cmd]
        #puts $stderr_handle "hello, world"; flush $stderr_handle
        set handle      [open |$cmdline r]
        chan configure $handle \
                        -buffering none \
                        -blocking 0 \
                        -translation binary \
                        -encoding binary
        set pids                [pid $handle]
        chan event $handle readable [code $this readable]
        $signals(running) set_state 1

        $dominos(check_output_vwaits) attach_output [code $this check_output_vwaits]
}

#>>>
body tlc::Process::destructor {} { #<<<
        tlc::try {
                $signals(running) set_state 0
        } onerr {
                default {STDMSG}
        }
        if {[info exists handle]} {
                tlc::try {
                        chan close $handle
                } onerr {
                        default {STDMSG}
                }
                unset handle
        }
        if {[info exists stderr_handle]} {
                tlc::try {
                        chan close $stderr_handle
                } onerr {
                        default {STDMSG}
                }
                unset stderr_handle
        }

        if {$::tcl_platform(platform) == "unix"} {
                foreach pid $pids {
                        catch {exec kill -15 $pid}
                }
        }

        abort_waits
}

#>>>
body tlc::Process::readable {} { #<<<
        set dat [read $handle]
        if {$dat != ""} {
                lappend buf [list stdout $dat]
        }
        if {[chan eof $handle]} {
                tlc::try {
                        chan configure $handle -blocking 1
                        chan close $handle
                } onerr {
                        CHILDSTATUS {
                                lassign $::errorCode code childpid res
                        }

                        CHILDKILLED {
                                lassign $::errorCode code childpid sig msg
                                invoke_handlers death_by_signal $childpid $sig $msg
                                set res ""
                        }

                        default {
                                log error "Child died in an interesting way: $errmsg ($::errorCode)"
                                set res ""
                        }
                } onok {
                        set res 0
                }
                set pids                {}
                unset handle

                $dominos(check_output_vwaits) tip
                invoke_handlers output stdout $dat

                $signals(running) set_state 0
                invoke_handlers reaped $res
                $signals(finished) set_state 1
                abort_waits
                return
        }

        $dominos(check_output_vwaits) tip

        invoke_handlers output stdout $dat
}

#>>>
body tlc::Process::stderr_handler {subcmd channelId args} { #<<<
        switch -- $subcmd {
                initialize {
                        lassign $args mode
                        if {$mode != "write"} {
                                error "Only writing is supported"
                        }
                        return {
                                initialize
                                finalize
                                watch

                                write
                                blocking
                        }
                }

                finalize {
                }

                watch {
                }

                write {
                        lassign $args data
                        lappend buf     [list stderr $data]
                        invoke_handlers output stderr $data

                        $dominos(check_output_vwaits) tip

                        return [string length $data]
                }

                blocking {
                        lassign $args mode
                }

                default {
                        error "Unsupported subcommand: ($subcmd)"
                }
        }
}

#>>>
body tlc::Process::output {} { #<<<
        set build       ""
        foreach chunk $buf {
                lassign $chunk channel data
                append build $data
        }
        return $build
}

#>>>
body tlc::Process::stdout {} { #<<<
        set build       ""
        foreach chunk $buf {
                lassign $chunk channel data
                if {$channel != "stdout"} continue
                append build $data
        }
        return $build
}

#>>>
body tlc::Process::stderr {} { #<<<
        set build       ""
        foreach chunk $buf {
                lassign $chunk channel data
                if {$channel != "stderr"} continue
                append build $data
        }
        return $build
}

#>>>
body tlc::Process::result {} { #<<<
        if {![$signals(finished) state]} {
                error "Child yet lives"
        }
        return $res
}

#>>>
body tlc::Process::waitfor_output {match} { #<<<
        if {[string match "*$match*" $buf]} {
                return
        }
        set myseq       [incr seq]
        set output_matches($myseq)      $match
        set output_vwaits($myseq)       ""
        vwait [scope output_vwaits($myseq)]
        set result      $output_vwaits($myseq)
        array unset output_vwaits $myseq

        switch -- [lindex $result 0] {
                ok              {return}
                error   {error [lindex $result 1] "" [lindex $result 2]}
        }
}

#>>>
body tlc::Process::check_output_vwaits {} { #<<<
        set plain       [output]
        foreach {matchseq match} [array get output_matches] {
                if {[string match "*$match*" $plain]} {
                        array unset output_matches      $matchseq
                        set output_vwaits($matchseq)    [list ok]
                }
        }
}

#>>>
body tlc::Process::abort_waits {} { #<<<
        $dominos(check_output_vwaits) force_if_pending
        foreach {matchseq match} [array get output_matches] {
                array unset output_matches      $matchseq
                set output_vwaits($matchseq)    [list error "child died while waiting for \"$match\"" [list child_died $match]]
        }
}

#>>>
body tlc::Process::pids {} { #<<<
        return $pids
}

#>>>