Revision: 35274
http://brlcad.svn.sourceforge.net/brlcad/?rev=35274&view=rev
Author: bob1961
Date: 2009-07-23 21:57:33 +0000 (Thu, 23 Jul 2009)
Log Message:
-----------
Added tab completion to the Command widget.
Modified Paths:
--------------
brlcad/trunk/src/tclscripts/lib/Command.tcl
Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl
===================================================================
--- brlcad/trunk/src/tclscripts/lib/Command.tcl 2009-07-23 21:54:53 UTC (rev
35273)
+++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2009-07-23 21:57:33 UTC (rev
35274)
@@ -83,6 +83,9 @@
private method select_word {x y}
private method select_line {x y}
private method selection_modify {x y}
+ private method get_longest_common_string {matches}
+ private method tab_completion {}
+ private method tab_expansion {line}
private method print {str}
public method print_more_args_prompt {_prompt}
private method print_prompt {}
@@ -1105,6 +1108,224 @@
selection_add $x $y
}
+# find the longest common initial string from a list of strings
+::itcl::body Command::get_longest_common_string {matches} {
+ set done 0
+ set lastMatchIndex 0
+ set lastMatchChar [string index [lindex $matches 0] $lastMatchIndex]
+ if { $lastMatchChar == "" } return ""
+ while { $done == 0 } {
+ foreach m $matches {
+ if { [string index $m $lastMatchIndex] != $lastMatchChar } {
+ set done 1
+ incr lastMatchIndex -1
+ break
+ }
+ }
+ if { $done == 0 } {
+ incr lastMatchIndex
+ set lastMatchChar [string index [lindex $matches 0] $lastMatchIndex]
+ }
+ }
+ if { $lastMatchIndex > -1 } {
+ set name [string range [lindex $matches 0] 0 $lastMatchIndex]
+ } else {
+ set name ""
+ }
+
+ return $name
+}
+
+::itcl::body Command::tab_completion {} {
+ set w $itk_component(text)
+
+ set line [$w get -- promptEnd {promptEnd lineend -1c}]
+ set results [tab_expansion $line]
+
+ set expansions [lindex $results 1]
+ if { [llength $expansions] > 1 } {
+ # show the possible matches
+ $w delete {insert linestart} {end-2c}
+ $w insert insert "\n${expansions}\n"
+ print_prompt
+ }
+
+ # display the expanded line
+ $w delete promptEnd {end - 2c}
+ $w mark set insert promptEnd
+ $w insert insert [lindex $results 0]
+ $w see insert
+}
+
+::itcl::body Command::tab_expansion {line} {
+ set matches {}
+
+ set len [llength $line]
+
+ if { $len > 1 } {
+ # already have complete command, so do object expansion
+
+ # check if we have an open db
+ if {$itk_option(-cmd_prefix) == ""} {
+ # no db command means no db is open, cannot expand
+ return [list $line {}]
+ }
+
+ # get last word on command line
+ set word [lindex $line [expr $len - 1]]
+
+ # verify that word contains a legit path
+ # convert the path to a list of path elements
+ set path [string map {"/" " "} $word]
+ set pathLength [llength $path]
+
+ # look for the last "/" in the object
+ set index2 [string last "/" $word]
+
+ set slashIsLast 0
+ if { $index2 == [expr [string length $word]] - 1 } {
+ set slashIsLast 1
+ }
+
+ # only check if we have more than one path element
+ if { $pathLength > 1 || $slashIsLast == 1 } {
+ if { $slashIsLast != 1 } {
+ # do not verify the last element (that is what we expand)
+ incr pathLength -1
+ }
+ for { set index 0 } { $index < $pathLength } { incr index } {
+ set element [lindex $path $index]
+ # "$itk_option(-cmd_prefix) get_type" does not blather on error
+ if [catch {eval $itk_option(-cmd_prefix) get_type $element}
type] {
+ # the current path element is invalid, just return
+ return [list $line {}]
+ }
+ }
+ }
+
+ # we have a valid path, do expansion
+ if { $index2 > 0 } {
+ incr index2 -1
+ set index1 [string last "/" $word $index2]
+ if { $index1 == -1 } {
+ set index1 0
+ } else {
+ incr index1
+ }
+
+ # grp contains the object name that appears prior to the last "/"
+ set grp [string range $word $index1 $index2]
+
+ # use anything after the last "/" to create a search pattern
+ if { $index2 < [expr [string length $word] - 2] } {
+ set pattern "* [string range $word [expr $index2 + 2] end]*"
+ } else {
+ set pattern "*"
+ }
+
+ # get the members of the last object on the command line
+ # the "lt" command returns a list of elements like "{ op name }"
+ if [catch {lt $grp} members] {
+ set members {}
+ }
+
+ # use the search pattern to find matches in the list of members
+ set match [lsearch -all -inline $members $pattern]
+
+ set matchCount [llength $match]
+ if { $matchCount > 1 } {
+ # eliminate duplicates
+ set match [lsort -index 1 -unique $match]
+ set matchCount [llength $match]
+ }
+
+ if { $matchCount == 0 } {
+ # no matches just return
+ set newCommand $line
+ } elseif { $matchCount == 1 } {
+ # one match, do the substitution
+ set name [lindex [lindex $match 0] 1]
+ set index [string last "/" $line]
+ set newCommand [string replace $line $index end "/$name"]
+ } else {
+ # multiple matches, find the longest common match
+ # extract the member names from the matches list
+ set matches {}
+ foreach m $match {
+ lappend matches [lindex $m 1]
+ }
+
+ # get the longest common string from the list of member names
+ set name [get_longest_common_string $matches]
+ if { $name != "" } {
+ # found something useful, add it to the command line
+ set index [string last "/" $line]
+ set newCommand [string replace $line $index end "/$name"]
+ } else {
+ set newCommand $line
+ }
+ }
+ } else {
+ set prependSlash 0
+ if { $index2 == 0 } {
+ # first char in word is "/" (only "/" in the word)
+ set grp [string range $word 1 end]
+ set prependSlash 1
+ } else {
+ # no "/" in the object, just expand it with a "*"
+ set grp $word
+ }
+ set matches [eval $itk_option(-cmd_prefix) expand ${grp}*]
+ set len [llength $matches]
+ if { $len == 1 } {
+ if [string equal "${grp}*" $matches] {
+ # expand will return the pattern if nothing matches
+ set newCommand $line
+ } else {
+ # we have a unique expansion, so add it to the command line
+ if { $prependSlash } {
+ set matches "/$matches"
+ }
+ set newCommand [lreplace $line end end $matches]
+ }
+ } elseif { $len > 1 } {
+ # multiple possible matches, find the longest common string
+ set name [get_longest_common_string $matches]
+
+ # add longest common string to the command line
+ if { $prependSlash } {
+ set name "/$name"
+ }
+ set newCommand [lreplace $line end end $name]
+ } else {
+ return [list $line {}]
+ }
+ }
+ } else {
+ # command expansion
+ set cmd [lindex $line 0]
+ if { [string length $cmd] < 1 } {
+ # just a Tab on an empty line, don't show all commands, we have "?"
for that
+ set newCommand $line
+ } else {
+ set matches [lsearch -all -inline $cmdlist "${cmd}*"]
+ set numMatches [llength $matches]
+ if { $numMatches == 0 } {
+ # no matches
+ set newCommand $line
+ } elseif { $numMatches > 1 } {
+ # get longest match
+ set newCommand [get_longest_common_string $matches]
+ } else {
+ # just one match
+ set newCommand $matches
+ }
+ }
+ }
+
+ return [list $newCommand $matches]
+}
+
::itcl::body Command::print {str} {
set w $itk_component(text)
$w insert insert $str
@@ -1208,6 +1429,7 @@
bind $w <End> "[::itcl::code $this end_of_line]; break"
bind $w <Meta-d> "[::itcl::code $this doMeta_d]; break"
bind $w <Meta-BackSpace> "[::itcl::code $this doMeta_BackSpace]; break"
+ bind $w <Tab> "[::itcl::code $this tab_completion]; break"
bind $w <Alt-Key> {
::tk::TraverseToMenu %W %A
This was sent by the SourceForge.net collaborative development platform, the
world's largest Open Source development site.
------------------------------------------------------------------------------
_______________________________________________
BRL-CAD Source Commits mailing list
brlcad-commits@lists.sourceforge.net
https://lists.sourceforge.net/lists/listinfo/brlcad-commits
