1 # vim: ft=tcl foldmethod=marker foldmarker=<<<,>>> shiftwidth=4 ts=4
12 variable root_context
"::"
16 method register_custom_command
{cmd handler
}
17 method deregister_custom_command
{cmd
}
26 variable initialized
0
27 variable custom_commands
29 method check_enable
{}
33 method build_ns_context
{}
34 method custom_completer
{to_complete w_start w_end line
}
37 method cx_handler
{cmd
}
38 method ls_handler
{cmd
}
43 configbody tlc
::Console::enable { #<<<1
45 $dominos(check_enable
) tip
49 configbody tlc
::Console::prompt_cb { #<<<1
50 log debug
"prompt_cb: ($prompt_cb)"
51 if {$prompt_cb == ""} {
52 set prompt_cb
[code
$this prompt1
]
53 log debug
"overrode blank prompt_cb to default: ([code $this prompt1])"
58 body tlc
::Console::constructor {args
} { #<<<1
59 array set custom_commands
{}
65 tlc
::Domino #auto dominos(check_enable) -name "$this check_enable"
66 $dominos(check_enable
) attach_output
[code
$this check_enable
]
70 if {$prompt_cb == ""} {
71 set prompt_cb
[code
$this prompt1
]
74 register_custom_command
"cx" [code
$this cx_handler
]
75 register_custom_command
"ls" [code
$this ls_handler
]
79 body tlc
::Console::destructor {} { #<<<1
84 body tlc
::Console::check_enable {} { #<<<1
87 if {!($initialized)} {
88 package require tclreadline
91 set basedir
[file join $::env(HOME
) .tlc console_history
]
92 set history [file join $basedir $appname]
93 if {![file isdirectory
$basedir]} {
96 if {[file exists
$history]} {
97 tclreadline
::readline initialize
$history
101 tclreadline
::readline customcompleter
[code
$this custom_completer
]
110 body tlc
::Console::get_cmds {} { #<<<1
113 set prompt
[uplevel #0 $prompt_cb]
114 log debug
"prompt: ($prompt)"
119 set new
[tclreadline
::readline read $prompt]
120 if {[regsub {^
after#[0-9]+(.*)$} $new {\1} kludge]} {
121 log warning
"Detected bizarre tclreadline bug: removing junk from start of ($new)"
125 log debug
"partial: ($partial) new: ($new) cmd: ($cmd)"
126 if {[tclreadline
::readline complete
$cmd]} {
136 body tlc
::Console::prompt1 {} { #<<<1
138 if {$partial != ""} {
141 if {[info exists appname
]} {
146 if {$obj_priv != ""} {
147 if {![itcl
::is object
$obj_priv]} {
148 return "$app (#invalid# $obj_priv) "
150 set class
[$obj_priv info class
]
151 return "$app ($class $obj_priv) "
153 return "$app [build_ns_context] "
158 body tlc
::Console::run_cmd {cmd
} { #<<<1
160 set first
[lindex $cmd 0]
162 if {[info exists custom_commands
($first)]} {
163 uplevel #0 $custom_commands($first) [list $cmd]
173 log
error "\n$::errorInfo"
179 if {[info exists
history]} {
180 tclreadline
::readline write
$history
185 body tlc
::Console::build_ns_context {} { #<<<1
186 if {$root_context == "::"} {
191 set b
[string trimleft
$context :]
192 return [join [list $a $b] ::]
196 body tlc
::Console::custom_completer {to_complete w_start w_end line
} { #<<<1
205 foreach cc
$custom_cmds {
206 if {[string match
"$to_complete*" cc
]} {
211 foreach cc
$custom_cmds {
212 if {[string match
"$cc *" $line]} {
214 foreach obj
[_eval
[list find objects
"${to_complete}*"]] {
217 set matches
[concat $matches $objs]
218 # TODO: assemble ns and obj matches
222 log debug
"\npossible matches:\n\t[join $matches \n\t]"
224 if {[llength $matches] > 0} {
225 foreach match
$matches {
226 if {![info exists longest
]} {
228 log debug
"initialized longest to ($longest)"
230 while {![string match
"${longest}*" $match]} {
231 set longest
[string range
$longest 0 end-1
]
233 log debug
"trimmed longest to ($longest) to match ($matches)"
236 log debug
"longest: ($longest)"
237 return [concat [list $longest] $matches]
239 return [list $to_complete]
244 body tlc
::Console::_eval {cmd
} { #<<<1
245 if {$obj_priv != ""} {
246 if {![itcl
::is object
$obj_priv]} {
247 error "Current context is not an object: ($obj_priv)"
249 set class
[$obj_priv info class
]
250 set testmeth
[lindex $cmd 0]
252 switch -- $testmeth {
260 if {[string range
$cmd 0 1] == "::"} {
261 foreach method
[namespace inscope
$class [list $obj_priv info function
]] {
262 if {$testmeth == $method} {
268 foreach method
[namespace inscope
$class [list $obj_priv info function
]] {
269 if {$testmeth == [namespace tail
$method]} {
278 return [namespace inscope
$class [concat $obj_priv $cmd]]
280 return [namespace inscope
$class $cmd]
283 set fqcontext
[build_ns_context
]
284 return [namespace inscope
$fqcontext $cmd]
289 body tlc
::Console::c {args
} { #<<<1
292 switch -- [string tolower
$name] {
293 "black" {append build
"\e\[30m"}
294 "red" {append build
"\e\[31m"}
295 "green" {append build
"\e\[32m"}
296 "yellow" {append build
"\e\[33m"}
297 "blue" {append build
"\e\[34m"}
298 "purple" {append build
"\e\[35m"}
299 "cyan" {append build
"\e\[36m"}
300 "white" {append build
"\e\[37m"}
301 "bg_black" {append build
"\e\[40m"}
302 "bg_red" {append build
"\e\[41m"}
303 "bg_green" {append build
"\e\[42m"}
304 "bg_yellow" {append build
"\e\[43m"}
305 "bg_blue" {append build
"\e\[44m"}
306 "bg_purple" {append build
"\e\[45m"}
307 "bg_cyan" {append build
"\e\[46m"}
308 "bg_white" {append build
"\e\[47m"}
309 "inverse" {append build
"\e\[7m"}
310 "bold" {append build
"\e\[5m"}
311 "underline" {append build
"\e\[4m"}
312 "bright" {append build
"\e\[1m"}
313 "norm" {append build
"\e\[0m"}
314 default {append build
""}
322 body tlc
::Console::cx_handler {cmd
} { #<<<1
323 if {[llength $cmd] != 2} {
324 log
error "wrong # of args: cx <new_ns_context>"
326 set new
[lindex $cmd 1]
327 if {[itcl
::is object
$new]} {
328 set obj_priv
[_eval
[list namespace origin
$new]]
329 log debug
"context is now the private scope of $obj_priv"
332 set context
[string trimright
$new :]
333 log debug
"context is now the namespace $context"
338 body tlc
::Console::ls_handler {cmd
} { #<<<1
339 if {$obj_priv != ""} {
340 set showall
[expr {[lindex $cmd 1] == "-a"}]
342 set class
[$obj_priv info class
]
350 foreach var
[_eval
{info variable}] {
351 if {[string match
"${class}::*" $var]} {
352 set var
[namespace tail
$var]
353 } elseif
{!($showall)} {
356 if {$var == "this"} continue
357 set full
[$obj_priv info variable $var]
358 if {[llength $full] == 5} {
359 foreach {prlev type fqname
default current
} $full break
361 foreach {prlev type fqname
default handler current
} $full break
364 if {$current == "<undefined>"} {
367 set current
"[c red]\"$current\"[c norm]"
370 set scopename
[list @itcl
$obj_priv $fqname]
371 if {[string range
$var 0 1] == "::"} {
372 if {[_eval
[list array exists
$fqname]]} {
373 set current
"\[array set"
374 foreach {key val
} [_eval
[list array get
$fqname]] {
375 if {[llength $key] > 1} {
378 if {[llength $val] > 1} {
381 append current
"\n\t\t\t[c red]$key[c norm]\t[c red]$val[c norm]"
383 append current
"\n\t\t\]"
386 if {[array exists
$scopename]} {
387 set current
"\[array set"
388 foreach {key val
} [array get
$scopename] {
389 if {[llength $key] > 1} {
392 if {[llength $val] > 1} {
395 append current
"\n\t\t\t[c red]$key[c norm]\t[c red]$val[c norm]"
397 append current
"\n\t\t\]"
401 lappend ${prlev
}_v
$type $var $current
404 foreach method
[_eval
{info function
}] {
405 if {[string match
"${class}::*" $method]} {
406 set method
[namespace tail
$method]
407 } elseif
{!($showall)} {
410 set full
[$obj_priv info function
$method]
411 foreach {prlev type fqname arglist body
} $full break
412 if {$method == "constructor"} {
413 set constructor_args
$arglist
416 if {$method == "destructor"} {
417 set destructor_exists
1
420 lappend ${prlev
}_m
$type $method $arglist
423 puts "[c green]class[c norm] $class {"
424 puts "\t[c green]inherits[c norm] [$obj_priv info heritage]"
427 if {[info exists constructor_args
]} {
428 puts "\t[c green]constructor[c norm] {$constructor_args} {}"
431 if {[info exists destructor_exists
]} {
432 puts "\t[c green]destructor[c norm] {}"
435 if {[info exists flag
]} {
439 foreach prlev
{public protected private
} {
440 set vars
[set ${prlev
}_v
]
441 set methods
[set ${prlev
}_m
]
442 if {[llength $vars] == 0 && [llength $methods] == 0} {
449 puts "\t[c blue]$prlev[c norm] {"
450 foreach {type name current
} $vars {
451 if {$current == "<undefined>"} {
452 puts "\t\t[c yellow]$type[c norm] $name"
454 puts "\t\t[c yellow]$type[c norm] $name\t$current"
457 if {[llength $vars] > 0 && [llength $methods] > 0} {
460 foreach {type name arglist
} $methods {
461 puts "\t\t[c green]$type[c norm] $name {$arglist}"
467 # List sub widgets if we are a widget
469 set is_widget
[$obj_priv isa itk
::Archetype]
474 foreach child
[winfo children
[$obj_priv info variable w
-value]] {
478 # TODO: list sub namespaces and relative objects
484 body tlc
::Console::register_custom_command {cmd handler
} { #<<<1
485 set custom_commands
($cmd) $handler
489 body tlc
::Console::deregister_custom_command {cmd
} { #<<<1
490 array unset custom_commands
$cmd