Posted to tcl by pooryorick at Wed Nov 13 19:39:52 GMT 2013view pretty

#! /bin/env tclsh

proc invoke {command handler} {
    lassign [chan pipe] stderr stderrin
    lappend command 2>@$stderrin
    set stdout [open |$command]

    set handler1 [namespace current]::[info cmdcount]
    coroutine $handler1 {*}$handler
    fileevent $stderrin writable [list apply {{stdout stderrin} {
        if {[chan names $stdout] eq {} || [eof $stdout]} {
            close $stderrin
        }
    }} $stdout $stderrin]
    fileevent $stdout readable [list $handler1 [list stdout $stdout]]
    fileevent $stderr readable [list $handler1 [list stderr $stderr]]
}


proc handler {onstdout onstderr onexit} {
    set done {}
    lassign [yield [info level 0]] mode chan
    while 1 {
        if {[set data [gets $chan]] eq {}} {
            if {[eof $chan]} {
                lappend done $mode
                if {[catch {close $chan} cres e]} {
                    dict with e {}
                    lassign [set -errorcode] sysmsg pid exit
                    if {$sysmsg == "NONE"} {
                        #output to stderr caused [close] to fail.  Do nothing
                    } elseif {$sysmsg eq "CHILDSTATUS"} {
                        {*}$onexit $exit
                    } else {
                        return -options $e $stderr 
                    }
                }
                if {[llength $done] == 2} {
                    return
                } else {
                    lassign [yield] mode chan
                }
            } else {
                lassign [yield] mode chan
            }
        } else {
            {*}[set on$mode] $data
            lassign [yield] mode chan
        }
    }
}



set command {
    puts stdout {hi to stdout}
    puts stderr {hi to stderr}
    exit 42
}

invoke [list tclsh <<$command] [list handler [list apply {{data} {
    puts -nonewline "here comes some stdout: "
    puts $data
}}] [list apply {{data} {
    puts -nonewline "here comes some stderr: "
    return -code error "an error!"
    puts $data
}}] [list apply {{code} {
    set ::exit 1
    puts $code
}}]]



vwait exit