Added custom field type support to Form

[tcl-tlc.git] / scripts / probe.itcl

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

class tlc::Probe {
        inherit tlc::Baselog

        constructor {args} {}
        destructor {}

        public {
                variable enable_probe   0
                variable probe_port
        }

        private {
                variable listen
                variable context        ""

                method run_probe_cmd {cmd}
                method process_probe_cmd {cmd}
                method readable {con}
                method accept {con clip clport}
        }
}


body tlc::Probe::constructor {args} { #<<<1
        log debug $this
        eval configure $args

        foreach reqf {probe_port} {
                if {![info exists $reqf]} {
                        error "Must set -$reqf"
                }
        }

        if {$enable_probe} {
                set probe_listen        [socket -server [code $this accept] $probe_port]
                log debug "opened listening socket ($probe_listen) on port ($probe_port)"
        }
}


body tlc::Probe::destructor {} { #<<<1
        log debug $this
        if {[info exists proble_listen]} {
                if {[catch {close $probe_listen} errmsg]} {
                        log error "\nError closing probe_listen: $errmsg\n$::errorInfo"
                }
                unset proble_listen
        }
}


body tlc::Probe::run_probe_cmd {cmd} { #<<<1
        log notice
        if {[catch {
                if {$context == ""} {
                        set res [uplevel #0 $cmd]
                } else {
                        set res [eval [list $context proxy] $cmd]
                }
        } errmsg]} {
                log error "\nError processing command: $errmsg\n$::errorInfo"
                return "Error processing command:\n$::errorInfo"
        } else {
                log debug "result: ($res)"
                return $res
        }
}

body tlc::Probe::process_probe_cmd {cmd} { #<<<1
        log notice
        switch -- [lindex $cmd 0] {
                "context" {
                        #set user       [lindex $cmd 1]
                        #if {$user == ""} {
                        #       set context     ""
                        #       return "ok: global context"
                        #}
                        #foreach obj [find objects -class Session] {
                        #       if {$user == [$obj fqun]} {
                        #               set context     $obj
                        #               return "ok: $obj"
                        #       }
                        #}
                }

                "remote" {
                        return [run_probe_cmd [lrange $cmd 1 end]
                }

                "reload_method" -
                "reload_methods" {
                        set fn          [lindex $cmd 1]
                        set methods     [lrange $cmd 2 end]

                        #if {$context != ""} {
                        #       $context proxy vfs_modules refresh_md5s
                        #}
                        if {[catch {
                                set fp  [open $fn r]
                                set dat [read $fp]
                                close $fp
                                set saving      0
                                set code        ""
                                set level       0
                                foreach line [split $dat \n] {
                                        if {$saving} {
                                                set openbraces  [regsub -all {[^\{]*} $line {}]
                                                set closebraces [regsub -all {[^\}]*} $line {}]
                                                incr level [string length $openbraces]
                                                incr level -[string length $closebraces]
                                                log notice "openbraces: ($openbraces) closebraces: ($closebraces) level: ($level)"
                                                if {$level <= 0} {
                                                        # TODO: handle extra close brace chars etc after
                                                        # end of method
                                                        set saving      0
                                                }
                                                append code $line \n
                                        }
                                        if {!$saving} {
                                                if {[string match "body *" $line]} {
                                                        set fqmethod \
                                                                        [regsub {^body ([^\s]*) .*$} $line {\1}]
                                                        set method      [lindex [split $fqmethod :] end]
                                                        if {[lsearch $methods $method] != -1} {
                                                                set saving      1
                                                                set openbraces  [regsub -all {[^\{]*} $line {}]
                                                                set closebraces [regsub -all {[^\}]*} $line {}]
                                                                incr level [string length $openbraces]
                                                                incr level -[string length $closebraces]
                                                                append code     $line \n
                                                        }
                                                }
                                        }
                                }
                                log notice "reload_methods: fn: ($fn) methods: ($methods) running code:\n$code"
                                if {$::context == ""} {
                                        uplevel #0 $code
                                } else {
                                        eval [list $::context proxy] $code
                                }
                        } errmsg]} {
                                return "Error processing reload_methods: $::errorInfo"
                        } else {
                                return "Reloaded code:\n$code"
                        }
                }

                "private" {
                        set obj         [lindex $cmd 1]

                        if {![itcl::is object $obj]} {
                                return "Error: $obj is not an object"
                        }

                        set class       [$obj info class]
                        return [namespace inscope $class [lrange $cmd 1 end]]
                }

                "privatevar" {
                        set obj         [lindex $cmd 1]
                        set var         [lindex $cmd 2]

                        if {![itcl::is object $obj]} {
                                return "Error: $obj is not an object"
                        }

                        return  [$obj info variable $var -value]
                }

                default {
                        return [run_probe_cmd $cmd]
                }
        }
}


body tlc::Probe::readable {con} { #<<<1
        log debug
        set len         [gets $con]
        if {[eof $con]} {
                close $con
                return
        }
        set data        [read $con $len]
        if {[catch {
                set res         [process_probe_cmd $data]
        }]} {
                set msg         "Error processing command:\n$::errorInfo"
        } else {
                set msg         $res
        }

        puts $con [string length $msg]
        puts -nonewline $con $msg
        flush $con
}


body tlc::Probe::accept {con clip clport} { #<<<1
        log notice
        if {$clip != "127.0.0.1"} {
                log error "rejecting connection from $clip"
                close $con
                return
        }
        fconfigure $con -blocking 1 -translation binary -encoding binary
        fileevent $con readable [code $this readable $con]
}