# 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: predtask.tcl,v 1.7 2006/03/18 01:43:02 jfontain Exp $


class predictor {

    class task {

        set (marker) <R>

        proc task {this code args} switched {$args} {
            if {$global::noRPath} {
                set command R
            } else {
                set command $global::rPath
            }
            set task [new lineTask\
                -command "nice $command --vanilla --slave 2>@stdout" -access r+ -translation lf -begin 0\
                -callback "predictor::task::read $this"\
            ]
            set ($this,task) $task
            set ($this,lines) {}
            switched::complete $this
            lineTask::begin $task
            # add marker to detect communication, system, ... errors unrelated to R, in which case the marker will not appear:
            lineTask::write $task "cat('$(marker)\\n');$code"
        }

        proc ~task {this} {
            catch {delete $($this,task)}
        }

        proc options {this} {
            return [::list\
                [::list -command {} {}]\
            ]
        }

        proc set-command {this value} {}

        proc read {this line} {                              ;# read remote data now that it is available and possibly handle errors
            set task $($this,task)
            switch $lineTask::($task,event) {
                end {         ;# either valid data availability as R exited, rsh connection was closed, or connection broken for ssh
                    end $this
                }
                error {                                                                          ;# some communication error occured
                    set ($this,communication,error) $lineTask::($task,error)
                }
                timeout {                                                                     ;# remote host did not respond in time
                    ### implement when multiple hosts functionality implemented ###
                    set $($this,communication,error) "timeout error: unexpected (please contact author)"
                }
            }
            lappend ($this,lines) [string trim $line]
        }

        proc end {this} {                                                         ;# remote task is finished, gather data and errors
            delete $($this,task)
            foreach line $($this,lines) {
                if {$line eq $(marker)} {
                    # shows that R was successfully executed, but result is not yet available (may not become so if errors)
                    set ($this,lists) {}
                    continue
                }
                switch -glob [string tolower $line] {
                    {{*}} {                                                                       ;# result must lists by convention
                        set ($this,lists) $line
                    }
                    *error* {                                                                                        ;# error header
                        if {[info exists ($this,errors)]} {append ($this,errors) { }}                       ;# concatenate all lines
                        append ($this,errors) $line
                    }
                    *warning* {                                                                                    ;# warning header
                        if {[info exists ($this,warnings)]} {append ($this,warnings) { }}                   ;# concatenate all lines
                        append ($this,warnings) $line
                    }
                    default {
                        if {[info exists ($this,errors)]} {    ;# consider that what follows the error header is part of the message
                            append ($this,errors) { }
                            append ($this,errors) $line
                        } elseif {[info exists ($this,warnings)]} {
                            append ($this,warnings) { }
                            append ($this,warnings) $line   ;# consider that what follows the warnings header is part of the message
                        } else {
                            if {[info exists ($this,information)]} {
                                append ($this,information) { }
                            }
                            append ($this,information) $line
                        }
                    }
                }
            }
            if {$switched::($this,-command) ne ""} {
                uplevel #0 $switched::($this,-command)                                      ;# always invoke command at global level
            }
        }

        proc processIdentifiers {this} {
            return [lineTask::processIdentifiers $($this,task)]
        }

    }

}
