Main Page | Namespace List | Class Hierarchy | Alphabetical List | Class List | File List | Namespace Members | Class Members | File Members | Related Pages

shell.tcl

00001 # Copyright (C) 1997-2004 The CDG Team <cdg@nats.informatik.uni-hamburg.de> 00002 # 00003 # This file is free software; as a special exception the author gives 00004 # unlimited permission to copy and/or distribute it, with or without 00005 # modifications, as long as this notice is preserved. 00006 # 00007 # This program is distributed in the hope that it will be useful, but 00008 # WITHOUT ANY WARRANTY, to the extent permitted by law; without even the 00009 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00010 00011 ## ---------------------------------------------------------------------------- 00012 ## CdgShell - imitate the CDG shell in tcl. 00013 ## 00014 ## \author Michael Daum (see also AUTHORS and THANKS for more) 00015 ## $Id: shell.tcl,v 1.59 2004/09/06 13:40:54 micha Exp $ 00016 ##----------------------------------------------------------------------------- 00017 class CdgShell { 00018 inherit ::iwidgets::Scrolledtext 00019 00020 ## itk_option: configure the shell background color 00021 itk_option define -background background Background "gray90" 00022 00023 ## itk_option: configure the shell prompt. the actual value will be 00024 ## set to one of -prompt1 or -prompt2 00025 itk_option define -prompt prompt Prompt "cdg> " 00026 00027 ## itk_option: configure the shell first prompt 00028 itk_option define -prompt1 prompt1 Prompt "cdg> " 00029 00030 ## itk_option: configure the shell second prompt 00031 itk_option define -prompt2 prompt2 Prompt "tcltk# " 00032 00033 ## flag to show a tcl error trace or not. 00034 public variable showTrace 0 00035 00036 ## shell command history 00037 private variable history; ## \type TclArray 00038 00039 ## index in the shell command history 00040 private variable historyIndex 00041 00042 ## the maximum nr of commands stored in the history 00043 public variable maxIndex 100 00044 00045 ## boolean flag with 0: command incomplete, 1: complete 00046 private variable completeFlag 1 00047 00048 ## boolean flag with 0: application, 1: safe shell. the ctrl-t key lets 00049 ## you switch between the two interpreters. the application interpreter is 00050 ## the one executing the XCDG 00051 private variable interpFlag 1 00052 00053 ## interpreter where all commands are executed 00054 private variable safeInterp "" 00055 00056 ## boolean flag 0: print command result, 1: don't 00057 private variable silentFlag 0 00058 00059 ## array of additional commands 00060 private variable commands; ## \type TclArray 00061 00062 ## list of autotag information 00063 private variable tagging {} 00064 00065 ## start of the commandline 00066 private variable firstPosition 0.0 00067 00068 ## end of the commandline 00069 private variable lastPosition 0.0 00070 00071 ## temporarily store the old shell background color here 00072 private variable oldBackground "" 00073 00074 ## flag indicating wether next insert deletes line 00075 private variable needsLineFeed 0 00076 00077 private method fgets_action {} 00078 private method return_action {} 00079 private method tab_action {} 00080 private method tabtab_action {} 00081 private method up_action {} 00082 private method down_action {} 00083 private method left_action {} 00084 private method home_action {} 00085 private method end_action {} 00086 private method backspace_action {} 00087 private method delete_action {} 00088 private method control_d_action {} 00089 private method control_q_action {} 00090 private method control_c_action {} 00091 private method control_l_action {} 00092 private method b1_action {x y} ; ## \type TclNumber, TclNumber 00093 private method double_1_action {x y} ; ## \type TclNumber, TclNumber 00094 private method triple_1_action {x y} ; ## \type TclNumber, TclNumber 00095 private method prio_action {} 00096 private method next_action {} 00097 private method shift_up_action {} 00098 private method shift_down_action {} 00099 private method switch_interp {} 00100 private method getCompletions {name {parameter ""}}; ## \type TclString, TclString 00101 00102 public method updateCmd {args}; ## \type TclList 00103 public method getCmd {} 00104 public method deleteCmd {} 00105 public method resetCmd {args}; ## \type TclList 00106 public method safeEval {cmd}; ## \type TclCommand 00107 public method safeSource {file}; ## \type TclString 00108 public method insert {string}; ## \type TclString 00109 public method clear {} 00110 public method setCursor {pos}; ## \type TclString 00111 public method autotag {pattern args}; ## \type TclString, TclList 00112 public method fgets {} 00113 00114 # Should we confirm exit from the program? 00115 public method getConfirmExit {} 00116 public method setConfirmExit {x}; ## \type TclBoolean 00117 private variable confirmexit 1 00118 00119 constructor {args} {}; ## \type TclList 00120 00121 }; 00122 00123 ##----------------------------------------------------------------------------- 00124 ## constructor 00125 ##----------------------------------------------------------------------------- 00126 body CdgShell::constructor {args} { 00127 array set commands { 00128 00129 # original CDG commands 00130 activate {::cmd::Activate section} 00131 annos2prolog {::cmd::Annos2Prolog ""} 00132 annotation {::cmd::Annotation anno} 00133 anno2parse {::cmd::Anno2Parse anno} 00134 chunk {::cmd::Chunk lattice} 00135 compareparses {::cmd::Compareparses parse} 00136 compile {::cmd::Compile ""} 00137 constraint {::cmd::Constraint constraint} 00138 deactivate {::cmd::Deactivate section} 00139 distance {::cmd::Distance net} 00140 edges {::cmd::Edges net} 00141 frobbing {::cmd::Frobbing net} 00142 gls {::cmd::Gls net} 00143 ngls {::cmd::NewGls net} 00144 hierarchy {::cmd::Hierarchy hierarchy} 00145 hook {::cmd::Hook hkHooks} 00146 incrementalcompletion {::cmd::IncrementalCompletion lattice} 00147 inputwordgraph {::cmd::Inputwordgraph ""} 00148 isearch {::cmd::Isearch lattice} 00149 level {::cmd::Level level} 00150 levelsort {::cmd::Levelsort level} 00151 lexicon {::cmd::Lexicon word} 00152 license {::cmd::License ""} 00153 load {::cmd::Load file} 00154 ls {::cmd::Ls file} 00155 net {::cmd::Net net} 00156 netdelete {::cmd::Netdelete net} 00157 netsearch {::cmd::Netsearch net} 00158 newnet {::cmd::Newnet lattice} 00159 nonspeccompatible {::cmd::Nonspeccompatible constraint} 00160 parses2prolog {::cmd::Parses2Prolog ""} 00161 printparse {::cmd::PrintParse parse} 00162 printparses {::cmd::PrintParses net} 00163 quit {::cmd::Quit ""} 00164 renewnet {::cmd::Renewnet net} 00165 reset {::cmd::Reset ""} 00166 search {::cmd::Search ""} 00167 section {::cmd::Section ""} 00168 set {::cmd::Set variable} 00169 shift-reduce {::cmd::Shift net} 00170 showlevel {::cmd::Showlevel level} 00171 source {::cmd::Source file} 00172 status {::cmd::Status ""} 00173 tagger {::cmd::Tagger ""} 00174 testing {::cmd::Testing ""} 00175 time {::time ""} 00176 useconstraint {::cmd::Useconstraint constraint} 00177 uselevel {::cmd::Uselevel level} 00178 verify {::cmd::Verify parse} 00179 version {::cmd::Version} 00180 weight {::cmd::Weight constraint} 00181 wordgraph {::cmd::Wordgraph lattice} 00182 writeannotation {::cmd::Writeannotation net} 00183 writenet {::cmd::Writenet net} 00184 writeparse {::cmd::WriteParses net} 00185 writewordgraph {::cmd::WriteWordgraph lattice} 00186 00187 # additional XCDG commands 00188 clear {::cmd::Clear "" } 00189 cd {::cmd::Cd file} 00190 deleteparse {::cmd::Deleteparse parse} 00191 printf {::cmd::Printf ""} 00192 puts {::cmd::Puts ""} 00193 pwd {::pwd ""} 00194 regexpr {::regexpr ""} 00195 regsub {::regsub ""} 00196 run {::cmd::Source file} 00197 showparse {::cmd::Showparse parse/anno} 00198 00199 00200 } 00201 00202 set text [component text] 00203 00204 # bind $text <KeyPress> [code "$this updateCmd"] 00205 bind $text <Return> [code "$this return_action; break" ] 00206 bind $text <Tab> [code "$this tab_action; break"] 00207 bind $text <Tab><Tab> [code "$this tabtab_action; break" ] 00208 bind $text <Control-a> [code "$this updateCmd; $this home_action ; break" ] 00209 bind $text <Control-c> [code "$this updateCmd; $this control_c_action ; break" ] 00210 bind $text <Control-l> [code "$this control_l_action ; break" ] 00211 bind $text <Control-d> [code "$this control_d_action" ] 00212 bind $text <Control-q> [code "$this control_q_action" ] 00213 bind $text <Up> [code "$this updateCmd; $this up_action ; break" ] 00214 bind $text <Down> [code "$this updateCmd; $this down_action ; break" ] 00215 bind $text <Home> [code "$this updateCmd; $this home_action ; break" ] 00216 bind $text <End> [code "$this updateCmd; $this end_action ; break" ] 00217 bind $text <BackSpace> [code "$this updateCmd; $this backspace_action ; break" ] 00218 bind $text <Delete> [code "$this updateCmd; $this delete_action ; break" ] 00219 bind $text <Left> [code "$this updateCmd; $this left_action ; break" ] 00220 00221 bind $text <1> [code "$this b1_action %x %y; break" ] 00222 bind $text <Double-1> [code "$this double_1_action %x %y; break" ] 00223 bind $text <Triple-1> [code "$this triple_1_action %x %y; break" ] 00224 00225 bind $text <Prior> [code "$this updateCmd; $this prio_action ; break" ] 00226 bind $text <Next> [code "$this updateCmd; $this next_action ; break" ] 00227 00228 # Sense ? 00229 # bind $text <Shift-Prior> [code "$this prio_action ; break" ] 00230 # bind $text <Shift-Next> [code "$this next_action ; break" ] 00231 00232 bind $text <Shift-Up> [code "$this updateCmd; $this shift_up_action ; break" ] 00233 bind $text <Shift-Down> [code "$this updateCmd; $this shift_down_action ; break" ] 00234 00235 # disable a couple of things 00236 00237 # bind $text <Select> break 00238 00239 bind $text <Shift-Left> break 00240 bind $text <Shift-Right> break 00241 bind $text <Shift-Home> break 00242 bind $text <Shift-End> break 00243 bind $text <Shift-Tab> break 00244 # bind $text <Shift-Select> break 00245 00246 bind $text <Control-Left> break 00247 bind $text <Control-Right> break 00248 bind $text <Control-Up> break 00249 bind $text <Control-Down> break 00250 bind $text <Control-Prior> break 00251 bind $text <Control-Next> break 00252 bind $text <Control-Home> break 00253 bind $text <Control-Shift-Home> break 00254 bind $text <Control-End> break 00255 bind $text <Control-Tab> break 00256 bind $text <Control-i> break 00257 bind $text <Control-space> break 00258 bind $text <Control-slash> break 00259 bind $text <Control-backslash> break 00260 00261 bind $text <Shift-Control-End> break 00262 bind $text <Shift-Control-Left> break 00263 bind $text <Shift-Control-Right> break 00264 bind $text <Shift-Control-Up> break 00265 bind $text <Shift-Control-Down> break 00266 bind $text <Shift-Control-Tab> break 00267 bind $text <Control-Shift-space> break 00268 00269 bind $text <Control-i> [code "$this switch_interp; break"] 00270 00271 focus $text 00272 00273 set safeInterp [interp create -safe] 00274 00275 set knownCmds [$safeInterp eval {info commands}] 00276 foreach srcCmd [array names commands] { 00277 if {[lsearch $knownCmds $srcCmd] >=0} { 00278 $safeInterp eval [list rename $srcCmd ""] 00279 } 00280 $safeInterp alias $srcCmd [lindex $commands($srcCmd) 0] 00281 } 00282 00283 foreach srcCmd {fcopy fblocked fileevent flush read seek tell gets} { 00284 $safeInterp eval [list rename $srcCmd ""] 00285 } 00286 00287 set history(0) "" 00288 set history(1) "" 00289 set historyIndex(0) -1 00290 set historyIndex(1) -1 00291 00292 eval itk_initialize $args 00293 00294 resetCmd 00295 deleteCmd 00296 } 00297 00298 00299 ##----------------------------------------------------------------------------- 00300 ## option -background. 00301 ##----------------------------------------------------------------------------- 00302 configbody CdgShell::background { 00303 configure -textbackground $itk_option(-background) 00304 } 00305 00306 ##----------------------------------------------------------------------------- 00307 ## add a syntax highlightening rule. 00308 ##----------------------------------------------------------------------------- 00309 body CdgShell::autotag {pattern args} { 00310 lappend tagging $pattern 00311 eval tag configure $pattern $args 00312 } 00313 00314 ##----------------------------------------------------------------------------- 00315 ## evaluate a command in the safe interpreter. 00316 ##----------------------------------------------------------------------------- 00317 body CdgShell::safeEval {cmd} { 00318 global errorInfo 00319 00320 insert \n 00321 00322 set oldCursor [cget -cursor] 00323 . configure -cursor watch 00324 update idletask 00325 00326 set result "" 00327 00328 set errorInfo "" 00329 if {$interpFlag} { 00330 if {[catch { set result [$safeInterp eval $cmd] } errMsg] } { 00331 insert "ERROR: $errMsg\n" 00332 if {$showTrace > 0} { 00333 insert "$errorInfo\n" 00334 } 00335 } 00336 } else { 00337 if {[catch { set result [uplevel "#0" $cmd] } errMsg] } { 00338 insert "ERROR: $errMsg\n" 00339 if {$showTrace > 0} { 00340 insert "$errorInfo\n" 00341 } 00342 } 00343 } 00344 00345 . configure -cursor $oldCursor 00346 00347 if {!$silentFlag && $result != ""} { 00348 insert "$result\n" 00349 } 00350 00351 resetCmd 00352 deleteCmd 00353 00354 return $result 00355 } 00356 00357 ##----------------------------------------------------------------------------- 00358 ## source the commands in the safe interpreter. 00359 ## \param file filename of the file to be read 00360 ##----------------------------------------------------------------------------- 00361 body CdgShell::safeSource {file} { 00362 set silentFlag 1 00363 set fid [open [glob $file]] 00364 set script [read $fid] 00365 close $fid 00366 safeEval $script 00367 set silentFlag 0 00368 return 00369 } 00370 00371 ##----------------------------------------------------------------------------- 00372 ## set the insert cursor. 00373 ## \param pos a valid tcl text widget index specification. 00374 ##----------------------------------------------------------------------------- 00375 body CdgShell::setCursor {pos} { 00376 mark set insert $pos 00377 # tag remove sel 1.0 end 00378 see insert 00379 } 00380 00381 ##----------------------------------------------------------------------------- 00382 ## print a string to the shell output. 00383 ## \param string the message to be printed 00384 ##----------------------------------------------------------------------------- 00385 body CdgShell::insert {string} { 00386 global errorInfo 00387 00388 set tempErrorInfo $errorInfo 00389 00390 # insertions overwrite selections: 00391 # a habit of mine is to type something then press shift+cursormovement 00392 # and then replace the marked stuff with something else 00393 catch { 00394 if {[compare sel.first <= insert] 00395 && [compare sel.last >= insert]} { 00396 delete sel.first sel.last 00397 } 00398 } 00399 set errorInfo $tempErrorInfo 00400 00401 ::scan [index end] %d logFirst 00402 incr logFirst -1 00403 00404 # split string by formfeeds if available 00405 set splitStringList [split $string "\r"] 00406 set isfirst 1 00407 foreach splitString $splitStringList { 00408 if {!$needsLineFeed && $isfirst} { 00409 Scrolledtext::insert end "$splitString" 00410 set isfirst 0 00411 } else { 00412 deleteCmd 00413 Scrolledtext::insert end "$splitString" 00414 } 00415 } 00416 00417 # if the last list is empty then the last character is a linefeed 00418 # ergo the next output must first delete the line 00419 # we register this in `needsLineFeed' 00420 if {"[lindex $splitStringList end]" == ""} { 00421 set needsLineFeed 1 00422 } else { 00423 set needsLineFeed 0 00424 } 00425 00426 ::scan [index end] %d logLast 00427 00428 foreach pattern $tagging { 00429 for {set i $logFirst} {$i < $logLast} {incr i} { 00430 mark set last $i.0 00431 while {[regexp -indices $pattern [get last "last lineend"] indices]} { 00432 00433 mark set first "last + [lindex $indices 0] chars" 00434 mark set last "last + 1 chars + [lindex $indices 1] chars" 00435 tag add $pattern first last 00436 } 00437 } 00438 } 00439 00440 set firstPosition [index insert] 00441 set lastPosition $firstPosition 00442 } 00443 00444 00445 ##----------------------------------------------------------------------------- 00446 ## delete the current command-line 00447 ##----------------------------------------------------------------------------- 00448 body CdgShell::deleteCmd {} { 00449 ::scan $firstPosition "%d.%d" row col 00450 delete $row.0 $lastPosition 00451 00452 setCursor end 00453 set firstPosition [index insert] 00454 set lastPosition $firstPosition 00455 } 00456 00457 00458 ##----------------------------------------------------------------------------- 00459 ## get a single line of input from the user without interpreting it. 00460 ## This proc is only used during subprompts, e.g. as used by frobbing 00461 ##----------------------------------------------------------------------------- 00462 body CdgShell::fgets {} { 00463 00464 global fgets_result 00465 set fgets_result "" 00466 00467 # temporarily redirect the <Return> event 00468 set oldBinding [bind $itk_component(text) <Return>] 00469 bind $itk_component(text) <Return> [code "$this fgets_action ; break" ] 00470 00471 # fgets_action sets this variable 00472 # (has to be global because vwait can't handle class variables) 00473 vwait fgets_result 00474 00475 # restore old event binding 00476 bind $itk_component(text) <Return> $oldBinding 00477 00478 # return string typed by the user 00479 return $fgets_result 00480 00481 } 00482 00483 ##------------------------------------------------------------------------------ 00484 ## alternative &lt;Return&gt; handler, 00485 ## This version gets a line, but does not call cdg commands. 00486 ##------------------------------------------------------------------------------ 00487 body CdgShell::fgets_action {} { 00488 00489 # communicate with fgets{} 00490 global fgets_result 00491 set fgets_result [getCmd] 00492 00493 # display the return key 00494 insert "\n" 00495 00496 } 00497 00498 00499 ##----------------------------------------------------------------------------- 00500 ## the return key binding. 00501 ##----------------------------------------------------------------------------- 00502 body CdgShell::return_action {} { 00503 set cmd [getCmd] 00504 if {$cmd == ""} { 00505 insert "\n" 00506 resetCmd 00507 return 00508 } 00509 00510 set completeFlag [info complete $cmd] 00511 if {$completeFlag} { 00512 safeEval "$cmd" 00513 lappend history($interpFlag) $cmd 00514 if {$historyIndex($interpFlag) > $maxIndex} { 00515 set history($interpFlag) [lreplace history($interpFlag) 0 0] 00516 } 00517 set historyIndex($interpFlag) [llength $history($interpFlag)] 00518 00519 if {$interpFlag} { 00520 configure -prompt $itk_option(-prompt1) 00521 } else { 00522 configure -prompt $itk_option(-prompt2) 00523 } 00524 resetCmd 00525 } else { 00526 updateCmd "\n" 00527 } 00528 setCursor end 00529 } 00530 00531 ##----------------------------------------------------------------------------- 00532 ## get the set of possible commandline completions. 00533 ## 00534 ## \param name the string to be completed. If it is "file", 00535 ## then \c parameter is used to fork an \c "ls \c -adF" 00536 ## 00537 ## \param parameter used when name = "file" 00538 ## 00539 ## \returns the set of possible completions 00540 ##----------------------------------------------------------------------------- 00541 body CdgShell::getCompletions {name {parameter ""}} { 00542 00543 set result "" 00544 00545 catch { 00546 switch $name { 00547 file { 00548 set result [exec /bin/sh -c "ls -adF $parameter*"] 00549 } 00550 hierarchy { 00551 set result [.cdgmain hierarchies getAllHierarchyIds] 00552 } 00553 net { 00554 set result [.cdgmain networks getAllNetIds] 00555 } 00556 parse { 00557 set result [.cdgmain parses getAllparseIds] 00558 } 00559 parse/anno { 00560 # allow names of parses or annotations 00561 set result [.cdgmain parses getAllparseIds] 00562 set result "$result [.cdgmain parses getAllAnnoIds]" 00563 } 00564 anno { 00565 set result [.cdgmain parses getAllAnnoIds] 00566 } 00567 constraint { 00568 set result [.cdgmain constraints getAllConstraintIds] 00569 } 00570 lattice { 00571 set result [.cdgmain wordgraphs getAllLatticeIds] 00572 } 00573 level { 00574 set result [.cdgmain levels getAllLevelIds] 00575 } 00576 section { 00577 set result [.cdgmain levels getAllSectionIds] 00578 } 00579 variable { 00580 set l [setReturnListOfNames] 00581 set result "" 00582 while {$l != "NULL"} { 00583 set item [pointer2string [listElement $l]] 00584 lappend result $item 00585 set l [listNext $l] 00586 } 00587 return $result 00588 } 00589 word { 00590 set result [.cdgmain lexemes getAllWords] 00591 } 00592 default { 00593 set result [::cmd::Set $name] 00594 } 00595 } 00596 } 00597 return $result 00598 } 00599 00600 ##----------------------------------------------------------------------------- 00601 ## double tab action. 00602 ## This method is part of the commandline completion. 00603 ##----------------------------------------------------------------------------- 00604 body CdgShell::tabtab_action {} { 00605 set cmdline [getCmd] 00606 regsub -all {\{} $cmdline {\\\{} cmdline 00607 regsub -all {\}} $cmdline {\\\}} cmdline 00608 set no [llength $cmdline] 00609 set len [string length $cmdline] 00610 set lastChar [string index $cmdline [expr $len -1]] 00611 set result "" 00612 set pivot [lindex $cmdline 0] 00613 regsub -all {\.} $pivot {\.} pivot 00614 regsub -all {\[} $pivot {\[} pivot 00615 00616 if { $lastChar == " " || $no > 1} { 00617 # argument expansion ######################################## 00618 set flag 0 00619 if {[info exists commands($pivot)]} { 00620 set alter [lindex $commands($pivot) 1] 00621 if {"$alter" != ""} { 00622 if {$lastChar == " "} { 00623 set result [lsort [getCompletions $alter]] 00624 } else { 00625 set newArg [lindex $cmdline end] 00626 set result [lsort [getCompletions $alter $newArg]] 00627 set result [lfilter $result "^$newArg.*"] 00628 } 00629 } 00630 } 00631 } else { 00632 # command expansion ######################################## 00633 set flag 1 00634 if {$interpFlag} { 00635 set result [lsort [$safeInterp eval info commands "$pivot*"]] 00636 } else { 00637 set result [lsort [uplevel "#0" info commands "$pivot*"]] 00638 if {[llength $result] > 50} { 00639 insert "\nERROR: too many commands\n" 00640 resetCmd $cmdline 00641 return 00642 } 00643 } 00644 } 00645 # print found stuff 00646 switch [llength $result] { 00647 0 { } 00648 1 { 00649 deleteCmd 00650 if {[string range $result end end] != "/" } { 00651 append result " " 00652 } 00653 if {$flag} { 00654 resetCmd "$result" 00655 } else { 00656 resetCmd "$pivot $result" 00657 } 00658 00659 } 00660 default { 00661 insert "\n$result\n" 00662 resetCmd $cmdline 00663 } 00664 } 00665 } 00666 00667 ##----------------------------------------------------------------------------- 00668 ## tab action. 00669 ## This is part of the commandline completion suite. 00670 ##----------------------------------------------------------------------------- 00671 body CdgShell::tab_action {} { 00672 set cmdline [getCmd] 00673 if {$cmdline == ""} { 00674 return 00675 } 00676 regsub -all {\{} $cmdline {\\\{} cmdline 00677 regsub -all {\}} $cmdline {\\\}} cmdline 00678 set no [llength $cmdline] 00679 set len [string length $cmdline] 00680 set lastChar [string index $cmdline [expr $len -1]] 00681 set result "" 00682 set pivot [lindex $cmdline 0] 00683 regsub -all {\.} $pivot {\.} pivot 00684 regsub -all {\[} $pivot {\[} pivot 00685 00686 if { $lastChar == " " || $no > 1} { 00687 # argument expansion ######################################## 00688 set flag 0 00689 if {[info exists commands($pivot)]} { 00690 set alter [lindex $commands($pivot) 1] 00691 if {"$alter" != ""} { 00692 if {$lastChar == " "} { 00693 set result [lsort [getCompletions $alter]] 00694 } else { 00695 set newArg [lindex $cmdline end] 00696 set result [lsort [getCompletions $alter $newArg]] 00697 set result [lfilter $result "^$newArg.*"] 00698 } 00699 } 00700 } 00701 } else { 00702 # command expansion ######################################## 00703 # show all possible commands (no widgets) 00704 set flag 1 00705 if {$interpFlag} { 00706 set result [lsort [$safeInterp eval info commands "$pivot*"]] 00707 } else { 00708 set result [lsort [uplevel "#0" info commands "$pivot*"]] 00709 } 00710 } 00711 00712 # test if we have to compare 00713 set noitems [llength $result] 00714 if {$noitems == 0} { 00715 return; 00716 } 00717 if {$noitems == 1} { 00718 deleteCmd 00719 if {[string range $result end end] != "/"} { 00720 append result " " 00721 } 00722 if {$flag} { 00723 resetCmd "$result" 00724 } else { 00725 if {$no > 1} { 00726 resetCmd "[lrange $cmdline 0 [expr [llength $cmdline] -2]] $result" 00727 } else { 00728 resetCmd "[lindex $cmdline 0] $result" 00729 } 00730 } 00731 return 00732 } 00733 00734 # 00735 # extract common prefix 00736 # 00737 00738 # copy list to array for faster access, cut away common part 00739 set pivot [lindex $cmdline end] 00740 set i 0 00741 foreach item $result { 00742 regexp "^${pivot}(.*)" $item dummy matches($i) 00743 incr i 00744 } 00745 00746 # compare all first characters and collect common ones in expansion 00747 set expansion "" 00748 set found 1 00749 while {$found} { 00750 set items [lsort [array names matches]] 00751 00752 # if there's nothing left to do, we quit from loop 00753 set noitems [llength $items] 00754 if {$noitems == 0} { 00755 break; 00756 } 00757 00758 # get the first char from the first item 00759 set firstItem [lindex $items 0] 00760 set char [string index $matches($firstItem) 0] 00761 if {"$char" == ""} { 00762 catch {unset matches($firstItem)} 00763 break; 00764 } 00765 00766 # if there exists a non-matching target, then quit loop 00767 foreach i $items { 00768 set found \ 00769 [regexp "^${char}(.*)" $matches($i) dummy matches($i)] 00770 if {!$found} { 00771 break; 00772 } 00773 } 00774 00775 # add common char to expansion 00776 if {$found} { 00777 append expansion $char 00778 } 00779 } 00780 00781 # print found stuff 00782 deleteCmd 00783 resetCmd "$cmdline$expansion" 00784 } 00785 00786 ##----------------------------------------------------------------------------- 00787 ## step backwards thru the commandline history. 00788 ##----------------------------------------------------------------------------- 00789 body CdgShell::up_action {} { 00790 set currentPosition [index insert] 00791 ::scan $currentPosition "%d.%d" currentRow currentCol 00792 ::scan $firstPosition "%d.%d" firstRow firstCol 00793 if {$currentRow == $firstRow} { 00794 set index [expr $historyIndex($interpFlag) -1] 00795 set line [string trim [lindex $history($interpFlag) $index]] 00796 00797 deleteCmd 00798 resetCmd $line 00799 if { "$line" != "" } { 00800 incr historyIndex($interpFlag) -1 00801 } else { 00802 set historyIndex($interpFlag) -1 00803 } 00804 } else { 00805 if {[expr $currentRow - $firstRow] == 1} { 00806 setCursor $firstPosition 00807 } else { 00808 setCursor insert-1l 00809 } 00810 } 00811 } 00812 00813 ##----------------------------------------------------------------------------- 00814 ## scroll forward thru the commandline history. 00815 ##----------------------------------------------------------------------------- 00816 body CdgShell::down_action {} { 00817 set currentPosition [index insert] 00818 ::scan $currentPosition "%d.%d" currentRow currentCol 00819 ::scan $lastPosition "%d.%d" lastRow lastCol 00820 if {$currentRow == $lastRow} { 00821 set index [expr $historyIndex($interpFlag) +1 ] 00822 set line [string trim [lindex $history($interpFlag) $index]] 00823 00824 deleteCmd 00825 resetCmd $line 00826 if { "$line" != "" } { 00827 incr historyIndex($interpFlag) 00828 } else { 00829 set historyIndex($interpFlag) [llength $history($interpFlag)] 00830 } 00831 } else { 00832 setCursor insert+1l 00833 } 00834 } 00835 00836 ##----------------------------------------------------------------------------- 00837 ## restrict cursor movement to the commandline end. 00838 ##----------------------------------------------------------------------------- 00839 body CdgShell::left_action {} { 00840 ::scan [index insert] "%d.%d" currentRow currentCol 00841 ::scan $firstPosition "%d.%d" firstRow firstCol 00842 00843 if {$currentRow > $firstRow || $currentCol > $firstCol} { 00844 setCursor insert-1c 00845 } 00846 } 00847 00848 ##----------------------------------------------------------------------------- 00849 ## set insert cursor to the end of commandline. 00850 ##----------------------------------------------------------------------------- 00851 body CdgShell::end_action {} { 00852 setCursor $lastPosition 00853 } 00854 00855 ##----------------------------------------------------------------------------- 00856 ## set the insert cursor to the start of commandline. 00857 ##----------------------------------------------------------------------------- 00858 body CdgShell::home_action {} { 00859 setCursor $firstPosition 00860 } 00861 00862 ##----------------------------------------------------------------------------- 00863 ## restrict BackSpace to the command-line 00864 ##----------------------------------------------------------------------------- 00865 body CdgShell::backspace_action {} { 00866 ::scan [index insert] "%d.%d" currentRow currentCol 00867 ::scan $firstPosition "%d.%d" firstRow firstCol 00868 00869 if {$currentRow > $firstRow || $currentCol > $firstCol} { 00870 delete insert-1c insert 00871 see insert 00872 } 00873 } 00874 00875 ##----------------------------------------------------------------------------- 00876 ## delete doesnt delete the selection. 00877 ##----------------------------------------------------------------------------- 00878 body CdgShell::delete_action {} { 00879 delete insert insert+1c 00880 see insert 00881 } 00882 00883 ##----------------------------------------------------------------------------- 00884 ## kind of control-c 00885 ##----------------------------------------------------------------------------- 00886 body CdgShell::control_c_action {} { 00887 00888 if {[cdgCtrlCAllowed_get]} { 00889 cdgCtrlCTrapped_set 1 00890 } 00891 setCursor end 00892 deleteCmd 00893 resetCmd 00894 } 00895 00896 ##----------------------------------------------------------------------------- 00897 ## terminate the application. 00898 ##----------------------------------------------------------------------------- 00899 body CdgShell::control_q_action {} { 00900 control_d_action 00901 } 00902 00903 ##----------------------------------------------------------------------------- 00904 ## terminate the application. 00905 ##----------------------------------------------------------------------------- 00906 body CdgShell::control_d_action {} { 00907 00908 # quit if pressed in an empty line... 00909 if {[getCmd] == ""} { ::cmd::Quit } 00910 00911 # ...otherwise chain to default binding 00912 } 00913 00914 ##----------------------------------------------------------------------------- 00915 ## clear the shell screen. 00916 ##----------------------------------------------------------------------------- 00917 body CdgShell::clear {} { 00918 delete 1.0 end 00919 } 00920 00921 ##----------------------------------------------------------------------------- 00922 ## clear the shell screen preventing the commandline content. 00923 ##----------------------------------------------------------------------------- 00924 body CdgShell::control_l_action {} { 00925 set cmd [getCmd] 00926 clear 00927 resetCmd $cmd 00928 } 00929 00930 ##----------------------------------------------------------------------------- 00931 ## button1 only sets the selection anchor. 00932 ##----------------------------------------------------------------------------- 00933 body CdgShell::b1_action {x y} { 00934 global tkPriv 00935 00936 set tkPriv(selectMode) char 00937 set tkPriv(mouseMoved) 0 00938 set tkPriv(pressX) $x 00939 00940 mark set anchor @$x,$y 00941 tag remove sel 0.0 end 00942 } 00943 00944 ##----------------------------------------------------------------------------- 00945 ## double-1 without changing the insert-position. 00946 ##----------------------------------------------------------------------------- 00947 body CdgShell::double_1_action {x y} { 00948 set w [component text] 00949 global tkPriv 00950 00951 set tkPriv(selectMode) word 00952 00953 tkTextSelectTo $w $x $y 00954 } 00955 00956 ##----------------------------------------------------------------------------- 00957 ## Triple-1 without changing the insert-position. 00958 ##----------------------------------------------------------------------------- 00959 body CdgShell::triple_1_action {x y} { 00960 set w [component text] 00961 global tkPriv 00962 00963 set tkPriv(selectMode) line 00964 00965 tkTextSelectTo $w $x $y 00966 } 00967 00968 ##----------------------------------------------------------------------------- 00969 ## simply scroll up one page, no cursor positioning. 00970 ##----------------------------------------------------------------------------- 00971 body CdgShell::prio_action {} { 00972 yview scroll -1 pages 00973 } 00974 00975 ##----------------------------------------------------------------------------- 00976 ## simply scroll down one page, no cursor positioning. 00977 ##----------------------------------------------------------------------------- 00978 body CdgShell::next_action {} { 00979 yview scroll 1 pages 00980 } 00981 00982 ##----------------------------------------------------------------------------- 00983 ## simply scroll up one line, no cursor positioning. 00984 ##----------------------------------------------------------------------------- 00985 body CdgShell::shift_up_action {} { 00986 yview scroll -1 units 00987 } 00988 00989 ##----------------------------------------------------------------------------- 00990 ## simply scroll down one line, no cursor positioning. 00991 ##----------------------------------------------------------------------------- 00992 body CdgShell::shift_down_action {} { 00993 yview scroll 1 units 00994 } 00995 00996 ##----------------------------------------------------------------------------- 00997 ## expand commandline if needed. 00998 ##----------------------------------------------------------------------------- 00999 body CdgShell::updateCmd {args} { 01000 if {$args != {}} { 01001 Scrolledtext::insert end [join $args] 01002 } 01003 01004 set testPosition [index insert] 01005 ::scan $testPosition "%d.%d" testRow testCol 01006 ::scan $lastPosition "%d.%d" lastRow lastCol 01007 if {($testRow > $lastRow) || \ 01008 ($testRow == $lastRow && $testCol > $lastCol)} { 01009 set lastPosition $testPosition 01010 } 01011 01012 set testPosition [index end-1c] 01013 ::scan $testPosition "%d.%d" testRow testCol 01014 ::scan $lastPosition "%d.%d" lastRow lastCol 01015 if {($testRow > $lastRow) || \ 01016 ($testRow == $lastRow && $testCol > $lastCol)} { 01017 set lastPosition $testPosition 01018 } 01019 } 01020 01021 ##----------------------------------------------------------------------------- 01022 ## get actual command. 01023 ##----------------------------------------------------------------------------- 01024 body CdgShell::getCmd {} { 01025 updateCmd 01026 set cmd [get $firstPosition $lastPosition] 01027 return $cmd 01028 } 01029 01030 ##----------------------------------------------------------------------------- 01031 ## reset commandline. 01032 ##----------------------------------------------------------------------------- 01033 body CdgShell::resetCmd {{cmd ""}} { 01034 setCursor end 01035 insert "$itk_option(-prompt)" 01036 set firstPosition [index insert] 01037 if {"$cmd" != ""} { 01038 updateCmd "$cmd" 01039 set lastPosition [index insert] 01040 } else { 01041 set lastPosition $firstPosition 01042 } 01043 return 01044 } 01045 01046 ##----------------------------------------------------------------------------- 01047 ## switch interpreter. 01048 ## This method allows you to access the interpreter that executes the XCDG application. 01049 ##----------------------------------------------------------------------------- 01050 body CdgShell::switch_interp {} { 01051 if {$completeFlag} { 01052 if {$interpFlag} { 01053 set interpFlag 0 01054 set oldBackground $itk_option(-textbackground) 01055 configure \ 01056 -prompt $itk_option(-prompt2) \ 01057 -textbackground "gray80" 01058 } else { 01059 set interpFlag 1 01060 configure \ 01061 -prompt $itk_option(-prompt1) \ 01062 -textbackground $oldBackground 01063 } 01064 deleteCmd 01065 resetCmd 01066 } 01067 } 01068 01069 # ---------------------------------------------------------------------- 01070 # Set exit confirmation flag. 01071 body CdgShell::setConfirmExit {x} { 01072 set confirmexit $x 01073 } 01074 01075 # ---------------------------------------------------------------------- 01076 # Get exit confirmation flag. 01077 body CdgShell::getConfirmExit {} { 01078 return $confirmexit 01079 } 01080 01081 01082 #----------------------------------------------------------------------------- 01083 # redefine the paste not to change the insert-cursor 01084 proc tkTextPaste {w x y} {; ## \type TclWidget, TclNumber, TclNumber 01085 catch { 01086 .cdgmain shell updateCmd [selection get -displayof $w] 01087 .cdgmain shell setCursor end 01088 if {[$w cget -state] == "normal"} {focus $w} 01089 } 01090 } 01091 01092 #----------------------------------------------------------------------------- 01093 #----------------------------------------------------------------------------- 01094

XCDG 0.95 (20 Oct 2004)