Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | # console.tcl -- |
2 | # | |
3 | # This code constructs the console window for an application. It | |
4 | # can be used by non-unix systems that do not have built-in support | |
5 | # for shells. | |
6 | # | |
7 | # RCS: @(#) $Id: console.tcl,v 1.22.2.3 2005/05/31 04:58:00 hobbs Exp $ | |
8 | # | |
9 | # Copyright (c) 1995-1997 Sun Microsystems, Inc. | |
10 | # Copyright (c) 1998-2000 Ajuba Solutions. | |
11 | # | |
12 | # See the file "license.terms" for information on usage and redistribution | |
13 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. | |
14 | # | |
15 | ||
16 | # TODO: history - remember partially written command | |
17 | ||
18 | namespace eval ::tk::console { | |
19 | variable blinkTime 500 ; # msecs to blink braced range for | |
20 | variable blinkRange 1 ; # enable blinking of the entire braced range | |
21 | variable magicKeys 1 ; # enable brace matching and proc/var recognition | |
22 | variable maxLines 600 ; # maximum # of lines buffered in console | |
23 | variable showMatches 1 ; # show multiple expand matches | |
24 | ||
25 | variable inPlugin [info exists embed_args] | |
26 | variable defaultPrompt ; # default prompt if tcl_prompt1 isn't used | |
27 | ||
28 | ||
29 | if {$inPlugin} { | |
30 | set defaultPrompt {subst {[history nextid] % }} | |
31 | } else { | |
32 | set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }} | |
33 | } | |
34 | } | |
35 | ||
36 | # simple compat function for tkcon code added for this console | |
37 | interp alias {} EvalAttached {} consoleinterp eval | |
38 | ||
39 | # ::tk::ConsoleInit -- | |
40 | # This procedure constructs and configures the console windows. | |
41 | # | |
42 | # Arguments: | |
43 | # None. | |
44 | ||
45 | proc ::tk::ConsoleInit {} { | |
46 | global tcl_platform | |
47 | ||
48 | if {![consoleinterp eval {set tcl_interactive}]} { | |
49 | wm withdraw . | |
50 | } | |
51 | ||
52 | if {[string equal $tcl_platform(platform) "macintosh"] | |
53 | || [string equal [tk windowingsystem] "aqua"]} { | |
54 | set mod "Cmd" | |
55 | } else { | |
56 | set mod "Ctrl" | |
57 | } | |
58 | ||
59 | if {[catch {menu .menubar} err]} { bgerror "INIT: $err" } | |
60 | .menubar add cascade -label File -menu .menubar.file -underline 0 | |
61 | .menubar add cascade -label Edit -menu .menubar.edit -underline 0 | |
62 | ||
63 | menu .menubar.file -tearoff 0 | |
64 | .menubar.file add command -label [mc "Source..."] \ | |
65 | -underline 0 -command tk::ConsoleSource | |
66 | .menubar.file add command -label [mc "Hide Console"] \ | |
67 | -underline 0 -command {wm withdraw .} | |
68 | .menubar.file add command -label [mc "Clear Console"] \ | |
69 | -underline 0 -command {.console delete 1.0 "promptEnd linestart"} | |
70 | if {[string equal $tcl_platform(platform) "macintosh"] | |
71 | || [string equal [tk windowingsystem] "aqua"]} { | |
72 | .menubar.file add command -label [mc "Quit"] \ | |
73 | -command exit -accel Cmd-Q | |
74 | } else { | |
75 | .menubar.file add command -label [mc "Exit"] \ | |
76 | -underline 1 -command exit | |
77 | } | |
78 | ||
79 | menu .menubar.edit -tearoff 0 | |
80 | .menubar.edit add command -label [mc "Cut"] -underline 2 \ | |
81 | -command { event generate .console <<Cut>> } -accel "$mod+X" | |
82 | .menubar.edit add command -label [mc "Copy"] -underline 0 \ | |
83 | -command { event generate .console <<Copy>> } -accel "$mod+C" | |
84 | .menubar.edit add command -label [mc "Paste"] -underline 1 \ | |
85 | -command { event generate .console <<Paste>> } -accel "$mod+V" | |
86 | ||
87 | if {[string compare $tcl_platform(platform) "windows"]} { | |
88 | .menubar.edit add command -label [mc "Clear"] -underline 2 \ | |
89 | -command { event generate .console <<Clear>> } | |
90 | } else { | |
91 | .menubar.edit add command -label [mc "Delete"] -underline 0 \ | |
92 | -command { event generate .console <<Clear>> } -accel "Del" | |
93 | ||
94 | .menubar add cascade -label Help -menu .menubar.help -underline 0 | |
95 | menu .menubar.help -tearoff 0 | |
96 | .menubar.help add command -label [mc "About..."] \ | |
97 | -underline 0 -command tk::ConsoleAbout | |
98 | } | |
99 | ||
100 | . configure -menu .menubar | |
101 | ||
102 | set con [text .console -yscrollcommand [list .sb set] -setgrid true] | |
103 | scrollbar .sb -command [list $con yview] | |
104 | pack .sb -side right -fill both | |
105 | pack $con -fill both -expand 1 -side left | |
106 | switch -exact $tcl_platform(platform) { | |
107 | "macintosh" { | |
108 | $con configure -font {Monaco 9 normal} -highlightthickness 0 | |
109 | } | |
110 | "windows" { | |
111 | $con configure -font systemfixed | |
112 | } | |
113 | "unix" { | |
114 | if {[string equal [tk windowingsystem] "aqua"]} { | |
115 | $con configure -font {Monaco 9 normal} -highlightthickness 0 | |
116 | } | |
117 | } | |
118 | } | |
119 | ||
120 | ConsoleBind $con | |
121 | ||
122 | $con tag configure stderr -foreground red | |
123 | $con tag configure stdin -foreground blue | |
124 | $con tag configure prompt -foreground \#8F4433 | |
125 | $con tag configure proc -foreground \#008800 | |
126 | $con tag configure var -background \#FFC0D0 | |
127 | $con tag raise sel | |
128 | $con tag configure blink -background \#FFFF00 | |
129 | $con tag configure find -background \#FFFF00 | |
130 | ||
131 | focus $con | |
132 | ||
133 | wm protocol . WM_DELETE_WINDOW { wm withdraw . } | |
134 | wm title . [mc "Console"] | |
135 | flush stdout | |
136 | $con mark set output [$con index "end - 1 char"] | |
137 | tk::TextSetCursor $con end | |
138 | $con mark set promptEnd insert | |
139 | $con mark gravity promptEnd left | |
140 | ||
141 | # A variant of ConsolePrompt to avoid a 'puts' call | |
142 | set w $con | |
143 | set temp [$w index "end - 1 char"] | |
144 | $w mark set output end | |
145 | if {![consoleinterp eval "info exists tcl_prompt1"]} { | |
146 | set string [EvalAttached $::tk::console::defaultPrompt] | |
147 | $w insert output $string stdout | |
148 | } | |
149 | $w mark set output $temp | |
150 | ::tk::TextSetCursor $w end | |
151 | $w mark set promptEnd insert | |
152 | $w mark gravity promptEnd left | |
153 | ||
154 | if {$tcl_platform(platform) eq "windows"} { | |
155 | # Subtle work-around to erase the '% ' that tclMain.c prints out | |
156 | after idle [list $con delete 1.0 output] | |
157 | } | |
158 | } | |
159 | ||
160 | # ::tk::ConsoleSource -- | |
161 | # | |
162 | # Prompts the user for a file to source in the main interpreter. | |
163 | # | |
164 | # Arguments: | |
165 | # None. | |
166 | ||
167 | proc ::tk::ConsoleSource {} { | |
168 | set filename [tk_getOpenFile -defaultextension .tcl -parent . \ | |
169 | -title [mc "Select a file to source"] \ | |
170 | -filetypes [list \ | |
171 | [list [mc "Tcl Scripts"] .tcl] \ | |
172 | [list [mc "All Files"] *]]] | |
173 | if {[string compare $filename ""]} { | |
174 | set cmd [list source $filename] | |
175 | if {[catch {consoleinterp eval $cmd} result]} { | |
176 | ConsoleOutput stderr "$result\n" | |
177 | } | |
178 | } | |
179 | } | |
180 | ||
181 | # ::tk::ConsoleInvoke -- | |
182 | # Processes the command line input. If the command is complete it | |
183 | # is evaled in the main interpreter. Otherwise, the continuation | |
184 | # prompt is added and more input may be added. | |
185 | # | |
186 | # Arguments: | |
187 | # None. | |
188 | ||
189 | proc ::tk::ConsoleInvoke {args} { | |
190 | set ranges [.console tag ranges input] | |
191 | set cmd "" | |
192 | if {[llength $ranges]} { | |
193 | set pos 0 | |
194 | while {[string compare [lindex $ranges $pos] ""]} { | |
195 | set start [lindex $ranges $pos] | |
196 | set end [lindex $ranges [incr pos]] | |
197 | append cmd [.console get $start $end] | |
198 | incr pos | |
199 | } | |
200 | } | |
201 | if {[string equal $cmd ""]} { | |
202 | ConsolePrompt | |
203 | } elseif {[info complete $cmd]} { | |
204 | .console mark set output end | |
205 | .console tag delete input | |
206 | set result [consoleinterp record $cmd] | |
207 | if {[string compare $result ""]} { | |
208 | puts $result | |
209 | } | |
210 | ConsoleHistory reset | |
211 | ConsolePrompt | |
212 | } else { | |
213 | ConsolePrompt partial | |
214 | } | |
215 | .console yview -pickplace insert | |
216 | } | |
217 | ||
218 | # ::tk::ConsoleHistory -- | |
219 | # This procedure implements command line history for the | |
220 | # console. In general is evals the history command in the | |
221 | # main interpreter to obtain the history. The variable | |
222 | # ::tk::HistNum is used to store the current location in the history. | |
223 | # | |
224 | # Arguments: | |
225 | # cmd - Which action to take: prev, next, reset. | |
226 | ||
227 | set ::tk::HistNum 1 | |
228 | proc ::tk::ConsoleHistory {cmd} { | |
229 | variable HistNum | |
230 | ||
231 | switch $cmd { | |
232 | prev { | |
233 | incr HistNum -1 | |
234 | if {$HistNum == 0} { | |
235 | set cmd {history event [expr {[history nextid] -1}]} | |
236 | } else { | |
237 | set cmd "history event $HistNum" | |
238 | } | |
239 | if {[catch {consoleinterp eval $cmd} cmd]} { | |
240 | incr HistNum | |
241 | return | |
242 | } | |
243 | .console delete promptEnd end | |
244 | .console insert promptEnd $cmd {input stdin} | |
245 | } | |
246 | next { | |
247 | incr HistNum | |
248 | if {$HistNum == 0} { | |
249 | set cmd {history event [expr {[history nextid] -1}]} | |
250 | } elseif {$HistNum > 0} { | |
251 | set cmd "" | |
252 | set HistNum 1 | |
253 | } else { | |
254 | set cmd "history event $HistNum" | |
255 | } | |
256 | if {[string compare $cmd ""]} { | |
257 | catch {consoleinterp eval $cmd} cmd | |
258 | } | |
259 | .console delete promptEnd end | |
260 | .console insert promptEnd $cmd {input stdin} | |
261 | } | |
262 | reset { | |
263 | set HistNum 1 | |
264 | } | |
265 | } | |
266 | } | |
267 | ||
268 | # ::tk::ConsolePrompt -- | |
269 | # This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 | |
270 | # exists in the main interpreter it will be called to generate the | |
271 | # prompt. Otherwise, a hard coded default prompt is printed. | |
272 | # | |
273 | # Arguments: | |
274 | # partial - Flag to specify which prompt to print. | |
275 | ||
276 | proc ::tk::ConsolePrompt {{partial normal}} { | |
277 | set w .console | |
278 | if {[string equal $partial "normal"]} { | |
279 | set temp [$w index "end - 1 char"] | |
280 | $w mark set output end | |
281 | if {[consoleinterp eval "info exists tcl_prompt1"]} { | |
282 | consoleinterp eval "eval \[set tcl_prompt1\]" | |
283 | } else { | |
284 | puts -nonewline [EvalAttached $::tk::console::defaultPrompt] | |
285 | } | |
286 | } else { | |
287 | set temp [$w index output] | |
288 | $w mark set output end | |
289 | if {[consoleinterp eval "info exists tcl_prompt2"]} { | |
290 | consoleinterp eval "eval \[set tcl_prompt2\]" | |
291 | } else { | |
292 | puts -nonewline "> " | |
293 | } | |
294 | } | |
295 | flush stdout | |
296 | $w mark set output $temp | |
297 | ::tk::TextSetCursor $w end | |
298 | $w mark set promptEnd insert | |
299 | $w mark gravity promptEnd left | |
300 | ::tk::console::ConstrainBuffer $w $::tk::console::maxLines | |
301 | $w see end | |
302 | } | |
303 | ||
304 | # ::tk::ConsoleBind -- | |
305 | # This procedure first ensures that the default bindings for the Text | |
306 | # class have been defined. Then certain bindings are overridden for | |
307 | # the class. | |
308 | # | |
309 | # Arguments: | |
310 | # None. | |
311 | ||
312 | proc ::tk::ConsoleBind {w} { | |
313 | bindtags $w [list $w Console PostConsole [winfo toplevel $w] all] | |
314 | ||
315 | ## Get all Text bindings into Console | |
316 | foreach ev [bind Text] { bind Console $ev [bind Text $ev] } | |
317 | ## We really didn't want the newline insertion... | |
318 | bind Console <Control-Key-o> {} | |
319 | ## ...or any Control-v binding (would block <<Paste>>) | |
320 | bind Console <Control-Key-v> {} | |
321 | ||
322 | # For the moment, transpose isn't enabled until the console | |
323 | # gets and overhaul of how it handles input -- hobbs | |
324 | bind Console <Control-Key-t> {} | |
325 | ||
326 | # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. | |
327 | # Otherwise, if a widget binding for one of these is defined, the | |
328 | ||
329 | bind Console <Alt-KeyPress> {# nothing } | |
330 | bind Console <Meta-KeyPress> {# nothing} | |
331 | bind Console <Control-KeyPress> {# nothing} | |
332 | ||
333 | foreach {ev key} { | |
334 | <<Console_Prev>> <Key-Up> | |
335 | <<Console_Next>> <Key-Down> | |
336 | <<Console_NextImmediate>> <Control-Key-n> | |
337 | <<Console_PrevImmediate>> <Control-Key-p> | |
338 | <<Console_PrevSearch>> <Control-Key-r> | |
339 | <<Console_NextSearch>> <Control-Key-s> | |
340 | ||
341 | <<Console_Expand>> <Key-Tab> | |
342 | <<Console_Expand>> <Key-Escape> | |
343 | <<Console_ExpandFile>> <Control-Shift-Key-F> | |
344 | <<Console_ExpandProc>> <Control-Shift-Key-P> | |
345 | <<Console_ExpandVar>> <Control-Shift-Key-V> | |
346 | <<Console_Tab>> <Control-Key-i> | |
347 | <<Console_Tab>> <Meta-Key-i> | |
348 | <<Console_Eval>> <Key-Return> | |
349 | <<Console_Eval>> <Key-KP_Enter> | |
350 | ||
351 | <<Console_Clear>> <Control-Key-l> | |
352 | <<Console_KillLine>> <Control-Key-k> | |
353 | <<Console_Transpose>> <Control-Key-t> | |
354 | <<Console_ClearLine>> <Control-Key-u> | |
355 | <<Console_SaveCommand>> <Control-Key-z> | |
356 | } { | |
357 | event add $ev $key | |
358 | bind Console $key {} | |
359 | } | |
360 | ||
361 | bind Console <<Console_Expand>> { | |
362 | if {[%W compare insert > promptEnd]} {::tk::console::Expand %W} | |
363 | } | |
364 | bind Console <<Console_ExpandFile>> { | |
365 | if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path} | |
366 | } | |
367 | bind Console <<Console_ExpandProc>> { | |
368 | if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc} | |
369 | } | |
370 | bind Console <<Console_ExpandVar>> { | |
371 | if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var} | |
372 | } | |
373 | bind Console <<Console_Eval>> { | |
374 | %W mark set insert {end - 1c} | |
375 | tk::ConsoleInsert %W "\n" | |
376 | tk::ConsoleInvoke | |
377 | break | |
378 | } | |
379 | bind Console <Delete> { | |
380 | if {[string compare {} [%W tag nextrange sel 1.0 end]] \ | |
381 | && [%W compare sel.first >= promptEnd]} { | |
382 | %W delete sel.first sel.last | |
383 | } elseif {[%W compare insert >= promptEnd]} { | |
384 | %W delete insert | |
385 | %W see insert | |
386 | } | |
387 | } | |
388 | bind Console <BackSpace> { | |
389 | if {[string compare {} [%W tag nextrange sel 1.0 end]] \ | |
390 | && [%W compare sel.first >= promptEnd]} { | |
391 | %W delete sel.first sel.last | |
392 | } elseif {[%W compare insert != 1.0] && \ | |
393 | [%W compare insert > promptEnd]} { | |
394 | %W delete insert-1c | |
395 | %W see insert | |
396 | } | |
397 | } | |
398 | bind Console <Control-h> [bind Console <BackSpace>] | |
399 | ||
400 | bind Console <Home> { | |
401 | if {[%W compare insert < promptEnd]} { | |
402 | tk::TextSetCursor %W {insert linestart} | |
403 | } else { | |
404 | tk::TextSetCursor %W promptEnd | |
405 | } | |
406 | } | |
407 | bind Console <Control-a> [bind Console <Home>] | |
408 | bind Console <End> { | |
409 | tk::TextSetCursor %W {insert lineend} | |
410 | } | |
411 | bind Console <Control-e> [bind Console <End>] | |
412 | bind Console <Control-d> { | |
413 | if {[%W compare insert < promptEnd]} break | |
414 | %W delete insert | |
415 | } | |
416 | bind Console <<Console_KillLine>> { | |
417 | if {[%W compare insert < promptEnd]} break | |
418 | if {[%W compare insert == {insert lineend}]} { | |
419 | %W delete insert | |
420 | } else { | |
421 | %W delete insert {insert lineend} | |
422 | } | |
423 | } | |
424 | bind Console <<Console_Clear>> { | |
425 | ## Clear console display | |
426 | %W delete 1.0 "promptEnd linestart" | |
427 | } | |
428 | bind Console <<Console_ClearLine>> { | |
429 | ## Clear command line (Unix shell staple) | |
430 | %W delete promptEnd end | |
431 | } | |
432 | bind Console <Meta-d> { | |
433 | if {[%W compare insert >= promptEnd]} { | |
434 | %W delete insert {insert wordend} | |
435 | } | |
436 | } | |
437 | bind Console <Meta-BackSpace> { | |
438 | if {[%W compare {insert -1c wordstart} >= promptEnd]} { | |
439 | %W delete {insert -1c wordstart} insert | |
440 | } | |
441 | } | |
442 | bind Console <Meta-d> { | |
443 | if {[%W compare insert >= promptEnd]} { | |
444 | %W delete insert {insert wordend} | |
445 | } | |
446 | } | |
447 | bind Console <Meta-BackSpace> { | |
448 | if {[%W compare {insert -1c wordstart} >= promptEnd]} { | |
449 | %W delete {insert -1c wordstart} insert | |
450 | } | |
451 | } | |
452 | bind Console <Meta-Delete> { | |
453 | if {[%W compare insert >= promptEnd]} { | |
454 | %W delete insert {insert wordend} | |
455 | } | |
456 | } | |
457 | bind Console <<Console_Prev>> { | |
458 | tk::ConsoleHistory prev | |
459 | } | |
460 | bind Console <<Console_Next>> { | |
461 | tk::ConsoleHistory next | |
462 | } | |
463 | bind Console <Insert> { | |
464 | catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]} | |
465 | } | |
466 | bind Console <KeyPress> { | |
467 | tk::ConsoleInsert %W %A | |
468 | } | |
469 | bind Console <F9> { | |
470 | eval destroy [winfo child .] | |
471 | if {[string equal $tcl_platform(platform) "macintosh"]} { | |
472 | if {[catch {source [file join $tk_library console.tcl]}]} {source -rsrc console} | |
473 | } else { | |
474 | source [file join $tk_library console.tcl] | |
475 | } | |
476 | } | |
477 | if {[string equal $::tcl_platform(platform) "macintosh"] | |
478 | || [string equal [tk windowingsystem] "aqua"]} { | |
479 | bind Console <Command-q> { | |
480 | exit | |
481 | } | |
482 | } | |
483 | bind Console <<Cut>> { | |
484 | # Same as the copy event | |
485 | if {![catch {set data [%W get sel.first sel.last]}]} { | |
486 | clipboard clear -displayof %W | |
487 | clipboard append -displayof %W $data | |
488 | } | |
489 | } | |
490 | bind Console <<Copy>> { | |
491 | if {![catch {set data [%W get sel.first sel.last]}]} { | |
492 | clipboard clear -displayof %W | |
493 | clipboard append -displayof %W $data | |
494 | } | |
495 | } | |
496 | bind Console <<Paste>> { | |
497 | catch { | |
498 | set clip [::tk::GetSelection %W CLIPBOARD] | |
499 | set list [split $clip \n\r] | |
500 | tk::ConsoleInsert %W [lindex $list 0] | |
501 | foreach x [lrange $list 1 end] { | |
502 | %W mark set insert {end - 1c} | |
503 | tk::ConsoleInsert %W "\n" | |
504 | tk::ConsoleInvoke | |
505 | tk::ConsoleInsert %W $x | |
506 | } | |
507 | } | |
508 | } | |
509 | ||
510 | ## | |
511 | ## Bindings for doing special things based on certain keys | |
512 | ## | |
513 | bind PostConsole <Key-parenright> { | |
514 | if {[string compare \\ [%W get insert-2c]]} { | |
515 | ::tk::console::MatchPair %W \( \) promptEnd | |
516 | } | |
517 | } | |
518 | bind PostConsole <Key-bracketright> { | |
519 | if {[string compare \\ [%W get insert-2c]]} { | |
520 | ::tk::console::MatchPair %W \[ \] promptEnd | |
521 | } | |
522 | } | |
523 | bind PostConsole <Key-braceright> { | |
524 | if {[string compare \\ [%W get insert-2c]]} { | |
525 | ::tk::console::MatchPair %W \{ \} promptEnd | |
526 | } | |
527 | } | |
528 | bind PostConsole <Key-quotedbl> { | |
529 | if {[string compare \\ [%W get insert-2c]]} { | |
530 | ::tk::console::MatchQuote %W promptEnd | |
531 | } | |
532 | } | |
533 | ||
534 | bind PostConsole <KeyPress> { | |
535 | if {"%A" != ""} { | |
536 | ::tk::console::TagProc %W | |
537 | } | |
538 | break | |
539 | } | |
540 | } | |
541 | ||
542 | # ::tk::ConsoleInsert -- | |
543 | # Insert a string into a text at the point of the insertion cursor. | |
544 | # If there is a selection in the text, and it covers the point of the | |
545 | # insertion cursor, then delete the selection before inserting. Insertion | |
546 | # is restricted to the prompt area. | |
547 | # | |
548 | # Arguments: | |
549 | # w - The text window in which to insert the string | |
550 | # s - The string to insert (usually just a single character) | |
551 | ||
552 | proc ::tk::ConsoleInsert {w s} { | |
553 | if {[string equal $s ""]} { | |
554 | return | |
555 | } | |
556 | catch { | |
557 | if {[$w compare sel.first <= insert] | |
558 | && [$w compare sel.last >= insert]} { | |
559 | $w tag remove sel sel.first promptEnd | |
560 | $w delete sel.first sel.last | |
561 | } | |
562 | } | |
563 | if {[$w compare insert < promptEnd]} { | |
564 | $w mark set insert end | |
565 | } | |
566 | $w insert insert $s {input stdin} | |
567 | $w see insert | |
568 | } | |
569 | ||
570 | # ::tk::ConsoleOutput -- | |
571 | # | |
572 | # This routine is called directly by ConsolePutsCmd to cause a string | |
573 | # to be displayed in the console. | |
574 | # | |
575 | # Arguments: | |
576 | # dest - The output tag to be used: either "stderr" or "stdout". | |
577 | # string - The string to be displayed. | |
578 | ||
579 | proc ::tk::ConsoleOutput {dest string} { | |
580 | set w .console | |
581 | $w insert output $string $dest | |
582 | ::tk::console::ConstrainBuffer $w $::tk::console::maxLines | |
583 | $w see insert | |
584 | } | |
585 | ||
586 | # ::tk::ConsoleExit -- | |
587 | # | |
588 | # This routine is called by ConsoleEventProc when the main window of | |
589 | # the application is destroyed. Don't call exit - that probably already | |
590 | # happened. Just delete our window. | |
591 | # | |
592 | # Arguments: | |
593 | # None. | |
594 | ||
595 | proc ::tk::ConsoleExit {} { | |
596 | destroy . | |
597 | } | |
598 | ||
599 | # ::tk::ConsoleAbout -- | |
600 | # | |
601 | # This routine displays an About box to show Tcl/Tk version info. | |
602 | # | |
603 | # Arguments: | |
604 | # None. | |
605 | ||
606 | proc ::tk::ConsoleAbout {} { | |
607 | tk_messageBox -type ok -message "[mc {Tcl for Windows}] | |
608 | ||
609 | Tcl $::tcl_patchLevel | |
610 | Tk $::tk_patchLevel" | |
611 | } | |
612 | ||
613 | # ::tk::console::TagProc -- | |
614 | # | |
615 | # Tags a procedure in the console if it's recognized | |
616 | # This procedure is not perfect. However, making it perfect wastes | |
617 | # too much CPU time... | |
618 | # | |
619 | # Arguments: | |
620 | # w - console text widget | |
621 | ||
622 | proc ::tk::console::TagProc w { | |
623 | if {!$::tk::console::magicKeys} { return } | |
624 | set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]" | |
625 | set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c] | |
626 | if {$i == ""} {set i promptEnd} else {append i +2c} | |
627 | regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c | |
628 | if {[llength [EvalAttached [list info commands $c]]]} { | |
629 | $w tag add proc $i "insert-1c wordend" | |
630 | } else { | |
631 | $w tag remove proc $i "insert-1c wordend" | |
632 | } | |
633 | if {[llength [EvalAttached [list info vars $c]]]} { | |
634 | $w tag add var $i "insert-1c wordend" | |
635 | } else { | |
636 | $w tag remove var $i "insert-1c wordend" | |
637 | } | |
638 | } | |
639 | ||
640 | # ::tk::console::MatchPair -- | |
641 | # | |
642 | # Blinks a matching pair of characters | |
643 | # c2 is assumed to be at the text index 'insert'. | |
644 | # This proc is really loopy and took me an hour to figure out given | |
645 | # all possible combinations with escaping except for escaped \'s. | |
646 | # It doesn't take into account possible commenting... Oh well. If | |
647 | # anyone has something better, I'd like to see/use it. This is really | |
648 | # only efficient for small contexts. | |
649 | # | |
650 | # Arguments: | |
651 | # w - console text widget | |
652 | # c1 - first char of pair | |
653 | # c2 - second char of pair | |
654 | # | |
655 | # Calls: ::tk::console::Blink | |
656 | ||
657 | proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} { | |
658 | if {!$::tk::console::magicKeys} { return } | |
659 | if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { | |
660 | while { | |
661 | [string match {\\} [$w get $ix-1c]] && | |
662 | [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]] | |
663 | } {} | |
664 | set i1 insert-1c | |
665 | while {[string compare {} $ix]} { | |
666 | set i0 $ix | |
667 | set j 0 | |
668 | while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} { | |
669 | append i0 +1c | |
670 | if {[string match {\\} [$w get $i0-2c]]} continue | |
671 | incr j | |
672 | } | |
673 | if {!$j} break | |
674 | set i1 $ix | |
675 | while {$j && [string compare {} \ | |
676 | [set ix [$w search -back $c1 $ix $lim]]]} { | |
677 | if {[string match {\\} [$w get $ix-1c]]} continue | |
678 | incr j -1 | |
679 | } | |
680 | } | |
681 | if {[string match {} $ix]} { set ix [$w index $lim] } | |
682 | } else { set ix [$w index $lim] } | |
683 | if {$::tk::console::blinkRange} { | |
684 | Blink $w $ix [$w index insert] | |
685 | } else { | |
686 | Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert] | |
687 | } | |
688 | } | |
689 | ||
690 | # ::tk::console::MatchQuote -- | |
691 | # | |
692 | # Blinks between matching quotes. | |
693 | # Blinks just the quote if it's unmatched, otherwise blinks quoted string | |
694 | # The quote to match is assumed to be at the text index 'insert'. | |
695 | # | |
696 | # Arguments: | |
697 | # w - console text widget | |
698 | # | |
699 | # Calls: ::tk::console::Blink | |
700 | ||
701 | proc ::tk::console::MatchQuote {w {lim 1.0}} { | |
702 | if {!$::tk::console::magicKeys} { return } | |
703 | set i insert-1c | |
704 | set j 0 | |
705 | while {[string compare [set i [$w search -back \" $i $lim]] {}]} { | |
706 | if {[string match {\\} [$w get $i-1c]]} continue | |
707 | if {!$j} {set i0 $i} | |
708 | incr j | |
709 | } | |
710 | if {$j&1} { | |
711 | if {$::tk::console::blinkRange} { | |
712 | Blink $w $i0 [$w index insert] | |
713 | } else { | |
714 | Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] | |
715 | } | |
716 | } else { | |
717 | Blink $w [$w index insert-1c] [$w index insert] | |
718 | } | |
719 | } | |
720 | ||
721 | # ::tk::console::Blink -- | |
722 | # | |
723 | # Blinks between n index pairs for a specified duration. | |
724 | # | |
725 | # Arguments: | |
726 | # w - console text widget | |
727 | # i1 - start index to blink region | |
728 | # i2 - end index of blink region | |
729 | # dur - duration in usecs to blink for | |
730 | # | |
731 | # Outputs: | |
732 | # blinks selected characters in $w | |
733 | ||
734 | proc ::tk::console::Blink {w args} { | |
735 | eval [list $w tag add blink] $args | |
736 | after $::tk::console::blinkTime [list $w] tag remove blink $args | |
737 | } | |
738 | ||
739 | # ::tk::console::ConstrainBuffer -- | |
740 | # | |
741 | # This limits the amount of data in the text widget | |
742 | # Called by Prompt and ConsoleOutput | |
743 | # | |
744 | # Arguments: | |
745 | # w - console text widget | |
746 | # size - # of lines to constrain to | |
747 | # | |
748 | # Outputs: | |
749 | # may delete data in console widget | |
750 | ||
751 | proc ::tk::console::ConstrainBuffer {w size} { | |
752 | if {[$w index end] > $size} { | |
753 | $w delete 1.0 [expr {int([$w index end])-$size}].0 | |
754 | } | |
755 | } | |
756 | ||
757 | # ::tk::console::Expand -- | |
758 | # | |
759 | # Arguments: | |
760 | # ARGS: w - text widget in which to expand str | |
761 | # type - type of expansion (path / proc / variable) | |
762 | # | |
763 | # Calls: ::tk::console::Expand(Pathname|Procname|Variable) | |
764 | # | |
765 | # Outputs: The string to match is expanded to the longest possible match. | |
766 | # If ::tk::console::showMatches is non-zero and the longest match | |
767 | # equaled the string to expand, then all possible matches are | |
768 | # output to stdout. Triggers bell if no matches are found. | |
769 | # | |
770 | # Returns: number of matches found | |
771 | ||
772 | proc ::tk::console::Expand {w {type ""}} { | |
773 | set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]" | |
774 | set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c] | |
775 | if {$tmp == ""} {set tmp promptEnd} else {append tmp +2c} | |
776 | if {[$w compare $tmp >= insert]} { return } | |
777 | set str [$w get $tmp insert] | |
778 | switch -glob $type { | |
779 | path* { set res [ExpandPathname $str] } | |
780 | proc* { set res [ExpandProcname $str] } | |
781 | var* { set res [ExpandVariable $str] } | |
782 | default { | |
783 | set res {} | |
784 | foreach t {Pathname Procname Variable} { | |
785 | if {![catch {Expand$t $str} res] && ($res != "")} { break } | |
786 | } | |
787 | } | |
788 | } | |
789 | set len [llength $res] | |
790 | if {$len} { | |
791 | set repl [lindex $res 0] | |
792 | $w delete $tmp insert | |
793 | $w insert $tmp $repl {input stdin} | |
794 | if {($len > 1) && $::tk::console::showMatches \ | |
795 | && [string equal $repl $str]} { | |
796 | puts stdout [lsort [lreplace $res 0 0]] | |
797 | } | |
798 | } else { bell } | |
799 | return [incr len -1] | |
800 | } | |
801 | ||
802 | # ::tk::console::ExpandPathname -- | |
803 | # | |
804 | # Expand a file pathname based on $str | |
805 | # This is based on UNIX file name conventions | |
806 | # | |
807 | # Arguments: | |
808 | # str - partial file pathname to expand | |
809 | # | |
810 | # Calls: ::tk::console::ExpandBestMatch | |
811 | # | |
812 | # Returns: list containing longest unique match followed by all the | |
813 | # possible further matches | |
814 | ||
815 | proc ::tk::console::ExpandPathname str { | |
816 | set pwd [EvalAttached pwd] | |
817 | if {[catch {EvalAttached [list cd [file dirname $str]]} err]} { | |
818 | return -code error $err | |
819 | } | |
820 | set dir [file tail $str] | |
821 | ## Check to see if it was known to be a directory and keep the trailing | |
822 | ## slash if so (file tail cuts it off) | |
823 | if {[string match */ $str]} { append dir / } | |
824 | if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} { | |
825 | set match {} | |
826 | } else { | |
827 | if {[llength $m] > 1} { | |
828 | global tcl_platform | |
829 | if {[string match windows $tcl_platform(platform)]} { | |
830 | ## Windows is screwy because it's case insensitive | |
831 | set tmp [ExpandBestMatch [string tolower $m] \ | |
832 | [string tolower $dir]] | |
833 | ## Don't change case if we haven't changed the word | |
834 | if {[string length $dir]==[string length $tmp]} { | |
835 | set tmp $dir | |
836 | } | |
837 | } else { | |
838 | set tmp [ExpandBestMatch $m $dir] | |
839 | } | |
840 | if {[string match ?*/* $str]} { | |
841 | set tmp [file dirname $str]/$tmp | |
842 | } elseif {[string match /* $str]} { | |
843 | set tmp /$tmp | |
844 | } | |
845 | regsub -all { } $tmp {\\ } tmp | |
846 | set match [linsert $m 0 $tmp] | |
847 | } else { | |
848 | ## This may look goofy, but it handles spaces in path names | |
849 | eval append match $m | |
850 | if {[file isdir $match]} {append match /} | |
851 | if {[string match ?*/* $str]} { | |
852 | set match [file dirname $str]/$match | |
853 | } elseif {[string match /* $str]} { | |
854 | set match /$match | |
855 | } | |
856 | regsub -all { } $match {\\ } match | |
857 | ## Why is this one needed and the ones below aren't!! | |
858 | set match [list $match] | |
859 | } | |
860 | } | |
861 | EvalAttached [list cd $pwd] | |
862 | return $match | |
863 | } | |
864 | ||
865 | # ::tk::console::ExpandProcname -- | |
866 | # | |
867 | # Expand a tcl proc name based on $str | |
868 | # | |
869 | # Arguments: | |
870 | # str - partial proc name to expand | |
871 | # | |
872 | # Calls: ::tk::console::ExpandBestMatch | |
873 | # | |
874 | # Returns: list containing longest unique match followed by all the | |
875 | # possible further matches | |
876 | ||
877 | proc ::tk::console::ExpandProcname str { | |
878 | set match [EvalAttached [list info commands $str*]] | |
879 | if {[llength $match] == 0} { | |
880 | set ns [EvalAttached \ | |
881 | "namespace children \[namespace current\] [list $str*]"] | |
882 | if {[llength $ns]==1} { | |
883 | set match [EvalAttached [list info commands ${ns}::*]] | |
884 | } else { | |
885 | set match $ns | |
886 | } | |
887 | } | |
888 | if {[llength $match] > 1} { | |
889 | regsub -all { } [ExpandBestMatch $match $str] {\\ } str | |
890 | set match [linsert $match 0 $str] | |
891 | } else { | |
892 | regsub -all { } $match {\\ } match | |
893 | } | |
894 | return $match | |
895 | } | |
896 | ||
897 | # ::tk::console::ExpandVariable -- | |
898 | # | |
899 | # Expand a tcl variable name based on $str | |
900 | # | |
901 | # Arguments: | |
902 | # str - partial tcl var name to expand | |
903 | # | |
904 | # Calls: ::tk::console::ExpandBestMatch | |
905 | # | |
906 | # Returns: list containing longest unique match followed by all the | |
907 | # possible further matches | |
908 | ||
909 | proc ::tk::console::ExpandVariable str { | |
910 | if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { | |
911 | ## Looks like they're trying to expand an array. | |
912 | set match [EvalAttached [list array names $ary $str*]] | |
913 | if {[llength $match] > 1} { | |
914 | set vars $ary\([ExpandBestMatch $match $str] | |
915 | foreach var $match {lappend vars $ary\($var\)} | |
916 | return $vars | |
917 | } elseif {[llength $match] == 1} { | |
918 | set match $ary\($match\) | |
919 | } | |
920 | ## Space transformation avoided for array names. | |
921 | } else { | |
922 | set match [EvalAttached [list info vars $str*]] | |
923 | if {[llength $match] > 1} { | |
924 | regsub -all { } [ExpandBestMatch $match $str] {\\ } str | |
925 | set match [linsert $match 0 $str] | |
926 | } else { | |
927 | regsub -all { } $match {\\ } match | |
928 | } | |
929 | } | |
930 | return $match | |
931 | } | |
932 | ||
933 | # ::tk::console::ExpandBestMatch -- | |
934 | # | |
935 | # Finds the best unique match in a list of names. | |
936 | # The extra $e in this argument allows us to limit the innermost loop a little | |
937 | # further. This improves speed as $l becomes large or $e becomes long. | |
938 | # | |
939 | # Arguments: | |
940 | # l - list to find best unique match in | |
941 | # e - currently best known unique match | |
942 | # | |
943 | # Returns: longest unique match in the list | |
944 | ||
945 | proc ::tk::console::ExpandBestMatch {l {e {}}} { | |
946 | set ec [lindex $l 0] | |
947 | if {[llength $l]>1} { | |
948 | set e [string length $e]; incr e -1 | |
949 | set ei [string length $ec]; incr ei -1 | |
950 | foreach l $l { | |
951 | while {$ei>=$e && [string first $ec $l]} { | |
952 | set ec [string range $ec 0 [incr ei -1]] | |
953 | } | |
954 | } | |
955 | } | |
956 | return $ec | |
957 | } | |
958 | ||
959 | # now initialize the console | |
960 | ::tk::ConsoleInit |