OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [insight/] [tk/] [library/] [console.tcl] - Blame information for rev 1765

Details | Compare with Previous | View Log

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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.