source: proiecte/pmake3d/make3d_original/Make3dSingleImageStanford_version0.1/third_party/vrippack-0.31/lib/linux/tk8.4/console.tcl @ 37

Last change on this file since 37 was 37, checked in by (none), 14 years ago

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