# copyright (C) 1997-2006 Jean-Luc Fontaine (mailto:jfontain@free.fr)
# this program is free software: please read the COPYRIGHT file enclosed in this package or use the Help Copyright menu

# $Id: linetask.tcl,v 1.19 2006/01/28 19:16:59 jfontain Exp $


package provide linetask [lindex {$Revision: 1.19 $} 1]


stooop::class lineTask {

    proc lineTask {this args} switched {$args} {
        set ($this,error) {}                                                                                        ;# error message
        set ($this,event) {}                                                                          ;# data, error, timeout or end
        switched::complete $this
        if {$switched::($this,-begin)} {
            begin $this
        }
    }

    proc ~lineTask {this} {
        if {[info exists ($this,channel)]} {
            end $this 1
        }
        if {[info exists ($this,worker)]} {
            stooop::delete $($this,worker)
        }
    }

    proc options {this} {                                                ;# note: use minimum buffer size since no buffering is used
        return [list\
            [list -access r r]\
            [list -begin 1 1]\
            [list -blocking 1 1]\
            [list -buffering none none]\
            [list -buffersize 10 10]\
            [list -callback {} {}]\
            [list -command {} {}]\
            [list -encoding binary binary]\
            [list -eofchar {} {}]\
            [list -threaded 0 0]\
            [list -timeout 60 60]\
            [list -translation binary binary]\
        ]
    }

    foreach option {-access -begin -blocking -buffering -buffersize -encoding -eofchar -translation} {
        proc set$option {this value} "
            if {\$switched::(\$this,complete)} {
                error {option $option cannot be set dynamically}
            }
        "
    }

    proc set-threaded {this value} {
        if {$switched::($this,complete)} {
            error {option -threaded cannot be set dynamically}
        }
        if {[catch {package present Thread}]} {error {Thread package is required in threaded mode}}
        if {[catch {package present threads}]} {error {threads package is required in threaded mode}}
        set ($this,worker) [stooop::new worker]
    }

    # invoked followed by data line read, or empty string in case of data end or error (check event member to know which)
    proc set-callback {this value} {}

    # command may open a bi-directionnal pipe, with read and write access, such as a ssh connection:
    #   "ssh -T -l user host 2>@stdout" followed by writes, such as "ps -aux"
    # or command may open a uni-directionnal pipe, with read only access and embedded remote command, such as a rsh connection:
    #   "rsh -n -l user host ps -aux" in which case data is returned once, then pipe closed
    # note: due to Tcl pipe processing mode (see Tcl exec command), command elements including spaces are best surrounded by double
    #  quotes. For example, sh -c 'echo OK' works whereas sh -c 'echo OK' fails.
    proc set-command {this value} {
        if {[info exists ($this,channel)]} {
            error {option -command cannot be set while command is being executed}
        }
        if {[string match |* [string trimleft $value]]} {
            error {command cannot start by a pipe character}
        }
    }

    proc set-timeout {this value} {                                                                                    ;# in seconds
        if {$switched::($this,complete)} {
            error {option -timeout cannot be set dynamically}
        }
        if {($value < 1) || ($value > 86400)} {
            error {timeout must be between 1 and 86400 seconds (1 day)}
        }
    }

    proc channelEvent {this} {
        timer $this 0
        set line {}
        if {[catch {set line [gets $($this,channel)]} message]} {
            set ($this,error) $message
            set ($this,event) error
        } elseif {[eof $($this,channel)]} {
            # note: line is valid data here when -command contains remote command that generates remote data back
            if {[end $this 1]} {
                set ($this,event) end
            } else {
                set ($this,event) error                                                         ;# with message set in end procedure
                after idle "
                    set lineTask::($this,event) end
                    set lineTask::($this,error) {}
                    $switched::($this,-callback) {}
                    set lineTask::($this,event) {}
                "
            }
        } else {
            set ($this,event) data
        }
        uplevel #0 $switched::($this,-callback) [list $line]                                ;# always invoke command at global level
        set ($this,event) {}                                                                                          ;# reset event
        set ($this,error) {}                                                                                    ;# and error message
    }

    proc threadEvent {this line errorInformation} {
        timer $this 0
        if {[string length $errorInformation] > 0} {                                                             ;# an error occured
            set ($this,error) $line
            set ($this,event) error
            set line {}                                                               ;# contained the error message, not valid data
        } elseif {[worker::evaluate $($this,worker) "eof $($this,channel)"]} {     ;# no waiting here as status is readily available
            # note: line is valid data here in when -command contains remote command that generates remote data back
            if {[end $this 1]} {
                set ($this,event) end
            } else {
                set ($this,event) error                                                         ;# with message set in end procedure
                after idle "
                    set lineTask::($this,event) end
                    set lineTask::($this,error) {}
                    $switched::($this,-callback) {}
                    set lineTask::($this,event) {}
                "
            }
        } else {
            set ($this,event) data
        }
        uplevel #0 $switched::($this,-callback) [list $line]                                ;# always invoke command at global level
        set ($this,event) {}
        set ($this,error) {}
    }

    proc timeoutEvent {this} {
        set ($this,event) timeout
        uplevel #0 "$switched::($this,-callback) {}"
        set ($this,event) {}
        set ($this,error) {}
    }

    proc timer {this start} {                                                                                             ;# or stop
        if {[info exists ($this,timer)]} {
            after cancel $($this,timer)
            unset ($this,timer)
        }
        if {$start} {
            set ($this,timer) [after [expr {$switched::($this,-timeout) * 1000}] "lineTask::timeoutEvent $this"]
        }
    }


    # public procedures below

    proc begin {this} {
        if {[string length $switched::($this,-callback)] == 0} {
            error {no callback defined}
        }
        if {[info exists ($this,channel)]} {
            error {cannot restart while command is being executed}
        }
        timer $this 1
        set ($this,error) {}
        set ($this,event) {}
        catch {set worker $($this,worker)}
        if {[info exists worker]} {                                                                                      ;# threaded
            set channel [worker::wait $worker "open {| $switched::($this,-command)} $switched::($this,-access)"]
            worker::evaluate $worker [list\
                fconfigure $channel -blocking $switched::($this,-blocking) -buffering $switched::($this,-buffering)\
                    -buffersize $switched::($this,-buffersize) -encoding $switched::($this,-encoding)\
                    -eofchar $switched::($this,-eofchar) -translation $switched::($this,-translation)\
            ]
            if {[string equal $switched::($this,-access) r]} {       ;# pipe is read only, so command must generate remote data back
                worker::evaluate $worker "gets $channel" "lineTask::threadEvent $this"               ;# immediately wait for it then
            }
        } else {                                                                                                       ;# event mode
            set channel [open "| $switched::($this,-command)" $switched::($this,-access)]
            fconfigure $channel -blocking $switched::($this,-blocking) -buffering $switched::($this,-buffering)\
                -buffersize $switched::($this,-buffersize) -encoding $switched::($this,-encoding)\
                -eofchar $switched::($this,-eofchar) -translation $switched::($this,-translation)
            fileevent $channel readable "lineTask::channelEvent $this"                                   ;# monitor channel activity
        }
        set ($this,channel) $channel
    }

    proc write {this data} {
        timer $this 0
        set ($this,error) {}
        if {![info exists ($this,channel)]} {
            set error 1
            set message {command channel closed}
        } else {
            set channel $($this,channel)
            if {[info exists ($this,worker)]} {                        ;# synchronously wait for remote data, but in separate thread
                set error [catch {
                    worker::evaluate $($this,worker) "puts $channel [list $data]; gets $channel" "lineTask::threadEvent $this"\
                } message]
            } else {
                set error [catch {puts $channel $data} message]
            }
        }
        if {$error} {
            set ($this,error) $message
            set ($this,event) error
            after idle "$switched::($this,-callback) {}"                          ;# generate callback outside of invoking procedure
        } else {
            timer $this 1                                                                                           ;# restart timer
        }
    }

    proc flush {this} {                                             ;# must be used if -buffering is different from the none default
        if {![info exists ($this,channel)]} return
        if {[info exists ($this,worker)]} {
            worker::wait $($this,worker) "flush $($this,channel)"
        } else {
            flush $($this,channel)
        }
    }

    proc end {this {close 0}} {    ;# report status or force end of task (note: no event is generated when directly invoked by user)
        if {![info exists ($this,channel)]} {return 1}                                             ;# consider void channel as ended
        catch {set worker $($this,worker)}
        set channel $($this,channel)
        if {!$close} {
            if {[info exists worker]} {
                return [worker::evaluate $worker "eof $channel"]                   ;# no waiting here as status is readily available
            } else {
                return [eof $channel]
            }
        }
        timer $this 0
        set ($this,error) {}
        unset ($this,channel)                                                                             ;# channel is disappearing
#       catch {read $channel}              ;# avoid write on pipe with no readers error (never occured so far) by reading whole data
        if {[info exists worker]} {
            set error [catch {worker::wait $worker "close $channel"} message]
        } else {
            set error [catch {close $channel} message]
        }
        if {$error} {
            set ($this,error) $message
            return 0                                                                              ;# user should check error message
        } else {
            return 1                                                                                          ;# successfully closed
        }
    }

    proc processIdentifiers {this} {
        set list {}; catch {set list [pid $($this,channel)]}
        return $list
    }

}
