figenc

[RADIOACTIVE] rsa and symmetric key encryption scripts and executables
git clone git://git.figbert.com/figenc.git
Log | Files | Refs | README

console.tcl (32784B)


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