Improved metadirective handling

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

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

class tlc::Console {
        inherit tlc::Baselog

        constructor {args} {}
        destructor {}

        public {
                variable enable                 0
                variable prompt_cb              ""
                variable root_context   "::"
                variable appname                ""
                variable printres               1

                method register_custom_command {cmd handler}
                method deregister_custom_command {cmd}
        }

        private {
                variable dominos
                variable context        ""
                variable obj_priv       ""
                variable partial        ""
                variable history
                variable initialized    0
                variable custom_commands

                method check_enable {}
                method get_cmds {}
                method prompt1 {}
                method run_cmd {cmd}
                method build_ns_context {}
                method custom_completer {to_complete w_start w_end line}
                method _eval {cmd}
                method c {args}
                method cx_handler {cmd}
                method ls_handler {cmd}
        }
}


configbody tlc::Console::enable { #<<<1
        log debug
        $dominos(check_enable) tip
}


configbody tlc::Console::prompt_cb { #<<<1
        log debug "prompt_cb: ($prompt_cb)"
        if {$prompt_cb == ""} {
                set prompt_cb   [code $this prompt1]
                log debug "overrode blank prompt_cb to default: ([code $this prompt1])"
        }
}


body tlc::Console::constructor {args} { #<<<1
        array set custom_commands       {}

        log debug

        array set dominos       {}

        tlc::Domino #auto dominos(check_enable) -name "$this check_enable"
        $dominos(check_enable) attach_output [code $this check_enable]

        eval configure $args

        if {$prompt_cb == ""} {
                set prompt_cb   [code $this prompt1]
        }

        register_custom_command "cx" [code $this cx_handler]
        register_custom_command "ls" [code $this ls_handler]
}


body tlc::Console::destructor {} { #<<<1
        log debug
}


body tlc::Console::check_enable {} { #<<<1
        log debug
        if {$enable} {
                if {!($initialized)} {
                        package require tclreadline

                        if {$appname != ""} {
                                set basedir             [file join $::env(HOME) .tlc console_history]
                                set history             [file join $basedir $appname]
                                if {![file isdirectory $basedir]} {
                                        file mkdir $basedir
                                }
                                if {[file exists $history]} {
                                        tclreadline::readline initialize $history
                                }
                        }

                        tclreadline::readline customcompleter [code $this custom_completer]

                        set initialized 1
                }
                get_cmds
        }
}


body tlc::Console::get_cmds {} { #<<<1
        log debug
        while {$enable} {
                set prompt      [uplevel #0 $prompt_cb]
                log debug "prompt: ($prompt)"
                set cmd $partial
                if {$cmd != ""} {
                        append cmd      "\n"
                }
                set new [tclreadline::readline read $prompt]
                if {[regsub {^after#[0-9]+(.*)$} $new {\1} kludge]} {
                        log warning "Detected bizarre tclreadline bug: removing junk from start of ($new)"
                        set new $kludge
                }
                append cmd      $new
                log debug "partial: ($partial) new: ($new) cmd: ($cmd)"
                if {[tclreadline::readline complete $cmd]} {
                        set partial     ""
                        run_cmd $cmd
                } else {
                        set partial     $cmd
                }
        }
}


body tlc::Console::prompt1 {} { #<<<1
        log debug
        if {$partial != ""} {
                return "> "
        }
        if {[info exists appname]} {
                set app         $appname
        } else {
                set app         "#undef"
        }
        if {$obj_priv != ""} {
                if {![itcl::is object $obj_priv]} {
                        return "$app (#invalid# $obj_priv) "
                }
                set class       [$obj_priv info class]
                return "$app ($class $obj_priv) "
        } else {
                return "$app [build_ns_context] "
        }
}


body tlc::Console::run_cmd {cmd} { #<<<1
        log debug
        set first       [lindex $cmd 0]

        if {[info exists custom_commands($first)]} {
                uplevel #0 $custom_commands($first) [list $cmd]
        } else {
                try {
                        set res [_eval $cmd]
                } onok {
                        if {$printres} {
                                puts $res
                        }
                } onerr {
                        default {
                                log error "\n$::errorInfo"
                                set partial     ""
                        }
                }
        }

        if {[info exists history]} {
                tclreadline::readline write $history
        }
}


body tlc::Console::build_ns_context {} { #<<<1
        if {$root_context == "::"} {
                set a   ""
        } else {
                set a   $root_context
        }
        set b   [string trimleft $context :]
        return [join [list $a $b] ::]
}


body tlc::Console::custom_completer {to_complete w_start w_end line} { #<<<1
        log debug
        set custom_cmds {
                cx
                ls
        }

        set matches     {}
        if {$w_start == 0} {
                foreach cc $custom_cmds {
                        if {[string match "$to_complete*" cc]} {
                                lappend matches $cc
                        }
                }
        } else {
                foreach cc $custom_cmds {
                        if {[string match "$cc *" $line]} {
                                set objs        {}
                                foreach obj [_eval [list find objects "${to_complete}*"]] {
                                        lappend objs    $obj
                                }
                                set matches     [concat $matches $objs]
                                # TODO: assemble ns and obj matches
                        }
                }
        }
        log debug "\npossible matches:\n\t[join $matches \n\t]"

        if {[llength $matches] > 0} {
                foreach match $matches {
                        if {![info exists longest]} {
                                set longest     $match
                                log debug "initialized longest to ($longest)"
                        } else {
                                while {![string match "${longest}*" $match]} {
                                        set longest     [string range $longest 0 end-1]
                                }
                                log debug "trimmed longest to ($longest) to match ($matches)"
                        }
                }
                log debug "longest: ($longest)"
                return [concat [list $longest] $matches]
        } else {
                return [list $to_complete]
        }
}


body tlc::Console::_eval {cmd} { #<<<1
        if {$obj_priv != ""} {
                if {![itcl::is object $obj_priv]} {
                        error "Current context is not an object: ($obj_priv)"
                }
                set class               [$obj_priv info class]
                set testmeth    [lindex $cmd 0]
                set use_method  0
                switch -- $testmeth {
                        "scope" -
                        "info" -
                        "code" {
                                set use_method  1
                        }

                        default {
                                if {[string range $cmd 0 1] == "::"} {
                                        foreach method [namespace inscope $class [list $obj_priv info function]] {
                                                if {$testmeth == $method} {
                                                        set use_method  1
                                                        break
                                                }
                                        }
                                } else {
                                        foreach method [namespace inscope $class [list $obj_priv info function]] {
                                                if {$testmeth == [namespace tail $method]} {
                                                        set use_method  1
                                                        break
                                                }
                                        }
                                }
                        }
                }
                if {$use_method} {
                        return [namespace inscope $class [concat $obj_priv $cmd]]
                } else {
                        return [namespace inscope $class $cmd]
                }
        } else {
                set fqcontext   [build_ns_context]
                return [namespace inscope $fqcontext $cmd]
        }
}


body tlc::Console::c {args} { #<<<1
        set build       ""
        foreach name $args {
                switch -- [string tolower $name] {
                        "black"         {append build "\e\[30m"}
                        "red"           {append build "\e\[31m"}
                        "green"         {append build "\e\[32m"}
                        "yellow"        {append build "\e\[33m"}
                        "blue"          {append build "\e\[34m"}
                        "purple"        {append build "\e\[35m"}
                        "cyan"          {append build "\e\[36m"}
                        "white"         {append build "\e\[37m"}
                        "bg_black"      {append build "\e\[40m"}
                        "bg_red"        {append build "\e\[41m"}
                        "bg_green"      {append build "\e\[42m"}
                        "bg_yellow"     {append build "\e\[43m"}
                        "bg_blue"       {append build "\e\[44m"}
                        "bg_purple"     {append build "\e\[45m"}
                        "bg_cyan"       {append build "\e\[46m"}
                        "bg_white"      {append build "\e\[47m"}
                        "inverse"       {append build "\e\[7m"}
                        "bold"          {append build "\e\[5m"}
                        "underline"     {append build "\e\[4m"}
                        "bright"        {append build "\e\[1m"}
                        "norm"          {append build "\e\[0m"}
                        default         {append build ""}
                }
        }

        return $build
}


body tlc::Console::cx_handler {cmd} { #<<<1
        if {[llength $cmd] != 2} {
                log error "wrong # of args: cx <new_ns_context>"
        }
        set new [lindex $cmd 1]
        if {[itcl::is object $new]} {
                set obj_priv    [_eval [list namespace origin $new]]
                log debug "context is now the private scope of $obj_priv"
        } else {
                set obj_priv    ""
                set context             [string trimright $new :]
                log debug "context is now the namespace $context"
        }
}


body tlc::Console::ls_handler {cmd} { #<<<1
        if {$obj_priv != ""} {
                set showall     [expr {[lindex $cmd 1] == "-a"}]

                set class               [$obj_priv info class]
                set public_v    {}
                set protected_v {}
                set private_v   {}
                set public_m    {}
                set protected_m {}
                set private_m   {}

                foreach var [_eval {info variable}] {
                        if {[string match "${class}::*" $var]} {
                                set var [namespace tail $var]
                        } elseif {!($showall)} {
                                continue
                        }
                        if {$var == "this"} continue
                        set full [$obj_priv info variable $var]
                        if {[llength $full] == 5} {
                                foreach {prlev type fqname default current} $full break
                        } else {
                                foreach {prlev type fqname default handler current} $full break
                        }

                        if {$current == "<undefined>"} {
                                set current     ""
                        } else {
                                set current     "[c red]\"$current\"[c norm]"
                        }

                        set scopename   [list @itcl $obj_priv $fqname]
                        if {[string range $var 0 1] == "::"} {
                                if {[_eval [list array exists $fqname]]} {
                                        set current "\[array set"
                                        foreach {key val} [_eval [list array get $fqname]] {
                                                if {[llength $key] > 1} {
                                                        set key         "\"$key\""
                                                }
                                                if {[llength $val] > 1} {
                                                        set val         "\"$val\""
                                                }
                                                append current "\n\t\t\t[c red]$key[c norm]\t[c red]$val[c norm]"
                                        }
                                        append current "\n\t\t\]"
                                }
                        } else {
                                if {[array exists $scopename]} {
                                        set current "\[array set"
                                        foreach {key val} [array get $scopename] {
                                                if {[llength $key] > 1} {
                                                        set key         "\"$key\""
                                                }
                                                if {[llength $val] > 1} {
                                                        set val         "\"$val\""
                                                }
                                                append current "\n\t\t\t[c red]$key[c norm]\t[c red]$val[c norm]"
                                        }
                                        append current "\n\t\t\]"
                                }
                        }

                        lappend ${prlev}_v      $type $var $current
                }

                foreach method [_eval {info function}] {
                        if {[string match "${class}::*" $method]} {
                                set method      [namespace tail $method]
                        } elseif {!($showall)} {
                                continue
                        }
                        set full [$obj_priv info function $method]
                        foreach {prlev type fqname arglist body} $full break
                        if {$method == "constructor"} {
                                set constructor_args    $arglist
                                continue
                        }
                        if {$method == "destructor"} {
                                set destructor_exists   1
                                continue
                        }
                        lappend ${prlev}_m $type $method $arglist
                }

                puts "[c green]class[c norm] $class {"
                puts "\t[c green]inherits[c norm] [$obj_priv info heritage]"
                puts ""
                set flag        0
                if {[info exists constructor_args]} {
                        puts "\t[c green]constructor[c norm] {$constructor_args} {}"
                        set flag        1
                }
                if {[info exists destructor_exists]} {
                        puts "\t[c green]destructor[c norm] {}"
                        set flag        1
                }
                if {[info exists flag]} {
                        puts ""
                }
                set flag        0
                foreach prlev {public protected private} {
                        set vars        [set ${prlev}_v]
                        set methods     [set ${prlev}_m]
                        if {[llength $vars] == 0 && [llength $methods] == 0} {
                                continue
                        }
                        if {$flag} {
                                puts ""
                        }
                        set flag        1
                        puts "\t[c blue]$prlev[c norm] {"
                        foreach {type name current} $vars {
                                if {$current == "<undefined>"} {
                                        puts "\t\t[c yellow]$type[c norm] $name"
                                } else {
                                        puts "\t\t[c yellow]$type[c norm] $name\t$current"
                                }
                        }
                        if {[llength $vars] > 0 && [llength $methods] > 0} {
                                puts ""
                        }
                        foreach {type name arglist} $methods {
                                puts "\t\t[c green]$type[c norm] $name {$arglist}"
                        }
                        puts "\t}"
                }
                puts "}"

                # List sub widgets if we are a widget
                if {[catch {
                        set is_widget   [$obj_priv isa itk::Archetype]
                } errmsg]} {
                        set is_widget   0
                }
                if {$is_widget} {
                        foreach child [winfo children [$obj_priv info variable w -value]] {
                                puts "$child"
                        }
                }
                # TODO: list sub namespaces and relative objects
        } else {
        }
}


body tlc::Console::register_custom_command {cmd handler} { #<<<1
        set custom_commands($cmd)       $handler
}


body tlc::Console::deregister_custom_command {cmd} { #<<<1
        array unset custom_commands $cmd
}