APN 2015-04-13: Doing more TclOO stuff, I wanted to be able to expand method names interactively in the same manner that proc names are expanded. Turned out the tkcon already had that for nx, xotcl, nsf so I patched in support for TclOO.
The patch also fixes some limitations in the original code. In particular, it also expands method names when the cursor is not at the end of the line, or within a multi command line like first command ; obj methodcall or when the object is accessed via a variable like $obj methodcall.
The patch below is against tkcon.tcl CVS file version 1.122 (that is the *CVS* file version, not the tkcon version). Tested with Tcl 8.5 and 8.6. Will fail on 8.4 (no apply command) but I cannot be bothered with old Tcl versions.
*** tkcon.tcl.orig Sat Mar 21 07:44:37 2015
--- tkcon.tcl Mon Apr 13 09:11:42 2015
*************** proc ::tkcon::Init {args} {
*** 119,125 ****
if {![info exists COLOR($key)]} { set COLOR($key) $default }
}
- # expandorder could also include 'Methodname' for XOTcl/NSF methods
foreach {key default} {
autoload {}
blinktime 500
--- 119,124 ----
*************** proc ::tkcon::Init {args} {
*** 131,137 ****
debugPrompt {(level \#$level) debug [history nextid] > }
dead {}
edit edit
! expandorder {Pathname Variable Procname}
font {}
history 48
hoterrors 1
--- 130,136 ----
debugPrompt {(level \#$level) debug [history nextid] > }
dead {}
edit edit
! expandorder {Methodname Pathname Variable Procname}
font {}
history 48
hoterrors 1
*************** proc ::tkcon::Init {args} {
*** 323,332 ****
-main - -e - -eval { append OPT(maineval) \n$val\n }
-package - -load {
lappend OPT(autoload) $val
- if {$val eq "nsf" || $val eq "nx" || $val eq "XOTcl" } {
- # If xotcl is loaded, prepend expand order for it
- set OPT(expandorder) [concat Methodname $OPT(expandorder)]
- }
}
-slave { append OPT(slaveeval) \n$val\n }
-nontcl { set OPT(nontcl) [regexp -nocase $truth $val]}
--- 322,327 ----
*************** proc ::tkcon::ExpandProcname str {
*** 5836,5851 ****
# possible further matches
##
proc ::tkcon::ExpandMethodname str {
- # In a first step, obtain the typed-in cmd from the console
- set typedCmd [::tkcon::CmdGet $::tkcon::PRIV(console)]
set obj [lindex $typedCmd 0]
if {$obj eq $typedCmd} {
# just a single word, can't be a method expansion
return -code continue
}
# Get the full string after the object
! set sub [string trimleft [string range $typedCmd [string length [list $obj]] end]]
if {[EvalAttached [list info exists ::nsf::version]]} {
# Next Scripting Framework is loaded
if {![EvalAttached [list ::nsf::object::exists $obj]]} {return -code continue}
--- 5831,5861 ----
# possible further matches
##
proc ::tkcon::ExpandMethodname str {
+ # Locate the start of the current command looking back from the insert
+ # cursor to the end of the prompt (mark "limit"). Note the start of the
+ # command may be following a ";", "[", not necessarily the beginning.
+ set start [$::tkcon::PRIV(console) search -backwards -regexp {^|[;\[]\s*} insert-1c limit-1c]
+ if {[string compare {} $start]} {
+ append start +1c
+ } else {
+ set start limit
+ }
+ set typedCmd [string trimleft [$::tkcon::PRIV(console) get $start insert]]
set obj [lindex $typedCmd 0]
if {$obj eq $typedCmd} {
# just a single word, can't be a method expansion
return -code continue
}
# Get the full string after the object
! set sub [string trimleft [string range $typedCmd [string length $obj] end]]
!
! # Deal with cases where the object is actually stored in a variable
! # extract the real object name (ie. $x methodcall).
! if {[string index $obj 0] eq "\$"} {
! set obj [EvalAttached [list set [string range $obj 1 end]]]
! }
!
if {[EvalAttached [list info exists ::nsf::version]]} {
# Next Scripting Framework is loaded
if {![EvalAttached [list ::nsf::object::exists $obj]]} {return -code continue}
*************** proc ::tkcon::ExpandMethodname str {
*** 5860,5870 ****
# XOTcl < 2.* is loaded
if {![EvalAttached [list ::xotcl::Object isobject $obj]]} {return -code continue}
set cmd [list $obj info methods $sub*]
} else {
# No NSF/XOTcl loaded
return -code continue
}
-
set match [EvalAttached $cmd]
if {[llength $match] > 1} {
regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } bestMatch
--- 5870,5893 ----
# XOTcl < 2.* is loaded
if {![EvalAttached [list ::xotcl::Object isobject $obj]]} {return -code continue}
set cmd [list $obj info methods $sub*]
+ } elseif {[llength [EvalAttached [list ::info commands oo::define]]]} {
+ if {![EvalAttached "::info object isa object $obj"]} {
+ return -code continue
+ }
+ set cmd [list apply {
+ {obj sub} {
+ set matches {}
+ foreach meth [::info object methods $obj -all] {
+ if {[string match $sub* $meth]} {
+ lappend matches $meth
+ }
+ }
+ return $matches
+ }} $obj $sub]
} else {
# No NSF/XOTcl loaded
return -code continue
}
set match [EvalAttached $cmd]
if {[llength $match] > 1} {
regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } bestMatch