evalserver.tcl

是TCL的另外一个编译（解释）器

#!/bin/sh
#\
exec wish "$0" ${1+"$@"}
#########################################
# evalServer -- Version 2.1.1
# (c) 2002 by Andreas Sievers
# executes each socket in its own interpreter
#########################################


package require Tk

proc initServer {port {putsEcho 1}} {
    if {[catch {socket -server [list EvalAccept $putsEcho] $port } info]} {
        exit
    }
}

proc EvalAccept {echoOn newsock addr port} {
    global eval
    set eval(cmdbuf,$newsock) {}
    set eval(run,$newsock) 0
    set eval(interp,$newsock) [interp create]
    set eval(busy) 0
    interp eval $eval(interp,$newsock) set sock $newsock
    interp eval $eval(interp,$newsock) set echoOn $echoOn
    interp eval $eval(interp,$newsock) set interp $eval(interp,$newsock)
    $eval(interp,$newsock) alias ExitApp exitApp
    if {$echoOn == 1} {
        $eval(interp,$newsock) alias ASEDServerEcho asedServerEcho
    }
    fileevent $newsock readable [list EvalRead $newsock $eval(interp,$newsock)]
    fconfigure $newsock -blocking 0
    if [catch {
        interp eval $eval(interp,$newsock) {
            rename puts fileputs
            proc exitProc {} {
                global interp sock
                ExitApp $interp $sock
            }
            proc echoPuts {args} {
                global interp sock
                # tk_messageBox -message "echoPuts:$args:\n$interp\n$sock"
                ASEDServerEcho $interp $sock $args
            }
            interp alias {} exit {} exitProc
                        
            proc Interp {args} {
                global sock
                set subCmd [lindex $args 0]
                if {$subCmd == "create"} {
                    set newInterp [eval origInterp $args]
                    # here we will do some aliases in the future
                    # like puts alias
                } else  {
                    eval origInterp $args
                }
            }
            
            load {} Tk
            if {$echoOn} {
                interp alias {} puts {} echoPuts
                rename interp origInterp
                origInterp alias {} interp {} Interp
            }
            
            wm withdraw .
            wm protocol . WM_DELETE_WINDOW {exit}
        }
    } info] {
        tk_messageBox -message "Connection rejected:\n$info"
        close $newsock
    }
}



proc exitApp {interp sock} {
    global eval
    
    # wait until "EvalRead" has been finished
    if {$eval(busy)} {
        after 100 "exitApp $interp $sock"
        return
    }
    interp eval $interp {
        set taskList [after info]
        foreach id $taskList {
            after cancel $id
        }
    }
    puts $sock "exitASEDServer"
    catch {close $sock}
    interp delete $interp
    unset eval(cmdbuf,$sock)
    unset eval(cmdsbuf,$sock)
    return
}

proc asedServerEcho {interpret sock args} {
    global errorInfo
    
    eval set args $args
    set argcounter [llength $args]
    switch $argcounter {
        1 {puts $sock $args;flush $sock}
        2 {
            if {[lindex $args 0] == "-nonewline"} {
                #for safety we strip "nonewline", since this could hang the app
                puts $sock [lindex $args 1]
                flush $sock
            } else {
                #we have to write to a file or socket
                set code [catch {$interpret eval fileputs $args} info]
                puts $sock info:$info
                flush $sock
                if {$code} {
                    puts $sock $errorInfo
                } else {
                    puts $sock [lindex $args 1]
                }
            }
        }
        3 {
            if {[lindex $args 0] == "-nonewline"} {
                set code [catch {$interpret eval fileputs $args} info]
                #for safety we strip "nonewline", since this could hang up communication
                puts $sock info:$info
                if {$code} {
                    puts $sock $errorInfo
                } else {
                    puts $sock [lindex $args 1]
                }
                flush $sock
            } else {
                #this is an error
                tk_messageBox -message "internal error:\nputs statement with wrong number of args:\n$args"
                exit
            }
        }
        
        default {
            #this is an error
            tk_messageBox -message "internal error:\nputs statement with wrong number of args:\n$args"
            exit
        }
    }
    flush $sock
}

proc getFirstChar {line} {
    
    set char [string index $line 0]
    for {set i 0} {$char == " " || $char == "\t"} {incr i} {
        if {$i > [string length $line]} {
            set char ""
            break
        }
        set char [string index $line $i]
    }
    return $char
}

# EvalRead  -- reads commands from the sock and executes them
proc EvalRead {sock interp} {
    fconfigure $sock -blocking 1
    global eval errorInfo errorCode
    global tcl_platform env
    
    if [eof $sock] {
        # wait until open tasks have been finished
        while {$eval(busy)== 1} {
            after 1000 {
                global eval
                catch {
                    set dummy $eval(busy)
                }
            }
            vwait eval(busy)
        }
        exitApp $interp $sock
    } else {
        set code [catch {set result [gets $sock line]}]
        if {$code} {
            # wait until open tasks have been finished
            while {$eval(busy)== 1} {
                after 1000 {
                    global eval
                    catch {
                        set dummy $eval(busy)
                    }
                }
                vwait eval(busy)
            }
            catch {close $sock}
            exit
        } elseif {$result < 0} {
            catch {fconfigure $sock -blocking 0}
            return
        }
        if {$line == {}} {
            fconfigure $sock -blocking 0
            return
        } else  {
            catch {
                #first time eval(concat will not exist)
                if $eval(concat) {
                    append eval(concatLine) $line
                    set line $eval(concatLine)
                    set eval(concatLine) ""
                }
            }
        }
        # in case of line concatenation get next line and save current one
        if {[string index $line end] == "\\"} {
            set eval(concat) 1
            set line [string trimright $line \\]
            set eval(concatLine) $line
            fconfigure $sock -blocking 0
            return
        } else  {
            set eval(concat) 0
        }
        # skip comments
        if {[getFirstChar $line] == "#"} {
            fconfigure $sock -blocking 0
            return
        }
        
        # test for special commands
        switch -- $line {
            "resetServer" {
                #abort current command
                set eval(cmdbuf,$sock) {}
                catch {fconfigure $sock -blocking 0}
                return
            }
            
            "exitASEDServer" {
                # this should be clear
                exit
            }
        }
        
        # now build command line
        eval [list append eval(cmdbuf,$sock) $line\n]
        if {[string length $eval(cmdbuf,$sock)] && [info complete $eval(cmdbuf,$sock)]} {
            # fill temporary commands buffer
            lappend eval(cmdsbuf,$sock) $eval(cmdbuf,$sock)
            # clear command line
            set eval(cmdbuf,$sock) {}
            # if there磗 a pending command return
            if {$eval(busy)} {
                return
            }
            set eval(busy) 1
        } else  {
            return
        }
        while {[string length $eval(cmdsbuf,$sock)]} {
            
            set eval(evalBuffer,$sock) $eval(cmdsbuf,$sock)
            # clear commands buffer
            set eval(cmdsbuf,$sock) {}
            # if we eval a command, which enters the event loop( i.e. tk_messageBox),
            # it might be possible, that additional commands arrive
            # in the meantime. These will be stored in the cmdsbuf
            # and after evaluation we check if there are new commands
            while {$eval(evalBuffer,$sock) != {} } {
                # we eval only one command with each call
                foreach command $eval(evalBuffer,$sock) {
                    set code [catch {
                        if {[string length $interp] == 0} {
                            uplevel #0 eval $command
                        } else {
                            interp eval $interp $command
                        }
                    } result]
                    if {$code != 0} {
                        set reply [list Code:$code\nResult:$result\nErrorinfo:$errorInfo\nErrorcode:$errorCode\n]
                        eval puts -nonewline $sock $reply
                        tk_messageBox -icon error -title Error -message "$reply\n\n-->Abort Application now<--"
                        exit
                    } else  {
                        # catch {puts $sock $result}
                    }
                }
                catch {
                    set eval(evalBuffer,$sock) {}
                    flush $sock
                    fconfigure $sock -blocking 0
                    update idletasks
                }
            }
            catch {
                flush $sock
                fconfigure $sock -blocking 0
            }
        }
        catch {
            flush $sock
            fconfigure $sock -blocking 0
        }
        set eval(busy) 0
    }
    return
}



if {[string compare [info script] $argv0] == 0} {
    
    switch -- $argc {
        0    {
            set port 9001
            set putsEcho 1
        }
        1    {
            set port [lindex $argv 0]
            set putsEcho 1
        }
        2    {
            set port [lindex $argv 0]
            set putsEcho [lindex $argv 1]
        }
        
        default {
            # port is portnumber as integer
            # putsEcho is boolean, if !=0 normal put commands are echoed back
            puts "usage: evalServer.tcl ?port? ?putsEcho?"
            exit
        }
    }
    
    initServer $port $putsEcho
    update
    catch {wm iconify .}
    wm protocol . WM_DELETE_WINDOW {exit}
}