2 ## Copyright 1996-1997 Jeffrey Hobbs
4 ## source standard_disclaimer.tcl
5 ## source beer_ware.tcl
7 ## Based off previous work for TkCon
10 ##------------------------------------------------------------------------
15 ## Implements a console mega-widget
18 ## console <window pathname> <options>
21 ## (Any frame widget option may be used in addition to these)
23 ## -blinkcolor color DEFAULT: yellow
24 ## Specifies the background blink color for brace highlighting.
25 ## This doubles as the highlight color for the find box.
27 ## -blinkrange TCL_BOOLEAN DEFAULT: 1
28 ## When doing electric brace matching, specifies whether to blink
29 ## the entire range or just the matching braces.
31 ## -blinktime delay DEFAULT: 500
32 ## For electric brace matching, specifies the amount of time to
33 ## blink the background for.
35 ## -grabputs TCL_BOOLEAN DEFAULT: 1
36 ## Whether this console should grab the "puts" default output
38 ## -lightbrace TCL_BOOLEAN DEFAULT: 1
39 ## Specifies whether to activate electric brace matching.
41 ## -lightcmd TCL_BOOLEAN DEFAULT: 1
42 ## Specifies whether to highlight recognized commands.
44 ## -proccolor color DEFAULT: darkgreen
45 ## Specifies the color to highlight recognized procs.
47 ## -promptcolor color DEFAULT: brown
48 ## Specifies the prompt color.
50 ## -stdincolor color DEFAULT: black
51 ## Specifies the color for "stdin".
52 ## This doubles as the console foreground color.
54 ## -stdoutcolor color DEFAULT: blue
55 ## Specifies the color for "stdout".
57 ## -stderrcolor color DEFAULT: red
58 ## Specifies the color for "stderr".
60 ## -showmultiple TCL_BOOLEAN DEFAULT: 1
61 ## For file/proc/var completion, specifies whether to display
62 ## completions when multiple choices are possible.
64 ## -showmenu TCL_BOOLEAN DEFAULT: 1
65 ## Specifies whether to show the menubar.
67 ## -subhistory TCL_BOOLEAN DEFAULT: 1
68 ## Specifies whether to allow substitution in the history.
70 ## RETURNS: the window pathname
72 ## BINDINGS (these are the bindings for Console, used in the text widget)
74 ## <<Console_ExpandFile>> <Key-Tab>
75 ## <<Console_ExpandProc>> <Control-Shift-Key-P>
76 ## <<Console_ExpandVar>> <Control-Shift-Key-V>
77 ## <<Console_Tab>> <Control-Key-i>
78 ## <<Console_Eval>> <Key-Return> <Key-KP_Enter>
80 ## <<Console_Clear>> <Control-Key-l>
81 ## <<Console_KillLine>> <Control-Key-k>
82 ## <<Console_Transpose>> <Control-Key-t>
83 ## <<Console_ClearLine>> <Control-Key-u>
84 ## <<Console_SaveCommand>> <Control-Key-z>
86 ## <<Console_Previous>> <Key-Up>
87 ## <<Console_Next>> <Key-Down>
88 ## <<Console_NextImmediate>> <Control-Key-n>
89 ## <<Console_PreviousImmediate>> <Control-Key-p>
90 ## <<Console_PreviousSearch>> <Control-Key-r>
91 ## <<Console_NextSearch>> <Control-Key-s>
93 ## <<Console_Exit>> <Control-Key-q>
94 ## <<Console_New>> <Control-Key-N>
95 ## <<Console_Close>> <Control-Key-w>
96 ## <<Console_About>> <Control-Key-A>
97 ## <<Console_Help>> <Control-Key-H>
98 ## <<Console_Find>> <Control-Key-F>
101 ## These are the methods that the console megawidget recognizes.
103 ## configure ?option? ?value option value ...?
105 ## Standard tk widget routines.
108 ## Loads the named file into the current interpreter.
109 ## If no file is specified, it pops up the file requester.
112 ## Saves the console buffer to the named file.
113 ## If no file is specified, it pops up the file requester.
115 ## clear ?percentage?
116 ## Clears a percentage of the console buffer (1-100). If no
117 ## percentage is specified, the entire buffer is cleared.
120 ## Displays the last error in the interpreter in a dialog box.
123 ## Withdraws the console from the screen
125 ## history ?-newline?
126 ## Prints out the history without numbers (basically providing a
127 ## list of the commands you've used).
130 ## Deiconifies and raises the console
133 ## Returns the true widget path of the specified widget. Valid
134 ## widgets are console, yscrollbar, menubar.
137 ## The megawidget creates a global array with the classname, and a
138 ## global array which is the name of each megawidget created. The latter
139 ## array is deleted when the megawidget is destroyed.
140 ## The procedure console and those beginning with Console are
141 ## used. Also, when a widget is created, commands named .$widgetname
142 ## and Console$widgetname are created.
146 ## console .con -height 20 -showmenu false
147 ## pack .con -fill both -expand 1
148 ##------------------------------------------------------------------------
150 package require Widget 1.0
151 set CONSOLE_VERSION 1.51
152 package provide Console $CONSOLE_VERSION
154 foreach pkg [info loaded {}] {
155 set file [lindex $pkg 0]
156 set name [lindex $pkg 1]
157 if {![catch {set version [package require $name]}]} {
158 if {[string match {} [package ifneeded $name $version]]} {
159 package ifneeded $name $version "load [list $file $name]"
163 catch {unset file name version}
165 set Console(WWW) [expr [info exists embed_args] || [info exists browser_args]]
169 base {text console console {-wrap char -setgrid 1 \
170 -yscrollcommand [list $data(yscrollbar) set] \
171 -foreground $data(-stdincolor)}}
173 {frame menubar menubar {-relief raised -bd 1}}
174 {scrollbar yscrollbar sy {-takefocus 0 -bd 1 \
175 -command [list $data(console) yview]}}
178 -blinkcolor {blinkColor BlinkColor \#FFFF00}
179 -proccolor {procColor ProcColor \#008800}
180 -promptcolor {promptColor PromptColor \#8F4433}
181 -stdincolor {stdinColor StdinColor \#000000}
182 -stdoutcolor {stdoutColor StdoutColor \#0000FF}
183 -stderrcolor {stderrColor StderrColor \#FF0000}
184 -varcolor {varColor VarColor \#FFC0D0}
186 -blinkrange {blinkRange BlinkRange 1}
187 -blinktime {blinkTime BlinkTime 500}
188 -grabputs {grabPuts GrabPuts 1}
189 -lightbrace {lightBrace LightBrace 1}
190 -lightcmd {lightCmd LightCmd 1}
191 -showmultiple {showMultiple ShowMultiple 1}
192 -showmenu {showMenu ShowMenu 1}
193 -subhistory {subhistory SubHistory 1}
195 release {July 23 1997}
196 contact "jeff.hobbs@acm.org"
197 docs "http://www.cs.uoregon.edu/research/tcl/script/tkcon/"
198 slavealias { console }
199 slaveprocs { alias dir dump lremove puts echo unknown tcl_unknown which }
201 if {![info exists Console(active)]} { set Console(active) {} }
202 set Console(version) $CONSOLE_VERSION
205 set Console(-prompt) {prompt Prompt {[history nextid] % }}
207 set Console(-prompt) {prompt Prompt \
208 {([file tail [pwd]]) [history nextid] % }}
211 # Create this to make sure there are registered in auto_mkindex
212 # these must come before the [widget create ...]
215 widget create Console
217 array set ConsoleDialog {
223 # Create this to make sure there are registered in auto_mkindex
224 # these must come before the [widget create ...]
225 proc ConsoleDialog args {}
226 proc consoledialog args {}
227 proc console_dialog args {}
228 widget create ConsoleDialog
229 interp alias {} console_dialog {} ConsoleDialog
231 ;proc ConsoleDialog:construct {w} {
232 upvar \#0 $w data ConsoleDialog class
234 wm title $w "Console Dialog $class(version)"
236 grid $data(console) -in $w -sticky news
237 grid columnconfig $w 0 -weight 1
238 grid rowconfig $w 0 -weight 1
241 ;proc ConsoleDialog:configure {w args} {
242 ## We have nothing to configure
245 set truth {^(1|yes|true|on)$}
246 foreach {key val} $args {
252 ;proc ConsoleDialog_hide w {
253 if {[winfo exists $w]} { wm withdraw $w }
256 ;proc ConsoleDialog_show w {
257 if {[winfo exists $w]} { wm deiconify $w; raise $w }
261 # ARGS: w - widget pathname of the Console console
263 # Calls: ConsoleInitUI
264 # Outputs: errors found in Console resource file
266 ;proc Console:construct {w} {
269 global auto_path tcl_pkgPath tcl_interactive
270 set tcl_interactive 0
274 app {} appname {} apptype {} namesp {} deadapp 0
275 cmdbuf {} cmdsave {} errorInfo {}
276 event 1 histid 0 find {} find,case 0 find,reg 0
279 if {![info exists tcl_pkgPath]} {
280 set dir [file join [file dirname [info nameofexec]] lib]
281 if {[string compare {} [info commands @scope]]} {
282 set dir [file join $dir itcl]
284 catch {source [file join $dir pkgIndex.tcl]}
286 catch {tclPkgUnknown dummy-name dummy-version}
290 grid $data(menubar) - -sticky ew
291 grid $data(console) $data(yscrollbar) -sticky news
292 grid columnconfig $w 0 -weight 1
293 grid rowconfig $w 1 -weight 1
295 Console:prompt $w "console display active\n"
298 foreach col {prompt stdout stderr stdin proc} {
299 $c tag configure $col -foreground $data(-${col}color)
301 $c tag configure var -background $data(-varcolor)
302 $c tag configure blink -background $data(-blinkcolor)
303 $c tag configure find -background $data(-blinkcolor)
307 ;proc Console:init {w} {
308 upvar \#0 $w data Console class
309 bind $w <Destroy> [bind $class(class) <Destroy>]
310 bindtags $w [list $w [winfo toplevel $w] all]
312 bindtags $c [list $c Console PostConsole $w all]
313 if {$data(-grabputs) && [lsearch $class(active) $c] == -1} {
314 set class(active) [linsert $class(active) 0 $c]
318 ;proc Console:destroy w {
319 upvar \#0 $w data Console class
320 set class(active) [lremove $class(active) $data(console)]
323 ;proc Console:configure { W args } {
327 set truth {^(1|yes|true|on)$}
329 foreach {key val} $args {
332 $c tag config blink -background $val
333 $c tag config find -background $val
335 -proccolor { $c tag config proc -foreground $val }
336 -promptcolor { $c tag config prompt -foreground $val }
338 $c tag config stdin -foreground $val
339 $c config -foreground $val
341 -stdoutcolor { $c tag config stdout -foreground $val }
342 -stderrcolor { $c tag config stderr -foreground $val }
345 if {![regexp {[0-9]+} $val]} {
346 return -code error "$key option requires an integer value"
347 } elseif {$val < 100} {
348 return -code error "$key option must be greater than 100"
352 if {[set val [regexp -nocase $truth $val]]} {
353 set Console(active) [linsert $Console(active) 0 $c]
355 set Console(active) [lremove -all $Console(active) $c]
359 if {[catch {uplevel \#0 [list subst $val]} err]} {
360 return -code error "\"$val\" threw an error:\n$err"
364 if {[set val [regexp -nocase $truth $val]]} {
367 grid remove $data(menubar)
373 -subhistory { set val [regexp -nocase $truth $val] }
379 ;proc Console:exit {w args} {
383 ## ConsoleEval - evaluates commands input into console window
384 ## This is the first stage of the evaluating commands in the console.
385 ## They need to be broken up into consituent commands (by ConsoleCmdSep) in
386 ## case a multiple commands were pasted in, then each is eval'ed (by
387 ## ConsoleEvalCmd) in turn. Any uncompleted command will not be eval'ed.
388 # ARGS: w - console text widget
389 # Calls: ConsoleCmdGet, ConsoleCmdSep, ConsoleEvalCmd
391 ;proc ConsoleEval {w} {
392 set incomplete [ConsoleCmdSep [ConsoleCmdGet $w] cmds last]
393 $w mark set insert end-1c
395 if {[llength $cmds]} {
396 foreach c $cmds {ConsoleEvalCmd $w $c}
397 $w insert insert $last {}
398 } elseif {!$incomplete} {
399 ConsoleEvalCmd $w $last
404 ## ConsoleEvalCmd - evaluates a single command, adding it to history
405 # ARGS: w - console text widget
406 # cmd - the command to evaluate
407 # Calls: Console:prompt
408 # Outputs: result of command to stdout (or stderr if error occured)
409 # Returns: next event number
411 ;proc ConsoleEvalCmd {w cmd} {
412 ## HACK to get $W as we need it
413 set W [winfo parent $w]
416 $w mark set output end
417 if {[string compare {} $cmd]} {
419 if {$data(-subhistory)} {
420 set ev [ConsoleEvalSlave history nextid]
422 if {[string match !! $cmd]} {
423 set code [catch {ConsoleEvalSlave history event $ev} cmd]
424 if {!$code} {$w insert output $cmd\n stdin}
425 } elseif {[regexp {^!(.+)$} $cmd dummy evnt]} {
426 ## Check last event because history event is broken
427 set code [catch {ConsoleEvalSlave history event $ev} cmd]
428 if {!$code && ![string match ${evnt}* $cmd]} {
429 set code [catch {ConsoleEvalSlave history event $evnt} cmd]
431 if {!$code} {$w insert output $cmd\n stdin}
432 } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} {
433 set code [catch {ConsoleEvalSlave history event $ev} cmd]
435 regsub -all -- $old $cmd $new cmd
436 $w insert output $cmd\n stdin
441 $w insert output $cmd\n stderr
443 ConsoleEvalSlave history add $cmd
444 if {[catch {ConsoleEvalAttached $cmd} res]} {
445 if {[catch {ConsoleEvalAttached {set errorInfo}} err]} {
446 set data(errorInfo) "Error getting errorInfo:\n$err"
448 set data(errorInfo) $err
450 $w insert output $res\n stderr
451 } elseif {[string compare {} $res]} {
452 $w insert output $res\n stdout
457 set data(event) [ConsoleEvalSlave history nextid]
460 ## ConsoleEvalSlave - evaluates the args in the associated slave
461 ## args should be passed to this procedure like they would be at
462 ## the command line (not like to 'eval').
463 # ARGS: args - the command and args to evaluate
465 ;proc ConsoleEvalSlave {args} {
469 ## ConsoleEvalAttached
471 ;proc ConsoleEvalAttached {args} {
472 uplevel \#0 eval $args
475 ## ConsoleCmdGet - gets the current command from the console widget
476 # ARGS: w - console text widget
477 # Returns: text which compromises current command line
479 ;proc ConsoleCmdGet w {
480 if {[string match {} [$w tag nextrange prompt limit end]]} {
481 $w tag add stdin limit end-1c
482 return [$w get limit end-1c]
486 ## ConsoleCmdSep - separates multiple commands into a list and remainder
487 # ARGS: cmd - (possible) multiple command to separate
488 # list - varname for the list of commands that were separated.
489 # rmd - varname of any remainder (like an incomplete final command).
490 # If there is only one command, it's placed in this var.
491 # Returns: constituent command info in varnames specified by list & rmd.
493 ;proc ConsoleCmdSep {cmd list last} {
494 upvar 1 $list cmds $last inc
497 foreach c [split [string trimleft $cmd] \n] {
498 if {[string compare $inc {}]} {
501 append inc [string trimleft $c]
503 if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
504 if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
508 set i [string compare $inc {}]
509 if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} {
510 set inc [lindex $cmds end]
511 set cmds [lreplace $cmds end end]
516 ## Console:prompt - displays the prompt in the console widget
517 # ARGS: w - console text widget
518 # Outputs: prompt (specified in data(-prompt)) to console
520 ;proc Console:prompt {W {pre {}} {post {}} {prompt {}}} {
524 if {[string compare {} $pre]} { $w insert end $pre stdout }
525 set i [$w index end-1c]
526 if {[string compare {} $data(appname)]} {
527 $w insert end ">$data(appname)< " prompt
529 if {[string compare {} $prompt]} {
530 $w insert end $prompt prompt
532 $w insert end [ConsoleEvalSlave subst $data(-prompt)] prompt
534 $w mark set output $i
535 $w mark set insert end
536 $w mark set limit insert
537 $w mark gravity limit left
538 if {[string compare {} $post]} { $w insert end $post stdin }
542 ## ConsoleAbout - gives about info for Console
544 ;proc ConsoleAbout W {
548 if {[winfo exists $w]} {
551 global tk_patchLevel tcl_patchLevel tcl_platform
553 wm title $w "About Console v$Console(version)"
554 button $w.b -text Dismiss -command [list wm withdraw $w]
555 text $w.text -height 9 -bd 1 -width 60
556 pack $w.b -fill x -side bottom
557 pack $w.text -fill both -side left -expand 1
558 $w.text tag config center -justify center
560 if {[string compare unix $tcl_platform(platform)] || \
561 [info tclversion] >= 8} {
562 $w.text tag config title -justify center -font {Courier 18 bold}
564 $w.text tag config title -justify center -font *Courier*Bold*18*
566 $w.text insert 1.0 "About Console v$Console(version)" title \
567 "\n\nCopyright 1995-1997 Jeffrey Hobbs, $Console(contact)\
568 \nhttp://www.cs.uoregon.edu/~jhobbs/\
569 \nRelease Date: v$Console(version), $Console(release)\
570 \nDocumentation available at:\n$Console(docs)\
571 \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
575 ## ConsoleInitMenus - inits the menubar and popup for the console
576 # ARGS: W - console megawidget
578 ;proc ConsoleInitMenus W {
582 set text $data(console)
584 if {[catch {menu $w.pop -tearoff 0}]} {
585 label $w.label -text "Menus not available in plugin mode"
589 bind [winfo toplevel $w] <Button-3> "tk_popup $w.pop %X %Y"
590 bind $text <Button-3> "tk_popup $w.pop %X %Y"
593 ## FIX - get the attachment stuff working
596 pack [menubutton $w.$n -text $l -un 0 -menu $w.$n.m] -side left
597 $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
598 foreach m [list [menu $w.$n.m -disabledfore $data(-promptcolor)] \
599 [menu $w.pop.$n -disabledfore $data(-promptcolor)]] {
600 $m add command -label "Console $W" -state disabled
601 $m add command -label "Clear Console " -un 1 \
602 -acc [event info <<Console_Clear>>] \
603 -com [list Console_clear $W]
604 $m add command -label "Load File" -und 0 \
605 -command [list Console_load $W]
606 $m add cascade -label "Save ..." -und 0 -menu $m.save
608 $m add cascade -label "Attach Console" -und 7 -menu $m.apps \
610 $m add cascade -label "Attach Namespace" -und 7 -menu $m.name \
613 $m add command -label "Exit" -un 1 -acc [event info <<Console_Exit>>] \
614 -command [list Console:exit $W]
619 menu $s -disabledforeground $data(-promptcolor) -tearoff 0
620 $s add command -label "All" -und 0 \
621 -command [list Console_save $W all]
622 $s add command -label "History" -und 0 \
623 -command [list Console_save $W history]
624 $s add command -label "Stdin" -und 3 \
625 -command [list Console_save $W stdin]
626 $s add command -label "Stdout" -und 3 \
627 -command [list Console_save $W stdout]
628 $s add command -label "Stderr" -und 3 \
629 -command [list Console_save $W stderr]
631 ## Attach Console Menu
633 menu $m.apps -disabledforeground $data(-promptcolor) \
634 -postcommand [list ConsoleAttachMenu $m.apps]
636 ## Attach Interpreter Menu
638 menu $m.int -disabledforeground $data(-promptcolor) -tearoff 0 \
639 -postcommand [list ConsoleAttachMenu $m.int interp]
641 ## Attach Namespace Menu
643 menu $m.name -disabledforeground $data(-promptcolor) -tearoff 0 \
644 -postcommand [list ConsoleAttachMenu $m.name namespace]
651 pack [menubutton $w.$n -text $l -un 0 -menu $w.$n.m] -side left
652 $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
653 foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
654 $m add command -label "Cut" -un 1 \
655 -acc [lindex [event info <<Cut>>] 0] \
656 -command [list ConsoleCut $text]
657 $m add command -label "Copy" -un 1 \
658 -acc [lindex [event info <<Copy>>] 0] \
659 -command [list ConsoleCopy $text]
660 $m add command -label "Paste" -un 0 \
661 -acc [lindex [event info <<Paste>>] 0] \
662 -command [list ConsolePaste $text]
664 $m add command -label "Find" -un 0 \
665 -acc [lindex [event info <<Console_Find>>] 0] \
666 -command [list ConsoleFindBox $W]
668 $m add command -label "Last Error" -un 0 -command [list $W error]
675 pack [menubutton $w.$n -text $l -un 0 -menu $w.$n.m] -side left
676 $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
677 foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
678 $m add checkbutton -label "Brace Highlighting" -var $W\(-lightbrace\)
679 $m add checkbutton -label "Command Highlighting" -var $W\(-lightcmd\)
680 $m add checkbutton -label "Grab Puts Output" -var $W\(-grabputs\) \
681 -command "Console:configure $W \
682 -grabputs \[set ${W}(-grabputs)\]"
683 $m add checkbutton -label "History Substitution" -var $W\(-subhistory\)
684 $m add checkbutton -label "Show Multiple Matches" \
685 -var $W\(-showmultiple\)
686 $m add checkbutton -label "Show Menubar" -var $W\(-showmenu\) \
687 -command "Console:configure $W \
688 -showmenu \[set ${W}(-showmenu)\]"
695 pack [menubutton $w.$n -text $l -un 0 -menu $w.$n.m] -side left
696 $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
697 foreach m [list $w.$n.m $w.pop.$n] {
698 menu $m -disabledfore $data(-promptcolor) \
699 -postcommand [list ConsoleHistoryMenu $W $m]
706 pack [menubutton $w.$n -text $l -un 0 -menu $w.$n.m] -side right
707 $w.pop add cascade -label $l -un 0 -menu $w.pop.$n
708 foreach m [list [menu $w.$n.m] [menu $w.pop.$n]] {
709 $m config -disabledfore $data(-promptcolor)
710 $m add command -label "About " -un 0 \
711 -acc [event info <<Console_About>>] \
712 -command [list ConsoleAbout $W]
715 bind $W <<Console_Exit>> [list Console:exit $W]
716 bind $W <<Console_About>> [list ConsoleAbout $W]
717 bind $W <<Console_Help>> [list ConsoleHelp $W]
718 bind $W <<Console_Find>> [list ConsoleFindBox $W]
720 ## Menu items need null PostConsole bindings to avoid the TagProc
722 foreach ev [bind $W] {
723 bind PostConsole $ev {
729 ## ConsoleHistoryMenu - dynamically build the menu for attached interpreters
731 # ARGS: w - menu widget
733 ;proc ConsoleHistoryMenu {W w} {
736 if {![winfo exists $w]} return
737 set id [ConsoleEvalSlave history nextid]
738 if {$data(histid)==$id} return
741 set con $data(console)
742 while {($id>$data(histid)-10) && \
743 ![catch {ConsoleEvalSlave history event [incr id -1]} tmp]} {
744 set lbl [lindex [split $tmp "\n"] 0]
745 if {[string len $lbl]>32} { set lbl [string range $tmp 0 30]... }
746 $w add command -label "$id: $lbl" -command "
747 $con delete limit end
748 $con insert limit [list $tmp]
755 ## ConsoleFindBox - creates minimal dialog interface to ConsoleFind
756 # ARGS: w - text widget
757 # str - optional seed string for data(find)
759 ;proc ConsoleFindBox {W {str {}}} {
764 if {![winfo exists $base]} {
767 wm title $base "Console Find"
769 pack [frame $base.f] -fill x -expand 1
770 label $base.f.l -text "Find:"
771 entry $base.f.e -textvar $W\(find\)
772 pack [frame $base.opt] -fill x
773 checkbutton $base.opt.c -text "Case Sensitive" -var $W\(find,case\)
774 checkbutton $base.opt.r -text "Use Regexp" -var $W\(find,reg\)
775 pack $base.f.l -side left
776 pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
777 pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
778 pack [frame $base.btn] -fill both
779 button $base.btn.fnd -text "Find" -width 6
780 button $base.btn.clr -text "Clear" -width 6
781 button $base.btn.dis -text "Dismiss" -width 6
782 eval pack [winfo children $base.btn] -padx 4 -pady 2 \
783 -side left -fill both
787 bind $base.f.e <Return> [list $base.btn.fnd invoke]
788 bind $base.f.e <Escape> [list $base.btn.dis invoke]
790 $base.btn.fnd config -command "Console_find $W \$data(find) \
791 -case \$data(find,case) -reg \$data(find,reg)"
792 $base.btn.clr config -command "
793 $t tag remove find 1.0 end
796 $base.btn.dis config -command "
797 $t tag remove find 1.0 end
800 if {[string compare {} $str]} {
805 if {[string compare normal [wm state $base]]} {
807 } else { raise $base }
808 $base.f.e select range 0 end
811 ## Console_find - searches in text widget for $str and highlights it
812 ## If $str is empty, it just deletes any highlighting
813 # ARGS: W - console widget
814 # str - string to search for
815 # -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0
816 # -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0
818 ;proc ConsoleFind {W str args} {
821 $t tag remove find 1.0 end
822 set truth {^(1|yes|true|on)$}
824 foreach {key val} $args {
825 switch -glob -- $key {
826 -c* { if {[regexp -nocase $truth $val]} { set case 1 } }
827 -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } }
828 default { return -code error "Unknown option $key" }
831 if {![info exists case]} { lappend opts -nocase }
832 if {[string match {} $str]} return
833 $t mark set findmark 1.0
834 while {[string compare {} [set ix [eval $t search $opts -count numc -- \
835 [list $str] findmark end]]]} {
836 $t tag add find $ix ${ix}+${numc}c
837 $t mark set findmark ${ix}+1c
839 catch {$t see find.first}
840 return [expr [llength [$t tag ranges find]]/2]
843 ## Console:savecommand - saves a command in a buffer for later retrieval
846 ;proc Console:savecommand {w} {
847 upvar \#0 [winfo parent $w] data
849 set tmp $data(cmdsave)
850 set data(cmdsave) [ConsoleCmdGet $w]
851 if {[string match {} $data(cmdsave)]} {
852 set data(cmdsave) $tmp
854 $w delete limit end-1c
860 ## Console_load - sources a file into the console
861 # ARGS: fn - (optional) filename to source in
862 # Returns: selected filename ({} if nothing was selected)
864 ;proc Console_load {W {fn ""}} {
866 {{Tcl Files} {.tcl .tk}}
867 {{Text Files} {.txt}}
871 [string match {} $fn] &&
872 ([catch {tk_getOpenFile -filetypes $types \
873 -title "Source File"} fn] || [string match {} $fn])
875 ConsoleEvalAttached [list source $fn]
878 ## Console_save - saves the console buffer to a file
879 ## This does not eval in a slave because it's not necessary
880 # ARGS: w - console text widget
881 # fn - (optional) filename to save to
883 ;proc Console_save {W {fn ""} {type ""}} {
887 if {![regexp -nocase {^(all|history|stdin|stdout|stderr)$} $type]} {
888 array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel }
889 ## Allow user to specify what kind of stuff to save
890 set type [tk_dialog $W.savetype "Save Type" \
891 "What part of the console text do you want to save?" \
892 questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)]
893 if {$type == 5 || $type == -1} return
896 if {[string match {} $fn]} {
898 {{Text Files} {.txt}}
899 {{Tcl Files} {.tcl .tk}}
902 if {[catch {tk_getSaveFile -filetypes $types -title "Save $type"} fn] \
903 || [string match {} $fn]} return
905 set type [string tolower $type]
907 stdin - stdout - stderr {
909 foreach {first last} [$c tag ranges $type] {
910 lappend data [$c get $first $last]
912 set data [join $data \n]
914 history { set data [Console_history $W] }
915 all - default { set data [$c get 1.0 end-1c] }
917 if {[catch {open $fn w} fid]} {
918 return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
924 ## clear - clears the buffer of the console (not the history though)
926 ;proc Console_clear {W {pcnt 100}} {
929 set data(tmp) [ConsoleCmdGet $data(console)]
930 if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
932 "invalid percentage to clear: must be 1-100 (100 default)"
933 } elseif {$pcnt == 100} {
934 $data(console) delete 1.0 end
936 set tmp [expr $pcnt/100.0*[$data(console) index end]]
937 $data(console) delete 1.0 "$tmp linestart"
939 Console:prompt $W {} $data(tmp)
942 ;proc Console_error {W} {
943 ## Outputs stack caused by last error.
945 set info $data(errorInfo)
946 if {[string match {} $info]} { set info {errorInfo empty} }
947 catch {destroy $W.error}
948 set w [toplevel $W.error]
949 wm title $w "Console Last Error"
950 button $w.close -text Dismiss -command [list destroy $w]
951 scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
952 text $w.text -yscrollcommand [list $w.sy set]
953 pack $w.close -side bottom -fill x
954 pack $w.sy -side right -fill y
955 pack $w.text -fill both -expand 1
956 $w.text insert 1.0 $info
957 $w.text config -state disabled
960 ## Console_event - searches for history based on a string
961 ## Search forward (next) if $int>0, otherwise search back (prev)
962 # ARGS: W - console widget
964 ;proc Console_event {W int {str {}}} {
970 set nextid [ConsoleEvalSlave history nextid]
971 if {[string compare {} $str]} {
972 ## String is not empty, do an event search
973 set event $data(event)
974 if {$int < 0 && $event == $nextid} { set data(cmdbuf) $str }
975 set len [string len $data(cmdbuf)]
978 ## Search history forward
979 while {$event < $nextid} {
980 if {[incr event] == $nextid} {
982 $w insert limit $data(cmdbuf)
984 } elseif {![catch {ConsoleEvalSlave history event $event} res]\
985 && ![string compare $data(cmdbuf) \
986 [string range $res 0 $len]]} {
992 set data(event) $event
994 ## Search history reverse
995 while {![catch {ConsoleEvalSlave \
996 history event [incr event -1]} res]} {
997 if {![string compare $data(cmdbuf) \
998 [string range $res 0 $len]]} {
1000 $w insert limit $res
1001 set data(event) $event
1007 ## String is empty, just get next/prev event
1009 ## Goto next command in history
1010 if {$data(event) < $nextid} {
1012 if {[incr data(event)] == $nextid} {
1013 $w insert limit $data(cmdbuf)
1015 $w insert limit [ConsoleEvalSlave \
1016 history event $data(event)]
1020 ## Goto previous command in history
1021 if {$data(event) == $nextid} {set data(cmdbuf) [ConsoleCmdGet $w]}
1022 if {[catch {ConsoleEvalSlave \
1023 history event [incr data(event) -1]} res]} {
1027 $w insert limit $res
1031 $w mark set insert end
1035 ;proc Console_history {W args} {
1037 if {[string match -n* $args]} { append sub "\n" }
1038 set h [ConsoleEvalSlave history]
1039 regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h
1044 ## Some procedures to make up for lack of built-in shell commands
1048 ## This allows me to capture all stdout/stderr to the console window
1049 # ARGS: same as usual
1050 # Outputs: the string with a color-coded text tag
1052 if {![catch {rename puts console_tcl_puts}]} {
1055 set w [lindex $Console(active) 0]
1056 if {[winfo exists $w]} {
1057 set len [llength $args]
1059 eval $w insert output $args stdout {\n} stdout
1061 } elseif {$len==2 && [regexp {(stdout|stderr|-nonewline)} \
1062 [lindex $args 0] junk tmp]} {
1063 if {[string compare $tmp -nonewline]} {
1064 eval $w insert output [lreplace $args 0 0] $tmp {\n} $tmp
1066 eval $w insert output [lreplace $args 0 0] stdout
1069 } elseif {$len==3 && \
1070 [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} {
1071 if {[string compare [lreplace $args 1 2] -nonewline]} {
1072 eval $w insert output [lrange $args 1 1] $tmp
1074 eval $w insert output [lreplace $args 0 1] $tmp
1078 global errorCode errorInfo
1079 if {[catch "console_tcl_puts $args" msg]} {
1080 regsub console_tcl_puts $msg puts msg
1081 regsub -all console_tcl_puts \
1082 $errorInfo puts errorInfo
1089 global errorCode errorInfo
1090 if {[catch "console_tcl_puts $args" msg]} {
1091 regsub console_tcl_puts $msg puts msg
1092 regsub -all console_tcl_puts $errorInfo puts errorInfo
1101 ## Relaxes the one string restriction of 'puts'
1102 # ARGS: any number of strings to output to stdout
1104 proc echo args { puts [concat $args] }
1106 ## alias - akin to the csh alias command
1107 ## If called with no args, then it dumps out all current aliases
1108 ## If called with one arg, returns the alias of that arg (or {} if none)
1109 # ARGS: newcmd - (optional) command to bind alias to
1110 # args - command and args being aliased
1112 proc alias {{newcmd {}} args} {
1113 if {[string match {} $newcmd]} {
1115 foreach a [interp aliases] {
1116 lappend res [list $a -> [interp alias {} $a]]
1118 return [join $res \n]
1119 } elseif {[string match {} $args]} {
1120 interp alias {} $newcmd
1122 eval interp alias [list {} $newcmd {}] $args
1126 ## dump - outputs variables/procedure/widget info in source'able form.
1127 ## Accepts glob style pattern matching for the names
1128 # ARGS: type - type of thing to dump: must be variable, procedure, widget
1130 # don't complain if no vars match something
1132 # specifies a glob filter pattern to be used by the variable
1133 # method as an array filter pattern (it filters down for
1134 # nested elements) and in the widget method as a config
1135 # option filter pattern
1136 # -- forcibly ends options recognition
1137 # Returns: the values of the requested items in a 'source'able form
1139 proc dump {type args} {
1142 if {[string match {} $args]} {
1143 ## If no args, assume they gave us something to dump and
1144 ## we'll try anything
1145 set args [list $type]
1148 while {[string match -* $args]} {
1149 switch -glob -- [lindex $args 0] {
1150 -n* { set whine 0; set args [lreplace $args 0 0] }
1151 -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] }
1152 -- { set args [lreplace $args 0 0]; break }
1153 default {return -code error "unknown option \"[lindex $args 0]\""}
1156 if {$whine && [string match {} $args]} {
1157 return -code error "wrong \# args: [lindex [info level 0] 0] type\
1158 ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?"
1161 switch -glob -- $type {
1164 # outpus commands by figuring out, as well as possible, what it is
1165 # this does not attempt to auto-load anything
1167 if {[string compare {} [set cmds [info comm $arg]]]} {
1168 foreach cmd [lsort $cmds] {
1169 if {[lsearch -exact [interp aliases] $cmd] > -1} {
1170 append res "\#\# ALIAS: $cmd =>\
1171 [interp alias {} $cmd]\n"
1172 } elseif {[string compare {} [info procs $cmd]]} {
1173 if {[catch {uplevel dump p -- $cmd} msg] \
1174 && $whine} { set code error }
1177 append res "\#\# COMMAND: $cmd\n"
1181 append res "\#\# No known command $arg\n"
1188 # outputs variables value(s), whether array or simple.
1189 if {![info exists fltr]} { set fltr * }
1191 if {[string match {} \
1192 [set vars [uplevel info vars [list $arg]]]]} {
1193 if {[uplevel info exists $arg]} {
1196 append res "\#\# No known variable $arg\n"
1201 foreach var [lsort $vars] {
1203 if {[array exists v]} {
1205 append res "array set $var \{\n"
1206 foreach i [lsort [array names v $fltr]] {
1207 upvar 0 v\($i\) __ary
1208 if {[array exists __ary]} {
1209 append nest "\#\# NESTED ARRAY ELEMENT: $i\n"
1210 append nest "upvar 0 [list $var\($i\)] __ary;\
1211 [dump v -filter $fltr __ary]\n"
1213 append res " [list $i]\t[list $v($i)]\n"
1216 append res "\}\n$nest"
1218 append res [list set $var $v]\n
1226 if {[string compare {} [set ps [info proc $arg]]] ||
1227 ([auto_load $arg] &&
1228 [string compare {} [set ps [info proc $arg]]])} {
1229 foreach p [lsort $ps] {
1231 foreach a [info args $p] {
1232 if {[info default $p $a tmp]} {
1233 lappend as [list $a $tmp]
1238 append res [list proc $p $as [info body $p]]\n
1241 append res "\#\# No known proc $arg\n"
1248 ## The user should have Tk loaded
1249 if {[string match {} [info command winfo]]} {
1250 return -code error "winfo not present, cannot dump widgets"
1252 if {![info exists fltr]} { set fltr .* }
1254 if {[string compare {} [set ws [info command $arg]]]} {
1255 foreach w [lsort $ws] {
1256 if {[winfo exists $w]} {
1257 if {[catch {$w configure} cfg]} {
1258 append res "\#\# Widget $w\
1259 does not support configure method"
1262 append res "\#\# [winfo class $w]\
1265 if {[llength $c] != 5} continue
1266 if {[regexp -nocase -- $fltr $c]} {
1267 append res " \\\n\t[list [lindex $c 0]\
1276 append res "\#\# No known widget $arg\n"
1282 ## any - try to dump as var, then command, then widget...
1284 [catch {uplevel dump v -- $args} res] &&
1285 [catch {uplevel dump c -- $args} res] &&
1286 [catch {uplevel dump w -- $args} res]
1288 set res "dump was unable to resolve type for \"$args\""
1293 return -code error "bad [lindex [info level 0] 0] option\
1294 \"$type\": must be command, procedure, variable, widget"
1297 return -code $code [string trimr $res \n]
1300 ## which - tells you where a command is found
1301 # ARGS: cmd - command name
1302 # Returns: where command is found (internal / external / unknown)
1305 if {[string compare {} [info commands $cmd]] || \
1306 ([auto_load $cmd] && [string compare {} [info commands $cmd]])} {
1307 if {[lsearch -exact [interp aliases] $cmd] > -1} {
1308 set result "$cmd: aliased to [alias $cmd]"
1309 } elseif {[string compare {} [info procs $cmd]]} {
1310 set result "$cmd: procedure"
1312 set result "$cmd: command"
1315 if {[info exists auto_index($cmd)]} {
1316 ## This tells you where the command MIGHT have come from -
1317 ## not true if the command was redefined interactively or
1318 ## existed before it had to be auto_loaded. This is just
1319 ## provided as a hint at where it MAY have come from
1320 append result " ($auto_index($cmd))"
1323 } elseif {[string compare {} [auto_execok $cmd]]} {
1324 return [auto_execok $cmd]
1326 return -code error "$cmd: command not found"
1330 ## dir - directory list
1331 # ARGS: args - names/glob patterns of directories to list
1332 # OPTS: -all - list hidden files as well (Unix dot files)
1333 # -long - list in full format "permissions size date filename"
1334 # -full - displays / after directories and link paths for links
1335 # Returns: a directory listing
1340 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
1342 while {[string match \-* [lindex $args 0]]} {
1343 set str [lindex $args 0]
1344 set args [lreplace $args 0 0]
1345 switch -glob -- $str {
1346 -a* {set s(all) 1} -f* {set s(full) 1}
1347 -l* {set s(long) 1} -- break
1349 return -code error "unknown option \"$str\",\
1350 should be one of: -all, -full, -long"
1354 set sep [string trim [file join . .] .]
1355 if {[string match {} $args]} { set args . }
1357 if {[file isdir $arg]} {
1358 set arg [string trimr $arg $sep]$sep
1360 lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]]
1362 lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]]
1365 lappend out [list [file dirname $arg]$sep \
1366 [lsort [glob -nocomplain -- $arg]]]
1370 set old [clock scan {1 year ago}]
1371 set fmt "%s%9d %s %s\n"
1375 foreach f [lindex $o 1] {
1377 set f [file tail $f]
1379 switch -glob $st(type) {
1380 d* { append f $sep }
1381 l* { append f "@ -> [file readlink $d$sep$f]" }
1382 default { if {[file exec $d$sep$f]} { append f * } }
1385 if {[string match file $st(type)]} {
1388 set mode [string index $st(type) 0]
1390 foreach j [split [format %o [expr $st(mode)&0777]] {}] {
1393 if {$st(mtime)>$old} {
1394 set cfmt {%b %d %H:%M}
1398 append res [format $fmt $mode $st(size) \
1399 [clock format $st(mtime) -format $cfmt] $f]
1408 foreach f [lindex $o 1] {
1409 if {[string len [file tail $f]] > $i} {
1410 set i [string len [file tail $f]]
1413 set i [expr {$i+2+$s(full)}]
1414 ## This gets the number of cols in the Console console widget
1415 set j [expr {66/$i}]
1417 foreach f [lindex $o 1] {
1418 set f [file tail $f]
1420 switch -glob [file type $d$sep$f] {
1421 d* { append f $sep }
1423 default { if {[file exec $d$sep$f]} { append f * } }
1426 append res [format "%-${i}s" $f]
1427 if {[incr k]%$j == 0} {set res [string trimr $res]\n}
1432 return [string trimr $res]
1434 interp alias {} ls {} dir -full
1436 ## lremove - remove items from a list
1437 # OPTS: -all remove all instances of each item
1438 # ARGS: l a list to remove items from
1439 # args items to remove
1441 proc lremove {args} {
1443 if {[string match \-a* [lindex $args 0]]} {
1445 set args [lreplace $args 0 0]
1447 set l [lindex $args 0]
1448 foreach i [join [lreplace $args 0 0]] {
1449 if {[set ix [lsearch -exact $l $i]] == -1} continue
1450 set l [lreplace $l $ix $ix]
1452 while {[set ix [lsearch -exact $l $i]] != -1} {
1453 set l [lreplace $l $ix $ix]
1461 ## Unknown changed to get output into Console window
1463 # Invoked automatically whenever an unknown command is encountered.
1464 # Works through a list of "unknown handlers" that have been registered
1465 # to deal with unknown commands. Extensions can integrate their own
1466 # handlers into the "unknown" facility via "unknown_handle".
1468 # If a handler exists that recognizes the command, then it will
1469 # take care of the command action and return a valid result or a
1470 # Tcl error. Otherwise, it should return "-code continue" (=2)
1471 # and responsibility for the command is passed to the next handler.
1474 # args - A list whose elements are the words of the original
1475 # command, including the command name.
1478 global unknown_handler_order unknown_handlers errorInfo errorCode
1481 # Be careful to save error info now, and restore it later
1482 # for each handler. Some handlers generate their own errors
1483 # and disrupt handling.
1485 set savedErrorCode $errorCode
1486 set savedErrorInfo $errorInfo
1488 if {![info exists unknown_handler_order] || \
1489 ![info exists unknown_handlers]} {
1490 set unknown_handlers(tcl) tcl_unknown
1491 set unknown_handler_order tcl
1494 foreach handler $unknown_handler_order {
1495 set status [catch {uplevel $unknown_handlers($handler) $args} result]
1499 # Strip the last five lines off the error stack (they're
1500 # from the "uplevel" command).
1502 set new [split $errorInfo \n]
1503 set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
1504 return -code $status -errorcode $errorCode \
1505 -errorinfo $new $result
1507 } elseif {$status != 4} {
1508 return -code $status $result
1511 set errorCode $savedErrorCode
1512 set errorInfo $savedErrorInfo
1515 set name [lindex $args 0]
1516 return -code error "invalid command name \"$name\""
1520 # Invoked when a Tcl command is invoked that doesn't exist in the
1523 # 1. See if the autoload facility can locate the command in a
1524 # Tcl script file. If so, load it and execute it.
1525 # 2. If the command was invoked interactively at top-level:
1526 # (a) see if the command exists as an executable UNIX program.
1527 # If so, "exec" the command.
1528 # (b) see if the command requests csh-like history substitution
1529 # in one of the common forms !!, !<number>, or ^old^new. If
1530 # so, emulate csh's history substitution.
1531 # (c) see if the command is a unique abbreviation for another
1532 # command. If so, invoke the command.
1535 # args - A list whose elements are the words of the original
1536 # command, including the command name.
1538 proc tcl_unknown args {
1539 global auto_noexec auto_noload env unknown_pending tcl_interactive Console
1540 global errorCode errorInfo
1542 # Save the values of errorCode and errorInfo variables, since they
1543 # may get modified if caught errors occur below. The variables will
1544 # be restored just before re-executing the missing command.
1546 set savedErrorCode $errorCode
1547 set savedErrorInfo $errorInfo
1548 set name [lindex $args 0]
1549 if {![info exists auto_noload]} {
1551 # Make sure we're not trying to load the same proc twice.
1553 if {[info exists unknown_pending($name)]} {
1554 return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
1556 set unknown_pending($name) pending;
1557 set ret [catch {auto_load $name} msg]
1558 unset unknown_pending($name);
1560 return -code $ret -errorcode $errorCode \
1561 "error while autoloading \"$name\": $msg"
1563 if {![array size unknown_pending]} {
1564 unset unknown_pending
1567 set errorCode $savedErrorCode
1568 set errorInfo $savedErrorInfo
1569 set code [catch {uplevel 1 $args} msg]
1572 # Strip the last five lines off the error stack (they're
1573 # from the "uplevel" command).
1576 set new [split $errorInfo \n]
1577 set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
1578 return -code error -errorcode $errorCode \
1579 -errorinfo $new $msg
1581 return -code $code $msg
1585 if {[info level] == 1 && [string match {} [info script]] \
1586 && [info exists tcl_interactive] && $tcl_interactive} {
1587 if {![info exists auto_noexec]} {
1588 set new [auto_execok $name]
1589 if {[string compare $new ""]} {
1590 set errorCode $savedErrorCode
1591 set errorInfo $savedErrorInfo
1592 return [uplevel exec [list $new] [lrange $args 1 end]]
1593 #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]]
1596 set errorCode $savedErrorCode
1597 set errorInfo $savedErrorInfo
1599 ## History substitution moved into ConsoleEvalCmd
1601 set ret [catch {set cmds [info commands $name*]} msg]
1602 if {![string compare $name "::"]} {
1606 return -code $ret -errorcode $errorCode \
1607 "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
1609 if {[llength $cmds] == 1} {
1610 return [uplevel [lreplace $args 0 0 $cmds]]
1612 if {[llength $cmds]} {
1614 return -code error "empty command name \"\""
1616 return -code error \
1617 "ambiguous command name \"$name\": [lsort $cmds]"
1621 return -code continue
1624 switch -glob $tcl_platform(platform) {
1625 win* { set META Alt }
1626 mac* { set META Command }
1627 default { set META Meta }
1630 # ConsoleClipboardKeysyms --
1631 # This procedure is invoked to identify the keys that correspond to
1632 # the "copy", "cut", and "paste" functions for the clipboard.
1635 # copy - Name of the key (keysym name plus modifiers, if any,
1636 # such as "Meta-y") used for the copy operation.
1637 # cut - Name of the key used for the cut operation.
1638 # paste - Name of the key used for the paste operation.
1640 ;proc ConsoleClipboardKeysyms {copy cut paste} {
1641 bind Console <$copy> {ConsoleCopy %W}
1642 bind Console <$cut> {ConsoleCut %W}
1643 bind Console <$paste> {ConsolePaste %W}
1646 ;proc ConsoleCut w {
1647 if {[string match $w [selection own -displayof $w]]} {
1648 clipboard clear -displayof $w
1650 clipboard append -displayof $w [selection get -displayof $w]
1651 if {[$w compare sel.first >= limit]} {$w delete sel.first sel.last}
1655 ;proc ConsoleCopy w {
1656 if {[string match $w [selection own -displayof $w]]} {
1657 clipboard clear -displayof $w
1658 catch {clipboard append -displayof $w [selection get -displayof $w]}
1662 ;proc ConsolePaste w {
1664 ![catch {selection get -displayof $w} tmp] ||
1665 ![catch {selection get -displayof $w -type TEXT} tmp] ||
1666 ![catch {selection get -displayof $w -selection CLIPBOARD} tmp]
1668 if {[$w compare insert < limit]} {$w mark set insert end}
1669 $w insert insert $tmp
1671 if {[string match *\n* $tmp]} {ConsoleEval $w}
1675 ## Get all Text bindings into Console
1676 foreach ev [bind Text] { bind Console $ev [bind Text $ev] }
1677 ## We don't want newline insertion
1678 bind Console <Control-Key-o> {}
1681 <<Console_Previous>> <Key-Up>
1682 <<Console_Next>> <Key-Down>
1683 <<Console_NextImmediate>> <Control-Key-n>
1684 <<Console_PreviousImmediate>> <Control-Key-p>
1685 <<Console_PreviousSearch>> <Control-Key-r>
1686 <<Console_NextSearch>> <Control-Key-s>
1688 <<Console_Expand>> <Key-Tab>
1689 <<Console_ExpandFile>> <Key-Escape>
1690 <<Console_ExpandProc>> <Control-Shift-Key-P>
1691 <<Console_ExpandVar>> <Control-Shift-Key-V>
1692 <<Console_Tab>> <Control-Key-i>
1693 <<Console_Tab>> <Meta-Key-i>
1694 <<Console_Eval>> <Key-Return>
1695 <<Console_Eval>> <Key-KP_Enter>
1697 <<Console_Clear>> <Control-Key-l>
1698 <<Console_KillLine>> <Control-Key-k>
1699 <<Console_Transpose>> <Control-Key-t>
1700 <<Console_ClearLine>> <Control-Key-u>
1701 <<Console_SaveCommand>> <Control-Key-z>
1703 <<Console_Exit>> <Control-Key-q>
1704 <<Console_New>> <Control-Key-N>
1705 <<Console_Close>> <Control-Key-w>
1706 <<Console_About>> <Control-Key-A>
1707 <<Console_Help>> <Control-Key-H>
1708 <<Console_Find>> <Control-Key-F>
1711 bind Console $key {}
1713 catch {unset ev key}
1715 ## Redefine for Console what we need
1717 event delete <<Paste>> <Control-V>
1718 ConsoleClipboardKeysyms <Copy> <Cut> <Paste>
1720 bind Console <Insert> {catch {ConsoleInsert %W [selection get -displayof %W]}}
1722 bind Console <Triple-1> {+
1724 eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
1725 %W mark set insert sel.first
1729 bind Console <<Console_Expand>> {
1730 if {[%W compare insert > limit]} {Console:expand %W}
1733 bind Console <<Console_ExpandFile>> {
1734 if {[%W compare insert > limit]} {Console:expand %W path}
1737 bind Console <<Console_ExpandProc>> {
1738 if {[%W compare insert > limit]} {Console:expand %W proc}
1741 bind Console <<Console_ExpandVar>> {
1742 if {[%W compare insert > limit]} {Console:expand %W var}
1745 bind Console <<Console_Tab>> {
1746 if {[%W compare insert >= limit]} {
1750 bind Console <<Console_Eval>> {
1753 bind Console <Delete> {
1754 if {[string compare {} [%W tag nextrange sel 1.0 end]] \
1755 && [%W compare sel.first >= limit]} {
1756 %W delete sel.first sel.last
1757 } elseif {[%W compare insert >= limit]} {
1762 bind Console <BackSpace> {
1763 if {[string compare {} [%W tag nextrange sel 1.0 end]] \
1764 && [%W compare sel.first >= limit]} {
1765 %W delete sel.first sel.last
1766 } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
1771 bind Console <Control-h> [bind Console <BackSpace>]
1773 bind Console <KeyPress> {
1777 bind Console <Control-a> {
1778 if {[%W compare {limit linestart} == {insert linestart}]} {
1779 tkTextSetCursor %W limit
1781 tkTextSetCursor %W {insert linestart}
1784 bind Console <Control-d> {
1785 if {[%W compare insert < limit]} break
1788 bind Console <<Console_KillLine>> {
1789 if {[%W compare insert < limit]} break
1790 if {[%W compare insert == {insert lineend}]} {
1793 %W delete insert {insert lineend}
1796 bind Console <<Console_Clear>> {
1797 Console_clear [winfo parent %W]
1799 bind Console <<Console_Previous>> {
1800 if {[%W compare {insert linestart} != {limit linestart}]} {
1801 tkTextSetCursor %W [tkTextUpDownLine %W -1]
1803 Console_event [winfo parent %W] -1
1806 bind Console <<Console_Next>> {
1807 if {[%W compare {insert linestart} != {end-1c linestart}]} {
1808 tkTextSetCursor %W [tkTextUpDownLine %W 1]
1810 Console_event [winfo parent %W] 1
1813 bind Console <<Console_NextImmediate>> {
1814 Console_event [winfo parent %W] 1
1816 bind Console <<Console_PreviousImmediate>> {
1817 Console_event [winfo parent %W] -1
1819 bind Console <<Console_PreviousSearch>> {
1820 Console_event [winfo parent %W] -1 [ConsoleCmdGet %W]
1822 bind Console <<Console_NextSearch>> {
1823 Console_event [winfo parent %W] 1 [ConsoleCmdGet %W]
1825 bind Console <<Console_Transpose>> {
1826 ## Transpose current and previous chars
1827 if {[%W compare insert > limit]} { tkTextTranspose %W }
1829 bind Console <<Console_ClearLine>> {
1830 ## Clear command line (Unix shell staple)
1833 bind Console <<Console_SaveCommand>> {
1834 ## Save command buffer (swaps with current command)
1835 Console:savecommand %W
1837 catch {bind Console <Key-Page_Up> { tkTextScrollPages %W -1 }}
1838 catch {bind Console <Key-Prior> { tkTextScrollPages %W -1 }}
1839 catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
1840 catch {bind Console <Key-Next> { tkTextScrollPages %W 1 }}
1841 bind Console <$META-d> {
1842 if {[%W compare insert >= limit]} {
1843 %W delete insert {insert wordend}
1846 bind Console <$META-BackSpace> {
1847 if {[%W compare {insert -1c wordstart} >= limit]} {
1848 %W delete {insert -1c wordstart} insert
1851 bind Console <$META-Delete> {
1852 if {[%W compare insert >= limit]} {
1853 %W delete insert {insert wordend}
1856 bind Console <ButtonRelease-2> {
1857 ## Try and get the default selection, then try and get the selection
1858 ## type TEXT, then try and get the clipboard if nothing else is available
1860 (!$tkPriv(mouseMoved) || $tk_strictMotif) &&
1861 (![catch {selection get -displayof %W} tkPriv(junk)] ||
1862 ![catch {selection get -displayof %W -type TEXT} tkPriv(junk)] ||
1863 ![catch {selection get -displayof %W \
1864 -selection CLIPBOARD} tkPriv(junk)])
1866 if {[%W compare @%x,%y < limit]} {
1867 %W insert end $tkPriv(junk)
1869 %W insert @%x,%y $tkPriv(junk)
1871 if {[string match *\n* $tkPriv(junk)]} {ConsoleEval %W}
1876 ## End Console bindings
1880 ## Bindings for doing special things based on certain keys
1882 bind PostConsole <Key-parenright> {
1883 if {[string compare \\ [%W get insert-2c]]} {ConsoleMatchPair %W \( \) limit}
1885 bind PostConsole <Key-bracketright> {
1886 if {[string compare \\ [%W get insert-2c]]} {ConsoleMatchPair %W \[ \] limit}
1888 bind PostConsole <Key-braceright> {
1889 if {[string compare \\ [%W get insert-2c]]} {ConsoleMatchPair %W \{ \} limit}
1891 bind PostConsole <Key-quotedbl> {
1892 if {[string compare \\ [%W get insert-2c]]} {ConsoleMatchQuote %W limit}
1895 bind PostConsole <KeyPress> {
1896 if {[string compare {} %A]} { ConsoleTagProc %W }
1900 ## ConsoleTagProc - tags a procedure in the console if it's recognized
1901 ## This procedure is not perfect. However, making it perfect wastes
1902 ## too much CPU time... Also it should check the existence of a command
1903 ## in whatever is the connected slave, not the master interpreter.
1905 ;proc ConsoleTagProc w {
1906 upvar \#0 [winfo parent $w] data
1907 if {!$data(-lightcmd)} return
1908 set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
1909 set i [$w search -backwards -regexp $exp insert-1c limit-1c]
1910 if {[string compare {} $i]} {append i +2c} {set i limit}
1911 regsub -all {[[\\\?\*]} [$w get $i "insert-1c wordend"] {\\\0} c
1912 if {[string compare {} [ConsoleEvalAttached info commands [list $c]]]} {
1913 $w tag add proc $i "insert-1c wordend"
1915 $w tag remove proc $i "insert-1c wordend"
1917 if {[string compare {} [ConsoleEvalAttached info vars [list $c]]]} {
1918 $w tag add var $i "insert-1c wordend"
1920 $w tag remove var $i "insert-1c wordend"
1924 ## ConsoleMatchPair - blinks a matching pair of characters
1925 ## c2 is assumed to be at the text index 'insert'.
1926 ## This proc is really loopy and took me an hour to figure out given
1927 ## all possible combinations with escaping except for escaped \'s.
1928 ## It doesn't take into account possible commenting... Oh well. If
1929 ## anyone has something better, I'd like to see/use it. This is really
1930 ## only efficient for small contexts.
1931 # ARGS: w - console text widget
1932 # c1 - first char of pair
1933 # c2 - second char of pair
1934 # Calls: Console:blink
1936 ;proc ConsoleMatchPair {w c1 c2 {lim 1.0}} {
1937 upvar \#0 [winfo parent $w] data
1938 if {!$data(-lightbrace) || $data(-blinktime)<100} return
1939 if {[string compare [set ix [$w search -back $c1 insert $lim]] {}]} {
1940 while {[string match {\\} [$w get $ix-1c]] && \
1941 [string compare [set ix [$w search -back $c1 $ix-1c $lim]] {}]} {}
1943 while {[string compare $ix {}]} {
1946 while {[string compare [set i0 [$w search $c2 $i0 $i1]] {}]} {
1948 if {[string match {\\} [$w get $i0-2c]]} continue
1953 while {$j && [string compare \
1954 [set ix [$w search -back $c1 $ix $lim]] {}]} {
1955 if {[string match {\\} [$w get $ix-1c]]} continue
1959 if {[string match {} $ix]} { set ix [$w index $lim] }
1960 } else { set ix [$w index $lim] }
1961 if {$data(-blinkrange)} {
1962 Console:blink $w $data(-blinktime) $ix [$w index insert]
1964 Console:blink $w $data(-blinktime) $ix $ix+1c \
1965 [$w index insert-1c] [$w index insert]
1969 ## ConsoleMatchQuote - blinks between matching quotes.
1970 ## Blinks just the quote if it's unmatched, otherwise blinks quoted string
1971 ## The quote to match is assumed to be at the text index 'insert'.
1972 # ARGS: w - console text widget
1973 # Calls: Console:blink
1975 ;proc ConsoleMatchQuote {w {lim 1.0}} {
1976 upvar \#0 [winfo parent $w] data
1977 if {!$data(-lightbrace) || $data(-blinktime)<100} return
1980 while {[string compare {} [set i [$w search -back \" $i $lim]]]} {
1981 if {[string match {\\} [$w get $i-1c]]} continue
1982 if {!$j} {set i0 $i}
1986 if {$data(-blinkrange)} {
1987 Console:blink $w $data(-blinktime) $i0 [$w index insert]
1989 Console:blink $w $data(-blinktime) $i0 $i0+1c \
1990 [$w index insert-1c] [$w index insert]
1993 Console:blink $w $data(-blinktime) [$w index insert-1c] \
1998 ## Console:blink - blinks between 2 indices for a specified duration.
1999 # ARGS: w - console text widget
2000 # delay - millisecs to blink for
2001 # args - indices of regions to blink
2002 # Outputs: blinks selected characters in $w
2004 ;proc Console:blink {w delay args} {
2005 eval $w tag add blink $args
2006 after $delay eval $w tag remove blink $args
2012 ## Insert a string into a text console at the point of the insertion cursor.
2013 ## If there is a selection in the text, and it covers the point of the
2014 ## insertion cursor, then delete the selection before inserting.
2015 # ARGS: w - text window in which to insert the string
2016 # s - string to insert (usually just a single char)
2017 # Outputs: $s to text widget
2019 ;proc ConsoleInsert {w s} {
2020 if {[string match {} $s] || [string match disabled [$w cget -state]]} {
2023 if {[$w comp insert < limit]} {
2024 $w mark set insert end
2027 if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} {
2028 $w delete sel.first sel.last
2036 # ARGS: w - text widget in which to expand str
2037 # type - type of expansion (path / proc / variable)
2038 # Calls: ConsoleExpand(Pathname|Procname|Variable)
2039 # Outputs: The string to match is expanded to the longest possible match.
2040 # If data(-showmultiple) is non-zero and the user longest match
2041 # equaled the string to expand, then all possible matches are
2042 # output to stdout. Triggers bell if no matches are found.
2043 # Returns: number of matches found
2045 ;proc Console:expand {w {type ""}} {
2046 set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
2047 set tmp [$w search -backwards -regexp $exp insert-1c limit-1c]
2048 if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit}
2049 if {[$w compare $tmp >= insert]} return
2050 set str [$w get $tmp insert]
2051 switch -glob $type {
2052 pa* { set res [ConsoleExpandPathname $str] }
2053 pr* { set res [ConsoleExpandProcname $str] }
2054 v* { set res [ConsoleExpandVariable $str] }
2057 foreach t {Pathname Procname Variable} {
2058 if {[string compare {} [set res [ConsoleExpand$t $str]]]} break
2062 set len [llength $res]
2064 $w delete $tmp insert
2065 $w insert $tmp [lindex $res 0]
2067 upvar \#0 [winfo parent $w] data
2068 if {$data(-showmultiple) && \
2069 ![string compare [lindex $res 0] $str]} {
2070 puts stdout [lreplace $res 0 0]
2074 return [incr len -1]
2077 ## ConsoleExpandPathname - expand a file pathname based on $str
2078 ## This is based on UNIX file name conventions
2079 # ARGS: str - partial file pathname to expand
2080 # Calls: ConsoleExpandBestMatch
2081 # Returns: list containing longest unique match followed by all the
2082 # possible further matches
2084 ;proc ConsoleExpandPathname str {
2085 set pwd [ConsoleEvalAttached pwd]
2086 if {[catch {ConsoleEvalAttached [list cd [file dirname $str]]} err]} {
2087 return -code error $err
2089 if {[catch {lsort [ConsoleEvalAttached \
2090 [list glob [file tail $str]*]]} m]} {
2093 if {[llength $m] > 1} {
2095 if {[string match windows $tcl_platform(platform)]} {
2096 ## Windows is screwy because it's case insensitive
2097 set tmp [ConsoleExpandBestMatch [string tolower $m] \
2098 [string tolower [file tail $str]]]
2100 set tmp [ConsoleExpandBestMatch $m [file tail $str]]
2102 if {[string match ?*/* $str]} {
2103 set tmp [file dirname $str]/$tmp
2104 } elseif {[string match /* $str]} {
2107 regsub -all { } $tmp {\\ } tmp
2108 set match [linsert $m 0 $tmp]
2110 ## This may look goofy, but it handles spaces in path names
2111 eval append match $m
2112 if {[file isdir $match]} {append match /}
2113 if {[string match ?*/* $str]} {
2114 set match [file dirname $str]/$match
2115 } elseif {[string match /* $str]} {
2118 regsub -all { } $match {\\ } match
2119 ## Why is this one needed and the ones below aren't!!
2120 set match [list $match]
2123 ConsoleEvalAttached [list cd $pwd]
2127 ## ConsoleExpandProcname - expand a tcl proc name based on $str
2128 # ARGS: str - partial proc name to expand
2129 # Calls: ConsoleExpandBestMatch
2130 # Returns: list containing longest unique match followed by all the
2131 # possible further matches
2133 ;proc ConsoleExpandProcname str {
2134 set match [ConsoleEvalAttached [list info commands $str*]]
2135 if {[llength $match] > 1} {
2136 regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str
2137 set match [linsert $match 0 $str]
2139 regsub -all { } $match {\\ } match
2144 ## ConsoleExpandVariable - expand a tcl variable name based on $str
2145 # ARGS: str - partial tcl var name to expand
2146 # Calls: ConsoleExpandBestMatch
2147 # Returns: list containing longest unique match followed by all the
2148 # possible further matches
2150 ;proc ConsoleExpandVariable str {
2151 if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
2152 ## Looks like they're trying to expand an array.
2153 set match [ConsoleEvalAttached [list array names $ary $str*]]
2154 if {[llength $match] > 1} {
2155 set vars $ary\([ConsoleExpandBestMatch $match $str]
2156 foreach var $match {lappend vars $ary\($var\)}
2158 } else {set match $ary\($match\)}
2159 ## Space transformation avoided for array names.
2161 set match [ConsoleEvalAttached [list info vars $str*]]
2162 if {[llength $match] > 1} {
2163 regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str
2164 set match [linsert $match 0 $str]
2166 regsub -all { } $match {\\ } match
2172 ## ConsoleExpandBestMatch2 - finds the best unique match in a list of names
2173 ## Improves upon the speed of the below proc only when $l is small
2174 ## or $e is {}. $e is extra for compatibility with proc below.
2175 # ARGS: l - list to find best unique match in
2176 # Returns: longest unique match in the list
2178 ;proc ConsoleExpandBestMatch2 {l {e {}}} {
2180 if {[llength $l]>1} {
2181 set i [expr [string length $s]-1]
2183 while {$i>=0 && [string first $s $l]} {
2184 set s [string range $s 0 [incr i -1]]
2191 ## ConsoleExpandBestMatch - finds the best unique match in a list of names
2192 ## The extra $e in this argument allows us to limit the innermost loop a
2193 ## little further. This improves speed as $l becomes large or $e becomes long.
2194 # ARGS: l - list to find best unique match in
2195 # e - currently best known unique match
2196 # Returns: longest unique match in the list
2198 ;proc ConsoleExpandBestMatch {l {e {}}} {
2199 set ec [lindex $l 0]
2200 if {[llength $l]>1} {
2201 set e [string length $e]; incr e -1
2202 set ei [string length $ec]; incr ei -1
2204 while {$ei>=$e && [string first $ec $l]} {
2205 set ec [string range $ec 0 [incr ei -1]]
2213 ## ConsoleResource - re'source's this script into current console
2214 ## Meant primarily for my development of this program. It follows
2215 ## links until the ultimate source is found.
2217 set Console(SCRIPT) [info script]
2218 if {!$Console(WWW)} {
2219 while {[string match link [file type $Console(SCRIPT)]]} {
2220 set link [file readlink $Console(SCRIPT)]
2221 if {[string match relative [file pathtype $link]]} {
2222 set Console(SCRIPT) [file join \
2223 [file dirname $Console(SCRIPT)] $link]
2225 set Console(SCRIPT) $link
2229 if {[string match relative [file pathtype $Console(SCRIPT)]]} {
2230 set Console(SCRIPT) [file join [pwd] $Console(SCRIPT)]
2234 ;proc Console:resource {} {
2236 uplevel \#0 [list source $Console(SCRIPT)]