Thread: [brlcad-commits] SF.net SVN: brlcad:[33960] brlcad/trunk/src/tclscripts/lib/Command.tcl
Open Source Solid Modeling CAD
Brought to you by:
brlcad
From: <bo...@us...> - 2009-03-06 15:04:36
|
Revision: 33960 http://brlcad.svn.sourceforge.net/brlcad/?rev=33960&view=rev Author: bob1961 Date: 2009-03-06 15:04:13 +0000 (Fri, 06 Mar 2009) Log Message: ----------- This applies the same bug fixes that were applied to MGED (i.e. bug #2555653 - the command line has an extra character at the end that is not used and cannot be removed; bug #2278235 - can't cut-n-paste under Windows) 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-03-06 14:48:06 UTC (rev 33959) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2009-03-06 15:04:13 UTC (rev 33960) @@ -92,6 +92,7 @@ private method doBindings {} private method doButtonBindings {} + private method doCopy {} private method doKeyBindings {} private method doControl_a {} private method doControl_c {} @@ -1146,7 +1147,17 @@ doButtonBindings } +::itcl::body Command::doCopy {} { + set w $itk_component(text) + catch { + clipboard clear -displayof $w; + clipboard append -displayof $w [selection get -displayof $w] + } +} + ::itcl::body Command::doKeyBindings {} { + global tcl_platform + set w $itk_component(text) switch $itk_option(-edit_style) { vi { @@ -1176,7 +1187,11 @@ bind $w <Right> "[::itcl::code $this doRight]; break" bind $w <Control-a> "[::itcl::code $this doControl_a]; break" bind $w <Control-b> "[::itcl::code $this backward_char]; break" - bind $w <Control-c> "[::itcl::code $this doControl_c]; break" + if {$tcl_platform(platform) == "windows"} { + bind $w <Control-c> "[::itcl::code $this doCopy]; break" + } else { + bind $w <Control-c> "[::itcl::code $this doControl_c]; break" + } bind $w <Control-e> "[::itcl::code $this end_of_line]; break" bind $w <Control-f> "[::itcl::code $this forward_char]; break" bind $w <Control-k> "[::itcl::code $this delete_end_of_line]; break" @@ -1288,6 +1303,27 @@ } } +bind Text <Control-Key-slash> {} + +proc tk_textPaste {w} { + global tcl_platform + if {![catch {::tk::GetSelection $w CLIPBOARD} sel]} { + set oldSeparator [$w cget -autoseparators] + if {$oldSeparator} { + $w configure -autoseparators 0 + $w edit separator + } + #if {[tk windowingsystem] ne "x11"} { + # catch { $w delete sel.first sel.last } + #} + $w insert insert $sel + if {$oldSeparator} { + $w edit separator + $w configure -autoseparators 1 + } + } +} + # Local Variables: # mode: Tcl # tab-width: 8 This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <br...@us...> - 2009-06-03 03:04:36
|
Revision: 34641 http://brlcad.svn.sourceforge.net/brlcad/?rev=34641&view=rev Author: brlcad Date: 2009-06-03 03:04:35 +0000 (Wed, 03 Jun 2009) Log Message: ----------- protect the gets rename the same way mged/text.tcl does it by making sure the proc has a body/exists first. the s2 folks reported that they're getting an error about gets not existing which would be consistent with the Command.tcl constructor getting read multiple times. 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-06-02 23:12:49 UTC (rev 34640) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2009-06-03 03:04:35 UTC (rev 34641) @@ -210,7 +210,9 @@ $itk_component(text) tag configure oldcmd -foreground $itk_option(-oldcmd_color) $itk_component(text) tag configure result -foreground $itk_option(-result_color) - rename ::gets ::tcl_gets + if {[catch {info body ::gets}] == 1} { + rename ::gets ::tcl_gets + } } ::itcl::body Command::destructor {} { This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bo...@us...> - 2009-07-23 21:57:41
|
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. |
From: <br...@us...> - 2011-01-13 03:01:33
|
Revision: 42202 http://brlcad.svn.sourceforge.net/brlcad/?rev=42202&view=rev Author: brlcad Date: 2011-01-13 03:01:27 +0000 (Thu, 13 Jan 2011) Log Message: ----------- gracefully handle a failure to create a slave interpreter Modified Paths: -------------- brlcad/trunk/src/tclscripts/lib/Command.tcl Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl =================================================================== --- brlcad/trunk/src/tclscripts/lib/Command.tcl 2011-01-13 02:42:26 UTC (rev 42201) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2011-01-13 03:01:27 UTC (rev 42202) @@ -192,7 +192,10 @@ ::itcl::body Command::constructor {args} { eval itk_initialize $args - set slaveInterp [interp create] + # thar be dragons here + if { [catch {set slaveInterp [interp create]} error] } { + error "Unable to initalize a slave interpreter" + } doBindings This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <br...@us...> - 2011-01-13 03:12:56
|
Revision: 42203 http://brlcad.svn.sourceforge.net/brlcad/?rev=42203&view=rev Author: brlcad Date: 2011-01-13 03:12:49 +0000 (Thu, 13 Jan 2011) Log Message: ----------- catch the other place we create an interpreter too Modified Paths: -------------- brlcad/trunk/src/tclscripts/lib/Command.tcl Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl =================================================================== --- brlcad/trunk/src/tclscripts/lib/Command.tcl 2011-01-13 03:01:27 UTC (rev 42202) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2011-01-13 03:12:49 UTC (rev 42203) @@ -155,7 +155,9 @@ # Create new slave interp interp delete $slaveInterp - set slaveInterp [interp create] + if { [catch {set slaveInterp [interp create]} err] } { + error "Unable to reinitalize a slave interpreter" + } # Create slave interp's aliases foreach cmd $cmdlist { @@ -193,7 +195,7 @@ eval itk_initialize $args # thar be dragons here - if { [catch {set slaveInterp [interp create]} error] } { + if { [catch {set slaveInterp [interp create]} err] } { error "Unable to initalize a slave interpreter" } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <br...@us...> - 2012-01-24 06:06:09
|
Revision: 49014 http://brlcad.svn.sourceforge.net/brlcad/?rev=49014&view=rev Author: brlcad Date: 2012-01-24 06:06:02 +0000 (Tue, 24 Jan 2012) Log Message: ----------- do the same for archer. looks like entirely duplicate code fortunately/unfortunately so same fix applies to make an empty tab-expansion return all registered commands. Modified Paths: -------------- brlcad/trunk/src/tclscripts/lib/Command.tcl Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl =================================================================== --- brlcad/trunk/src/tclscripts/lib/Command.tcl 2012-01-24 06:02:13 UTC (rev 49013) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2012-01-24 06:06:02 UTC (rev 49014) @@ -1318,22 +1318,19 @@ } 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 + + # even if line is empty, return all registered commands. + 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 { - 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 - } + # just one match + set newCommand $matches } } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <br...@us...> - 2012-01-24 06:12:14
|
Revision: 49015 http://brlcad.svn.sourceforge.net/brlcad/?rev=49015&view=rev Author: brlcad Date: 2012-01-24 06:12:07 +0000 (Tue, 24 Jan 2012) Log Message: ----------- apply similar usability enhancement to archer as was done for mged. if there's only one match remaining, then add a space after our match so the user is saved a keystroke. Modified Paths: -------------- brlcad/trunk/src/tclscripts/lib/Command.tcl Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl =================================================================== --- brlcad/trunk/src/tclscripts/lib/Command.tcl 2012-01-24 06:06:02 UTC (rev 49014) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2012-01-24 06:12:07 UTC (rev 49015) @@ -1157,7 +1157,9 @@ set results [tab_expansion $line] set expansions [lindex $results 1] - if { [llength $expansions] > 1 } { + set numExpansions [llength $expansions] + + if { $numExpansions > 1 } { # show the possible matches $w delete {insert linestart} {end-2c} $w insert insert "\n${expansions}\n" @@ -1168,6 +1170,10 @@ $w delete promptEnd {end - 2c} $w mark set insert promptEnd $w insert insert [lindex $results 0] + if { $numExpansions == 1 } { + # only one match remaining, pad space so we can keep going + $w insert insert " " + } $w see insert } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <car...@us...> - 2012-10-02 20:38:08
|
Revision: 52698 http://brlcad.svn.sourceforge.net/brlcad/?rev=52698&view=rev Author: carlmoore Date: 2012-10-02 20:38:02 +0000 (Tue, 02 Oct 2012) Log Message: ----------- fix spellings Modified Paths: -------------- brlcad/trunk/src/tclscripts/lib/Command.tcl Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl =================================================================== --- brlcad/trunk/src/tclscripts/lib/Command.tcl 2012-10-02 19:58:20 UTC (rev 52697) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2012-10-02 20:38:02 UTC (rev 52698) @@ -156,7 +156,7 @@ # Create new slave interp interp delete $slaveInterp if { [catch {set slaveInterp [interp create]} err] } { - error "Unable to reinitalize a slave interpreter" + error "Unable to reinitialize a slave interpreter" } # Create slave interp's aliases @@ -196,7 +196,7 @@ # thar be dragons here if { [catch {set slaveInterp [interp create]} err] } { - error "Unable to initalize a slave interpreter" + error "Unable to initialize a slave interpreter" } doBindings This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <car...@us...> - 2012-11-19 19:28:01
|
Revision: 53754 http://brlcad.svn.sourceforge.net/brlcad/?rev=53754&view=rev Author: carlmoore Date: 2012-11-19 19:27:54 +0000 (Mon, 19 Nov 2012) Log Message: ----------- fix spelling as just explained in an email Modified Paths: -------------- brlcad/trunk/src/tclscripts/lib/Command.tcl Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl =================================================================== --- brlcad/trunk/src/tclscripts/lib/Command.tcl 2012-11-19 19:16:51 UTC (rev 53753) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2012-11-19 19:27:54 UTC (rev 53754) @@ -410,7 +410,7 @@ $itk_component(text) delete 1.0 [expr $nlines - $itk_option(-maxlines)].end } } else { - print_promt2 + print_prompt2 } $itk_component(text) see insert } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bo...@us...> - 2013-03-27 18:33:37
|
Revision: 54920 http://brlcad.svn.sourceforge.net/brlcad/?rev=54920&view=rev Author: bob1961 Date: 2013-03-27 18:33:30 +0000 (Wed, 27 Mar 2013) Log Message: ----------- This fixes the Command::invoke method's mishandling of double quotes in nested commands. Modified Paths: -------------- brlcad/trunk/src/tclscripts/lib/Command.tcl Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl =================================================================== --- brlcad/trunk/src/tclscripts/lib/Command.tcl 2013-03-27 18:23:52 UTC (rev 54919) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2013-03-27 18:33:30 UTC (rev 54920) @@ -329,13 +329,19 @@ ::itcl::body Command::invoke {} { set w $itk_component(text) - set cmd [$w get promptEnd insert] + set cmd [string trimleft [$w get promptEnd insert]] set more_args_list {} # remove any instances of prompt2 from the beginning of each secondary line regsub -all "\n$itk_option(-prompt2)" $cmd "" cmd - set cname [lindex $cmd 0] + set i [string first " " $cmd] + if {$i == -1} { + set cname $cmd + } else { + set cname [string range $cmd 0 $i-1] + } + if {$cname == "master"} { invokeMaster $cmd @@ -357,7 +363,6 @@ } if {$do_history} { - eval lappend cmd $more_args_list $hist add $cmd } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <bo...@us...> - 2013-03-29 16:39:48
|
Revision: 54972 http://brlcad.svn.sourceforge.net/brlcad/?rev=54972&view=rev Author: bob1961 Date: 2013-03-29 16:39:40 +0000 (Fri, 29 Mar 2013) Log Message: ----------- A few minor tweaks to the Command widget. Updated Command::print_more_args_prompt to make the insertion point visible. Updated Command::invoke to print the prompt string whether we have a more-args interruption or not. Modified Paths: -------------- brlcad/trunk/src/tclscripts/lib/Command.tcl Modified: brlcad/trunk/src/tclscripts/lib/Command.tcl =================================================================== --- brlcad/trunk/src/tclscripts/lib/Command.tcl 2013-03-29 16:23:22 UTC (rev 54971) +++ brlcad/trunk/src/tclscripts/lib/Command.tcl 2013-03-29 16:39:40 UTC (rev 54972) @@ -382,10 +382,10 @@ if {$more_args_interrupted} { set more_args_interrupted 0 - } else { - print_prompt } + print_prompt + # get rid of oldest output set nlines [expr int([$w index end])] if {$nlines > $itk_option(-maxlines)} { @@ -1369,6 +1369,7 @@ ::itcl::body Command::print_more_args_prompt {args} { eval $itk_component(text) insert insert $args + $itk_component(text) see insert } ::itcl::body Command::print_prompt {} { This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |