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.8 2000/04/21 04:06:37 hobbs Exp $ |
---|
8 | # |
---|
9 | # Copyright (c) 1998-1999 Scriptics Corp. |
---|
10 | # Copyright (c) 1995-1997 Sun Microsystems, Inc. |
---|
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 | # tkConsoleInit -- |
---|
19 | # This procedure constructs and configures the console windows. |
---|
20 | # |
---|
21 | # Arguments: |
---|
22 | # None. |
---|
23 | |
---|
24 | proc tkConsoleInit {} { |
---|
25 | global tcl_platform |
---|
26 | |
---|
27 | if {![consoleinterp eval {set tcl_interactive}]} { |
---|
28 | wm withdraw . |
---|
29 | } |
---|
30 | |
---|
31 | if {[string compare $tcl_platform(platform) "macintosh"]} { |
---|
32 | set mod "Ctrl" |
---|
33 | } else { |
---|
34 | set mod "Cmd" |
---|
35 | } |
---|
36 | |
---|
37 | menu .menubar |
---|
38 | .menubar add cascade -label File -menu .menubar.file -underline 0 |
---|
39 | .menubar add cascade -label Edit -menu .menubar.edit -underline 0 |
---|
40 | |
---|
41 | menu .menubar.file -tearoff 0 |
---|
42 | .menubar.file add command -label "Source..." -underline 0 \ |
---|
43 | -command tkConsoleSource |
---|
44 | .menubar.file add command -label "Hide Console" -underline 0 \ |
---|
45 | -command {wm withdraw .} |
---|
46 | if {[string compare $tcl_platform(platform) "macintosh"]} { |
---|
47 | .menubar.file add command -label "Exit" -underline 1 -command exit |
---|
48 | } else { |
---|
49 | .menubar.file add command -label "Quit" -command exit -accel Cmd-Q |
---|
50 | } |
---|
51 | |
---|
52 | menu .menubar.edit -tearoff 0 |
---|
53 | .menubar.edit add command -label "Cut" -underline 2 \ |
---|
54 | -command { event generate .console <<Cut>> } -accel "$mod+X" |
---|
55 | .menubar.edit add command -label "Copy" -underline 0 \ |
---|
56 | -command { event generate .console <<Copy>> } -accel "$mod+C" |
---|
57 | .menubar.edit add command -label "Paste" -underline 1 \ |
---|
58 | -command { event generate .console <<Paste>> } -accel "$mod+V" |
---|
59 | |
---|
60 | if {[string compare $tcl_platform(platform) "windows"]} { |
---|
61 | .menubar.edit add command -label "Clear" -underline 2 \ |
---|
62 | -command { event generate .console <<Clear>> } |
---|
63 | } else { |
---|
64 | .menubar.edit add command -label "Delete" -underline 0 \ |
---|
65 | -command { event generate .console <<Clear>> } -accel "Del" |
---|
66 | |
---|
67 | .menubar add cascade -label Help -menu .menubar.help -underline 0 |
---|
68 | menu .menubar.help -tearoff 0 |
---|
69 | .menubar.help add command -label "About..." -underline 0 \ |
---|
70 | -command tkConsoleAbout |
---|
71 | } |
---|
72 | |
---|
73 | . configure -menu .menubar |
---|
74 | |
---|
75 | text .console -yscrollcommand ".sb set" -setgrid true |
---|
76 | scrollbar .sb -command ".console yview" |
---|
77 | pack .sb -side right -fill both |
---|
78 | pack .console -fill both -expand 1 -side left |
---|
79 | switch -exact $tcl_platform(platform) { |
---|
80 | "macintosh" { |
---|
81 | .console configure -font {Monaco 9 normal} -highlightthickness 0 |
---|
82 | } |
---|
83 | "windows" { |
---|
84 | .console configure -font systemfixed |
---|
85 | } |
---|
86 | } |
---|
87 | |
---|
88 | tkConsoleBind .console |
---|
89 | |
---|
90 | .console tag configure stderr -foreground red |
---|
91 | .console tag configure stdin -foreground blue |
---|
92 | |
---|
93 | focus .console |
---|
94 | |
---|
95 | wm protocol . WM_DELETE_WINDOW { wm withdraw . } |
---|
96 | wm title . "Console" |
---|
97 | flush stdout |
---|
98 | .console mark set output [.console index "end - 1 char"] |
---|
99 | tkTextSetCursor .console end |
---|
100 | .console mark set promptEnd insert |
---|
101 | .console mark gravity promptEnd left |
---|
102 | } |
---|
103 | |
---|
104 | # tkConsoleSource -- |
---|
105 | # |
---|
106 | # Prompts the user for a file to source in the main interpreter. |
---|
107 | # |
---|
108 | # Arguments: |
---|
109 | # None. |
---|
110 | |
---|
111 | proc tkConsoleSource {} { |
---|
112 | set filename [tk_getOpenFile -defaultextension .tcl -parent . \ |
---|
113 | -title "Select a file to source" \ |
---|
114 | -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}] |
---|
115 | if {[string compare $filename ""]} { |
---|
116 | set cmd [list source $filename] |
---|
117 | if {[catch {consoleinterp eval $cmd} result]} { |
---|
118 | tkConsoleOutput stderr "$result\n" |
---|
119 | } |
---|
120 | } |
---|
121 | } |
---|
122 | |
---|
123 | # tkConsoleInvoke -- |
---|
124 | # Processes the command line input. If the command is complete it |
---|
125 | # is evaled in the main interpreter. Otherwise, the continuation |
---|
126 | # prompt is added and more input may be added. |
---|
127 | # |
---|
128 | # Arguments: |
---|
129 | # None. |
---|
130 | |
---|
131 | proc tkConsoleInvoke {args} { |
---|
132 | set ranges [.console tag ranges input] |
---|
133 | set cmd "" |
---|
134 | if {[llength $ranges]} { |
---|
135 | set pos 0 |
---|
136 | while {[string compare [lindex $ranges $pos] ""]} { |
---|
137 | set start [lindex $ranges $pos] |
---|
138 | set end [lindex $ranges [incr pos]] |
---|
139 | append cmd [.console get $start $end] |
---|
140 | incr pos |
---|
141 | } |
---|
142 | } |
---|
143 | if {[string equal $cmd ""]} { |
---|
144 | tkConsolePrompt |
---|
145 | } elseif {[info complete $cmd]} { |
---|
146 | .console mark set output end |
---|
147 | .console tag delete input |
---|
148 | set result [consoleinterp record $cmd] |
---|
149 | if {[string compare $result ""]} { |
---|
150 | puts $result |
---|
151 | } |
---|
152 | tkConsoleHistory reset |
---|
153 | tkConsolePrompt |
---|
154 | } else { |
---|
155 | tkConsolePrompt partial |
---|
156 | } |
---|
157 | .console yview -pickplace insert |
---|
158 | } |
---|
159 | |
---|
160 | # tkConsoleHistory -- |
---|
161 | # This procedure implements command line history for the |
---|
162 | # console. In general is evals the history command in the |
---|
163 | # main interpreter to obtain the history. The global variable |
---|
164 | # histNum is used to store the current location in the history. |
---|
165 | # |
---|
166 | # Arguments: |
---|
167 | # cmd - Which action to take: prev, next, reset. |
---|
168 | |
---|
169 | set histNum 1 |
---|
170 | proc tkConsoleHistory {cmd} { |
---|
171 | global histNum |
---|
172 | |
---|
173 | switch $cmd { |
---|
174 | prev { |
---|
175 | incr histNum -1 |
---|
176 | if {$histNum == 0} { |
---|
177 | set cmd {history event [expr {[history nextid] -1}]} |
---|
178 | } else { |
---|
179 | set cmd "history event $histNum" |
---|
180 | } |
---|
181 | if {[catch {consoleinterp eval $cmd} cmd]} { |
---|
182 | incr histNum |
---|
183 | return |
---|
184 | } |
---|
185 | .console delete promptEnd end |
---|
186 | .console insert promptEnd $cmd {input stdin} |
---|
187 | } |
---|
188 | next { |
---|
189 | incr histNum |
---|
190 | if {$histNum == 0} { |
---|
191 | set cmd {history event [expr {[history nextid] -1}]} |
---|
192 | } elseif {$histNum > 0} { |
---|
193 | set cmd "" |
---|
194 | set histNum 1 |
---|
195 | } else { |
---|
196 | set cmd "history event $histNum" |
---|
197 | } |
---|
198 | if {[string compare $cmd ""]} { |
---|
199 | catch {consoleinterp eval $cmd} cmd |
---|
200 | } |
---|
201 | .console delete promptEnd end |
---|
202 | .console insert promptEnd $cmd {input stdin} |
---|
203 | } |
---|
204 | reset { |
---|
205 | set histNum 1 |
---|
206 | } |
---|
207 | } |
---|
208 | } |
---|
209 | |
---|
210 | # tkConsolePrompt -- |
---|
211 | # This procedure draws the prompt. If tcl_prompt1 or tcl_prompt2 |
---|
212 | # exists in the main interpreter it will be called to generate the |
---|
213 | # prompt. Otherwise, a hard coded default prompt is printed. |
---|
214 | # |
---|
215 | # Arguments: |
---|
216 | # partial - Flag to specify which prompt to print. |
---|
217 | |
---|
218 | proc tkConsolePrompt {{partial normal}} { |
---|
219 | if {[string equal $partial "normal"]} { |
---|
220 | set temp [.console index "end - 1 char"] |
---|
221 | .console mark set output end |
---|
222 | if {[consoleinterp eval "info exists tcl_prompt1"]} { |
---|
223 | consoleinterp eval "eval \[set tcl_prompt1\]" |
---|
224 | } else { |
---|
225 | puts -nonewline "% " |
---|
226 | } |
---|
227 | } else { |
---|
228 | set temp [.console index output] |
---|
229 | .console mark set output end |
---|
230 | if {[consoleinterp eval "info exists tcl_prompt2"]} { |
---|
231 | consoleinterp eval "eval \[set tcl_prompt2\]" |
---|
232 | } else { |
---|
233 | puts -nonewline "> " |
---|
234 | } |
---|
235 | } |
---|
236 | flush stdout |
---|
237 | .console mark set output $temp |
---|
238 | tkTextSetCursor .console end |
---|
239 | .console mark set promptEnd insert |
---|
240 | .console mark gravity promptEnd left |
---|
241 | } |
---|
242 | |
---|
243 | # tkConsoleBind -- |
---|
244 | # This procedure first ensures that the default bindings for the Text |
---|
245 | # class have been defined. Then certain bindings are overridden for |
---|
246 | # the class. |
---|
247 | # |
---|
248 | # Arguments: |
---|
249 | # None. |
---|
250 | |
---|
251 | proc tkConsoleBind {win} { |
---|
252 | bindtags $win "$win Text . all" |
---|
253 | |
---|
254 | # Ignore all Alt, Meta, and Control keypresses unless explicitly bound. |
---|
255 | # Otherwise, if a widget binding for one of these is defined, the |
---|
256 | # <KeyPress> class binding will also fire and insert the character, |
---|
257 | # which is wrong. Ditto for <Escape>. |
---|
258 | |
---|
259 | bind $win <Alt-KeyPress> {# nothing } |
---|
260 | bind $win <Meta-KeyPress> {# nothing} |
---|
261 | bind $win <Control-KeyPress> {# nothing} |
---|
262 | bind $win <Escape> {# nothing} |
---|
263 | bind $win <KP_Enter> {# nothing} |
---|
264 | |
---|
265 | bind $win <Tab> { |
---|
266 | tkConsoleInsert %W \t |
---|
267 | focus %W |
---|
268 | break |
---|
269 | } |
---|
270 | bind $win <Return> { |
---|
271 | %W mark set insert {end - 1c} |
---|
272 | tkConsoleInsert %W "\n" |
---|
273 | tkConsoleInvoke |
---|
274 | break |
---|
275 | } |
---|
276 | bind $win <Delete> { |
---|
277 | if {[string compare [%W tag nextrange sel 1.0 end] ""]} { |
---|
278 | %W tag remove sel sel.first promptEnd |
---|
279 | } elseif {[%W compare insert < promptEnd]} { |
---|
280 | break |
---|
281 | } |
---|
282 | } |
---|
283 | bind $win <BackSpace> { |
---|
284 | if {[string compare [%W tag nextrange sel 1.0 end] ""]} { |
---|
285 | %W tag remove sel sel.first promptEnd |
---|
286 | } elseif {[%W compare insert <= promptEnd]} { |
---|
287 | break |
---|
288 | } |
---|
289 | } |
---|
290 | foreach left {Control-a Home} { |
---|
291 | bind $win <$left> { |
---|
292 | if {[%W compare insert < promptEnd]} { |
---|
293 | tkTextSetCursor %W {insert linestart} |
---|
294 | } else { |
---|
295 | tkTextSetCursor %W promptEnd |
---|
296 | } |
---|
297 | break |
---|
298 | } |
---|
299 | } |
---|
300 | foreach right {Control-e End} { |
---|
301 | bind $win <$right> { |
---|
302 | tkTextSetCursor %W {insert lineend} |
---|
303 | break |
---|
304 | } |
---|
305 | } |
---|
306 | bind $win <Control-d> { |
---|
307 | if {[%W compare insert < promptEnd]} { |
---|
308 | break |
---|
309 | } |
---|
310 | } |
---|
311 | bind $win <Control-k> { |
---|
312 | if {[%W compare insert < promptEnd]} { |
---|
313 | %W mark set insert promptEnd |
---|
314 | } |
---|
315 | } |
---|
316 | bind $win <Control-t> { |
---|
317 | if {[%W compare insert < promptEnd]} { |
---|
318 | break |
---|
319 | } |
---|
320 | } |
---|
321 | bind $win <Meta-d> { |
---|
322 | if {[%W compare insert < promptEnd]} { |
---|
323 | break |
---|
324 | } |
---|
325 | } |
---|
326 | bind $win <Meta-BackSpace> { |
---|
327 | if {[%W compare insert <= promptEnd]} { |
---|
328 | break |
---|
329 | } |
---|
330 | } |
---|
331 | bind $win <Control-h> { |
---|
332 | if {[%W compare insert <= promptEnd]} { |
---|
333 | break |
---|
334 | } |
---|
335 | } |
---|
336 | foreach prev {Control-p Up} { |
---|
337 | bind $win <$prev> { |
---|
338 | tkConsoleHistory prev |
---|
339 | break |
---|
340 | } |
---|
341 | } |
---|
342 | foreach prev {Control-n Down} { |
---|
343 | bind $win <$prev> { |
---|
344 | tkConsoleHistory next |
---|
345 | break |
---|
346 | } |
---|
347 | } |
---|
348 | bind $win <Insert> { |
---|
349 | catch {tkConsoleInsert %W [selection get -displayof %W]} |
---|
350 | break |
---|
351 | } |
---|
352 | bind $win <KeyPress> { |
---|
353 | tkConsoleInsert %W %A |
---|
354 | break |
---|
355 | } |
---|
356 | foreach left {Control-b Left} { |
---|
357 | bind $win <$left> { |
---|
358 | if {[%W compare insert == promptEnd]} { |
---|
359 | break |
---|
360 | } |
---|
361 | tkTextSetCursor %W insert-1c |
---|
362 | break |
---|
363 | } |
---|
364 | } |
---|
365 | foreach right {Control-f Right} { |
---|
366 | bind $win <$right> { |
---|
367 | tkTextSetCursor %W insert+1c |
---|
368 | break |
---|
369 | } |
---|
370 | } |
---|
371 | bind $win <F9> { |
---|
372 | eval destroy [winfo child .] |
---|
373 | if {[string equal $tcl_platform(platform) "macintosh"]} { |
---|
374 | source -rsrc Console |
---|
375 | } else { |
---|
376 | source [file join $tk_library console.tcl] |
---|
377 | } |
---|
378 | } |
---|
379 | bind $win <<Cut>> { |
---|
380 | # Same as the copy event |
---|
381 | if {![catch {set data [%W get sel.first sel.last]}]} { |
---|
382 | clipboard clear -displayof %W |
---|
383 | clipboard append -displayof %W $data |
---|
384 | } |
---|
385 | break |
---|
386 | } |
---|
387 | bind $win <<Copy>> { |
---|
388 | if {![catch {set data [%W get sel.first sel.last]}]} { |
---|
389 | clipboard clear -displayof %W |
---|
390 | clipboard append -displayof %W $data |
---|
391 | } |
---|
392 | break |
---|
393 | } |
---|
394 | bind $win <<Paste>> { |
---|
395 | catch { |
---|
396 | set clip [selection get -displayof %W -selection CLIPBOARD] |
---|
397 | set list [split $clip \n\r] |
---|
398 | tkConsoleInsert %W [lindex $list 0] |
---|
399 | foreach x [lrange $list 1 end] { |
---|
400 | %W mark set insert {end - 1c} |
---|
401 | tkConsoleInsert %W "\n" |
---|
402 | tkConsoleInvoke |
---|
403 | tkConsoleInsert %W $x |
---|
404 | } |
---|
405 | } |
---|
406 | break |
---|
407 | } |
---|
408 | } |
---|
409 | |
---|
410 | # tkConsoleInsert -- |
---|
411 | # Insert a string into a text at the point of the insertion cursor. |
---|
412 | # If there is a selection in the text, and it covers the point of the |
---|
413 | # insertion cursor, then delete the selection before inserting. Insertion |
---|
414 | # is restricted to the prompt area. |
---|
415 | # |
---|
416 | # Arguments: |
---|
417 | # w - The text window in which to insert the string |
---|
418 | # s - The string to insert (usually just a single character) |
---|
419 | |
---|
420 | proc tkConsoleInsert {w s} { |
---|
421 | if {[string equal $s ""]} { |
---|
422 | return |
---|
423 | } |
---|
424 | catch { |
---|
425 | if {[$w compare sel.first <= insert] |
---|
426 | && [$w compare sel.last >= insert]} { |
---|
427 | $w tag remove sel sel.first promptEnd |
---|
428 | $w delete sel.first sel.last |
---|
429 | } |
---|
430 | } |
---|
431 | if {[$w compare insert < promptEnd]} { |
---|
432 | $w mark set insert end |
---|
433 | } |
---|
434 | $w insert insert $s {input stdin} |
---|
435 | $w see insert |
---|
436 | } |
---|
437 | |
---|
438 | # tkConsoleOutput -- |
---|
439 | # |
---|
440 | # This routine is called directly by ConsolePutsCmd to cause a string |
---|
441 | # to be displayed in the console. |
---|
442 | # |
---|
443 | # Arguments: |
---|
444 | # dest - The output tag to be used: either "stderr" or "stdout". |
---|
445 | # string - The string to be displayed. |
---|
446 | |
---|
447 | proc tkConsoleOutput {dest string} { |
---|
448 | .console insert output $string $dest |
---|
449 | .console see insert |
---|
450 | } |
---|
451 | |
---|
452 | # tkConsoleExit -- |
---|
453 | # |
---|
454 | # This routine is called by ConsoleEventProc when the main window of |
---|
455 | # the application is destroyed. Don't call exit - that probably already |
---|
456 | # happened. Just delete our window. |
---|
457 | # |
---|
458 | # Arguments: |
---|
459 | # None. |
---|
460 | |
---|
461 | proc tkConsoleExit {} { |
---|
462 | destroy . |
---|
463 | } |
---|
464 | |
---|
465 | # tkConsoleAbout -- |
---|
466 | # |
---|
467 | # This routine displays an About box to show Tcl/Tk version info. |
---|
468 | # |
---|
469 | # Arguments: |
---|
470 | # None. |
---|
471 | |
---|
472 | proc tkConsoleAbout {} { |
---|
473 | global tk_patchLevel |
---|
474 | tk_messageBox -type ok -message "Tcl for Windows |
---|
475 | Copyright \251 2000 Scriptics Corporation |
---|
476 | |
---|
477 | Tcl [info patchlevel] |
---|
478 | Tk $tk_patchLevel" |
---|
479 | } |
---|
480 | |
---|
481 | # now initialize the console |
---|
482 | |
---|
483 | tkConsoleInit |
---|