console.tcl

基于语义本体的单词查询系统

# console.tcl --
#
# This code constructs the console window for an application.  It
# can be used by non-unix systems that do not have built-in support
# for shells.
#
# RCS: @(#) $Id: console.tcl,v 1.8.2.4 2001/10/19 19:40:17 das Exp $
#
# Copyright (c) 1998-1999 Scriptics Corp.
# Copyright (c) 1995-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#

# TODO: history - remember partially written command
package require msgcat

namespace eval ::tk::console {
    variable blinkTime   500 ; # msecs to blink braced range for
    variable blinkRange  1   ; # enable blinking of the entire braced range
    variable magicKeys   1   ; # enable brace matching and proc/var recognition
    variable maxLines    600 ; # maximum # of lines buffered in console
    variable showMatches 1   ; # show multiple expand matches

    variable inPlugin [info exists embed_args]
    variable defaultPrompt  ; # default prompt if tcl_prompt1 isn't used

    if {$inPlugin} {
	set defaultPrompt {subst "[history nextid] % "}
    } else {
	set defaultPrompt {subst "([file tail [pwd]]) [history nextid] % "}
    }
}

# simple compat function for tkcon code added for this console
interp alias {} EvalAttached {} consoleinterp eval

# tkConsoleInit --
# This procedure constructs and configures the console windows.
#
# Arguments:
# 	None.

proc tkConsoleInit {} {
    global tcl_platform

    if {![consoleinterp eval {set tcl_interactive}]} {
	wm withdraw .
    }

    if {[string compare $tcl_platform(platform) "macintosh"]} {
	set mod "Ctrl"
    } else {
	set mod "Cmd"
    }

    menu .menubar
    .menubar add cascade -label File -menu .menubar.file -underline 0
    .menubar add cascade -label Edit -menu .menubar.edit -underline 0

    menu .menubar.file -tearoff 0
    .menubar.file add command -label "Source..." -underline 0 \
	    -command tkConsoleSource
    .menubar.file add command -label "Hide Console" -underline 0 \
	    -command {wm withdraw .}
    .menubar.file add command -label [::msgcat::mc "Clear Console"] \
	    -underline 0 -command {.console delete 1.0 "promptEnd linestart"}
    if {[string compare $tcl_platform(platform) "macintosh"]} {
	.menubar.file add command -label "Exit" -underline 1 -command exit
    } else {
	.menubar.file add command -label "Quit" -command exit -accel Cmd-Q
    }

    menu .menubar.edit -tearoff 0
    .menubar.edit add command -label "Cut" -underline 2 \
	    -command { event generate .console <<Cut>> } -accel "$mod+X"
    .menubar.edit add command -label "Copy" -underline 0 \
	    -command { event generate .console <<Copy>> } -accel "$mod+C"
    .menubar.edit add command -label "Paste" -underline 1 \
	    -command { event generate .console <<Paste>> } -accel "$mod+V"

    if {[string compare $tcl_platform(platform) "windows"]} {
	.menubar.edit add command -label "Clear" -underline 2 \
		-command { event generate .console <<Clear>> }
    } else {
	.menubar.edit add command -label "Delete" -underline 0 \
		-command { event generate .console <<Clear>> } -accel "Del"

	.menubar add cascade -label Help -menu .menubar.help -underline 0
	menu .menubar.help -tearoff 0
	.menubar.help add command -label "About..." -underline 0 \
		-command tkConsoleAbout
    }

    . configure -menu .menubar

    set con [text .console  -yscrollcommand [list .sb set] -setgrid true]
    scrollbar .sb -command [list $con yview]
    pack .sb -side right -fill both
    pack $con -fill both -expand 1 -side left
    switch -exact $tcl_platform(platform) {
	"macintosh" {
	    $con configure -font {Monaco 9 normal} -highlightthickness 0
	}
	"windows" {
	    $con configure -font systemfixed
	}
    }

    tkConsoleBind $con

    $con tag configure stderr	-foreground red
    $con tag configure stdin	-foreground blue
    $con tag configure prompt	-foreground \#8F4433
    $con tag configure proc	-foreground \#008800
    $con tag configure var	-background \#FFC0D0
    $con tag raise sel
    $con tag configure blink	-background \#FFFF00
    $con tag configure find	-background \#FFFF00

    focus $con
    
    wm protocol . WM_DELETE_WINDOW { wm withdraw . }
    wm title . "Console"
    flush stdout
    $con mark set output [$con index "end - 1 char"]
    tkTextSetCursor $con end
    $con mark set promptEnd insert
    $con mark gravity promptEnd left
}

# tkConsoleSource --
#
# Prompts the user for a file to source in the main interpreter.
#
# Arguments:
# None.

proc tkConsoleSource {} {
    set filename [tk_getOpenFile -defaultextension .tcl -parent . \
	    -title "Select a file to source" \
	    -filetypes {{"Tcl Scripts" .tcl} {"All Files" *}}]
    if {[string compare $filename ""]} {
    	set cmd [list source $filename]
	if {[catch {consoleinterp eval $cmd} result]} {
	    tkConsoleOutput stderr "$result\n"
	}
    }
}

# tkConsoleInvoke --
# Processes the command line input.  If the command is complete it
# is evaled in the main interpreter.  Otherwise, the continuation
# prompt is added and more input may be added.
#
# Arguments:
# None.

proc tkConsoleInvoke {args} {
    set ranges [.console tag ranges input]
    set cmd ""
    if {[llength $ranges]} {
	set pos 0
	while {[string compare [lindex $ranges $pos] ""]} {
	    set start [lindex $ranges $pos]
	    set end [lindex $ranges [incr pos]]
	    append cmd [.console get $start $end]
	    incr pos
	}
    }
    if {[string equal $cmd ""]} {
	tkConsolePrompt
    } elseif {[info complete $cmd]} {
	.console mark set output end
	.console tag delete input
	set result [consoleinterp record $cmd]
	if {[string compare $result ""]} {
	    puts $result
	}
	tkConsoleHistory reset
	tkConsolePrompt
    } else {
	tkConsolePrompt partial
    }
    .console yview -pickplace insert
}

# tkConsoleHistory --
# This procedure implements command line history for the
# console.  In general is evals the history command in the
# main interpreter to obtain the history.  The global variable
# histNum is used to store the current location in the history.
#
# Arguments:
# cmd -	Which action to take: prev, next, reset.

set histNum 1
proc tkConsoleHistory {cmd} {
    global histNum
    
    switch $cmd {
    	prev {
	    incr histNum -1
	    if {$histNum == 0} {
		set cmd {history event [expr {[history nextid] -1}]}
	    } else {
		set cmd "history event $histNum"
	    }
    	    if {[catch {consoleinterp eval $cmd} cmd]} {
    	    	incr histNum
    	    	return
    	    }
	    .console delete promptEnd end
    	    .console insert promptEnd $cmd {input stdin}
    	}
    	next {
	    incr histNum
	    if {$histNum == 0} {
		set cmd {history event [expr {[history nextid] -1}]}
	    } elseif {$histNum > 0} {
		set cmd ""
		set histNum 1
	    } else {
		set cmd "history event $histNum"
	    }
	    if {[string compare $cmd ""]} {
		catch {consoleinterp eval $cmd} cmd
	    }
	    .console delete promptEnd end
	    .console insert promptEnd $cmd {input stdin}
    	}
    	reset {
    	    set histNum 1
    	}
    }
}

# tkConsolePrompt --
# This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
# exists in the main interpreter it will be called to generate the 
# prompt.  Otherwise, a hard coded default prompt is printed.
#
# Arguments:
# partial -	Flag to specify which prompt to print.

proc tkConsolePrompt {{partial normal}} {
    set w .console
    if {[string equal $partial "normal"]} {
	set temp [$w index "end - 1 char"]
	$w mark set output end
    	if {[consoleinterp eval "info exists tcl_prompt1"]} {
    	    consoleinterp eval "eval \[set tcl_prompt1\]"
    	} else {
    	    puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
    	}
    } else {
	set temp [$w index output]
	$w mark set output end
    	if {[consoleinterp eval "info exists tcl_prompt2"]} {
    	    consoleinterp eval "eval \[set tcl_prompt2\]"
    	} else {
	    puts -nonewline "> "
    	}
    }
    flush stdout
    $w mark set output $temp
    tkTextSetCursor $w end
    $w mark set promptEnd insert
    $w mark gravity promptEnd left
    ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
    $w see end
}

# tkConsoleBind --
# This procedure first ensures that the default bindings for the Text
# class have been defined.  Then certain bindings are overridden for
# the class.
#
# Arguments:
# None.

proc tkConsoleBind {w} {
    bindtags $w [list $w Console PostConsole [winfo toplevel $w] all]

    ## Get all Text bindings into Console
    foreach ev [bind Text] { bind Console $ev [bind Text $ev] }	
    ## We really didn't want the newline insertion
    bind Console <Control-Key-o> {}

    # For the moment, transpose isn't enabled until the console
    # gets and overhaul of how it handles input -- hobbs
    bind Console <Control-Key-t> {}

    # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
    # Otherwise, if a widget binding for one of these is defined, the

    bind Console <Alt-KeyPress> {# nothing }
    bind Console <Meta-KeyPress> {# nothing}
    bind Console <Control-KeyPress> {# nothing}

    foreach {ev key} {
	<<Console_Prev>>		<Key-Up>
	<<Console_Next>>		<Key-Down>
	<<Console_NextImmediate>>	<Control-Key-n>
	<<Console_PrevImmediate>>	<Control-Key-p>
	<<Console_PrevSearch>>		<Control-Key-r>
	<<Console_NextSearch>>		<Control-Key-s>

	<<Console_Expand>>		<Key-Escape>
	<<Console_ExpandFile>>		<Control-Shift-Key-F>
	<<Console_ExpandProc>>		<Control-Shift-Key-P>
	<<Console_ExpandVar>>		<Control-Shift-Key-V>
	<<Console_Tab>>			<Control-Key-i>
	<<Console_Tab>>			<Meta-Key-i>
	<<Console_Eval>>		<Key-Return>
	<<Console_Eval>>		<Key-KP_Enter>

	<<Console_Clear>>		<Control-Key-l>
	<<Console_KillLine>>		<Control-Key-k>
	<<Console_Transpose>>		<Control-Key-t>
	<<Console_ClearLine>>		<Control-Key-u>
	<<Console_SaveCommand>>		<Control-Key-z>
    } {
	event add $ev $key
	bind Console $key {}
    }

    bind Console <Tab> {
	tkConsoleInsert %W \t
	focus %W
	break
    }
    bind Console <<Console_Expand>> {
	if {[%W compare insert > promptEnd]} {::tk::console::Expand %W}
    }
    bind Console <<Console_ExpandFile>> {
	if {[%W compare insert > promptEnd]} {::tk::console::Expand %W path}
    }
    bind Console <<Console_ExpandProc>> {
	if {[%W compare insert > promptEnd]} {::tk::console::Expand %W proc}
    }
    bind Console <<Console_ExpandVar>> {
	if {[%W compare insert > promptEnd]} {::tk::console::Expand %W var}
    }
    bind Console <<Console_Eval>> {
	%W mark set insert {end - 1c}
	tkConsoleInsert %W "\n"
	tkConsoleInvoke
	break
    }
    bind Console <Delete> {
	if {[string compare {} [%W tag nextrange sel 1.0 end]] \
		&& [%W compare sel.first >= promptEnd]} {
	    %W delete sel.first sel.last
	} elseif {[%W compare insert >= promptEnd]} {
	    %W delete insert
	    %W see insert
	}
    }
    bind Console <BackSpace> {
	if {[string compare {} [%W tag nextrange sel 1.0 end]] \
		&& [%W compare sel.first >= promptEnd]} {
	    %W delete sel.first sel.last
	} elseif {[%W compare insert != 1.0] && \
		[%W compare insert > promptEnd]} {
	    %W delete insert-1c
	    %W see insert
	}
    }
    bind Console <Control-h> [bind Console <BackSpace>]

    bind Console <Home> {
	if {[%W compare insert < promptEnd]} {
	    tkTextSetCursor %W {insert linestart}
	} else {
	    tkTextSetCursor %W promptEnd
	}
    }
    bind Console <Control-a> [bind Console <Home>]
    bind Console <End> {
	tkTextSetCursor %W {insert lineend}
    }
    bind Console <Control-e> [bind Console <End>]
    bind Console <Control-d> {
	if {[%W compare insert < promptEnd]} break
	%W delete insert
    }
    bind Console <<Console_KillLine>> {
	if {[%W compare insert < promptEnd]} break
	if {[%W compare insert == {insert lineend}]} {
	    %W delete insert
	} else {
	    %W delete insert {insert lineend}
	}
    }
    bind Console <<Console_Clear>> {
	## Clear console display
	%W delete 1.0 "promptEnd linestart"
    }
    bind Console <<Console_ClearLine>> {
	## Clear command line (Unix shell staple)
	%W delete promptEnd end
    }
    bind Console <Meta-d> {
	if {[%W compare insert >= promptEnd]} {
	    %W delete insert {insert wordend}
	}
    }
    bind Console <Meta-BackSpace> {
	if {[%W compare {insert -1c wordstart} >= promptEnd]} {
	    %W delete {insert -1c wordstart} insert
	}
    }
    bind Console <Meta-d> {
	if {[%W compare insert >= promptEnd]} {
	    %W delete insert {insert wordend}
	}
    }
    bind Console <Meta-BackSpace> {
	if {[%W compare {insert -1c wordstart} >= promptEnd]} {
	    %W delete {insert -1c wordstart} insert
	}
    }
    bind Console <Meta-Delete> {
	if {[%W compare insert >= promptEnd]} {
	    %W delete insert {insert wordend}
	}
    }
    bind Console <<Console_Prev>> {
	tkConsoleHistory prev
    }
    bind Console <<Console_Next>> {
	tkConsoleHistory next
    }
    bind Console <Insert> {
	catch {tkConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
    }
    bind Console <KeyPress> {
	tkConsoleInsert %W %A
    }
    bind Console <F9> {
	eval destroy [winfo child .]
	if {[string equal $tcl_platform(platform) "macintosh"]} {
	    if {[catch {source $tk_library:console.tcl}]} {source -rsrc console}
	} else {
	    source [file join $tk_library console.tcl]
	}
    }
    bind Console <<Cut>> {
        # Same as the copy event
 	if {![catch {set data [%W get sel.first sel.last]}]} {
	    clipboard clear -displayof %W
	    clipboard append -displayof %W $data
	}
    }
    bind Console <<Copy>> {
 	if {![catch {set data [%W get sel.first sel.last]}]} {
	    clipboard clear -displayof %W
	    clipboard append -displayof %W $data
	}
    }
    bind Console <<Paste>> {
	catch {