console.tcl

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

	    set clip [::tk::GetSelection %W CLIPBOARD]
	    set list [split $clip \n\r]
	    tkConsoleInsert %W [lindex $list 0]
	    foreach x [lrange $list 1 end] {
		%W mark set insert {end - 1c}
		tkConsoleInsert %W "\n"
		tkConsoleInvoke
		tkConsoleInsert %W $x
	    }
	}
    }

    ##
    ## Bindings for doing special things based on certain keys
    ##
    bind PostConsole <Key-parenright> {
	if {[string compare \\ [%W get insert-2c]]} {
	    ::tk::console::MatchPair %W \( \) promptEnd
	}
    }
    bind PostConsole <Key-bracketright> {
	if {[string compare \\ [%W get insert-2c]]} {
	    ::tk::console::MatchPair %W \[ \] promptEnd
	}
    }
    bind PostConsole <Key-braceright> {
	if {[string compare \\ [%W get insert-2c]]} {
	    ::tk::console::MatchPair %W \{ \} promptEnd
	}
    }
    bind PostConsole <Key-quotedbl> {
	if {[string compare \\ [%W get insert-2c]]} {
	    ::tk::console::MatchQuote %W promptEnd
	}
    }

    bind PostConsole <KeyPress> {
	if {"%A" != ""} {
	    ::tk::console::TagProc %W
	}
	break
    }
}

# tkConsoleInsert --
# Insert a string into a text at the point of the insertion cursor.
# If there is a selection in the text, and it covers the point of the
# insertion cursor, then delete the selection before inserting.  Insertion
# is restricted to the prompt area.
#
# Arguments:
# w -		The text window in which to insert the string
# s -		The string to insert (usually just a single character)

proc tkConsoleInsert {w s} {
    if {[string equal $s ""]} {
	return
    }
    catch {
	if {[$w compare sel.first <= insert]
		&& [$w compare sel.last >= insert]} {
	    $w tag remove sel sel.first promptEnd
	    $w delete sel.first sel.last
	}
    }
    if {[$w compare insert < promptEnd]} {
	$w mark set insert end	
    }
    $w insert insert $s {input stdin}
    $w see insert
}

# tkConsoleOutput --
#
# This routine is called directly by ConsolePutsCmd to cause a string
# to be displayed in the console.
#
# Arguments:
# dest -	The output tag to be used: either "stderr" or "stdout".
# string -	The string to be displayed.

proc tkConsoleOutput {dest string} {
    set w .console
    $w insert output $string $dest
    ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
    $w see insert
}

# tkConsoleExit --
#
# This routine is called by ConsoleEventProc when the main window of
# the application is destroyed.  Don't call exit - that probably already
# happened.  Just delete our window.
#
# Arguments:
# None.

proc tkConsoleExit {} {
    destroy .
}

# tkConsoleAbout --
#
# This routine displays an About box to show Tcl/Tk version info.
#
# Arguments:
# None.

proc tkConsoleAbout {} {
    global tk_patchLevel
    tk_messageBox -type ok -message "Tcl for Windows

Tcl [info patchlevel]
Tk $tk_patchLevel"
}

# ::tk::console::TagProc --
#
# Tags a procedure in the console if it's recognized
# This procedure is not perfect.  However, making it perfect wastes
# too much CPU time...
#
# Arguments:
#	w	- console text widget

proc ::tk::console::TagProc w {
    if {!$::tk::console::magicKeys} { return }
    set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
    set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
    if {$i == ""} {set i promptEnd} else {append i +2c}
    regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
    if {[llength [EvalAttached [list info commands $c]]]} {
	$w tag add proc $i "insert-1c wordend"
    } else {
	$w tag remove proc $i "insert-1c wordend"
    }
    if {[llength [EvalAttached [list info vars $c]]]} {
	$w tag add var $i "insert-1c wordend"
    } else {
	$w tag remove var $i "insert-1c wordend"
    }
}

# ::tk::console::MatchPair --
#
# Blinks a matching pair of characters
# c2 is assumed to be at the text index 'insert'.
# This proc is really loopy and took me an hour to figure out given
# all possible combinations with escaping except for escaped \'s.
# It doesn't take into account possible commenting... Oh well.  If
# anyone has something better, I'd like to see/use it.  This is really
# only efficient for small contexts.
#
# Arguments:
#	w	- console text widget
# 	c1	- first char of pair
# 	c2	- second char of pair
#
# Calls:	::tk::console::Blink
 
proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} {
    if {!$::tk::console::magicKeys} { return }
    if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} {
	while {
	    [string match {\\} [$w get $ix-1c]] &&
	    [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]]
	} {}
	set i1 insert-1c
	while {[string compare {} $ix]} {
	    set i0 $ix
	    set j 0
	    while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} {
		append i0 +1c
		if {[string match {\\} [$w get $i0-2c]]} continue
		incr j
	    }
	    if {!$j} break
	    set i1 $ix
	    while {$j && [string compare {} \
		    [set ix [$w search -back $c1 $ix $lim]]]} {
		if {[string match {\\} [$w get $ix-1c]]} continue
		incr j -1
	    }
	}
	if {[string match {} $ix]} { set ix [$w index $lim] }
    } else { set ix [$w index $lim] }
    if {$::tk::console::blinkRange} {
	Blink $w $ix [$w index insert]
    } else {
	Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
    }
}

# ::tk::console::MatchQuote --
#
# Blinks between matching quotes.
# Blinks just the quote if it's unmatched, otherwise blinks quoted string
# The quote to match is assumed to be at the text index 'insert'.
#
# Arguments:
#	w	- console text widget
#
# Calls:	::tk::console::Blink
 
proc ::tk::console::MatchQuote {w {lim 1.0}} {
    if {!$::tk::console::magicKeys} { return }
    set i insert-1c
    set j 0
    while {[string compare [set i [$w search -back \" $i $lim]] {}]} {
	if {[string match {\\} [$w get $i-1c]]} continue
	if {!$j} {set i0 $i}
	incr j
    }
    if {$j&1} {
	if {$::tk::console::blinkRange} {
	    Blink $w $i0 [$w index insert]
	} else {
	    Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
	}
    } else {
	Blink $w [$w index insert-1c] [$w index insert]
    }
}

# ::tk::console::Blink --
#
# Blinks between n index pairs for a specified duration.
#
# Arguments:
#	w	- console text widget
# 	i1	- start index to blink region
# 	i2	- end index of blink region
# 	dur	- duration in usecs to blink for
#
# Outputs:
#	blinks selected characters in $w

proc ::tk::console::Blink {w args} {
    eval [list $w tag add blink] $args
    after $::tk::console::blinkTime [list $w] tag remove blink $args
}

# ::tk::console::ConstrainBuffer --
#
# This limits the amount of data in the text widget
# Called by Prompt and ConsoleOutput
#
# Arguments:
#	w	- console text widget
#	size	- # of lines to constrain to
#
# Outputs:
#	may delete data in console widget

proc ::tk::console::ConstrainBuffer {w size} {
    if {[$w index end] > $size} {
	$w delete 1.0 [expr {int([$w index end])-$size}].0
    }
}

# ::tk::console::Expand --
#
# Arguments:
# ARGS:	w	- text widget in which to expand str
# 	type	- type of expansion (path / proc / variable)
#
# Calls:	::tk::console::Expand(Pathname|Procname|Variable)
#
# Outputs:	The string to match is expanded to the longest possible match.
#		If ::tk::console::showMatches is non-zero and the longest match
#		equaled the string to expand, then all possible matches are
#		output to stdout.  Triggers bell if no matches are found.
#
# Returns:	number of matches found

proc ::tk::console::Expand {w {type ""}} {
    set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]"
    set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
    if {$tmp == ""} {set tmp promptEnd} else {append tmp +2c}
    if {[$w compare $tmp >= insert]} { return }
    set str [$w get $tmp insert]
    switch -glob $type {
	path* { set res [ExpandPathname $str] }
	proc* { set res [ExpandProcname $str] }
	var*  { set res [ExpandVariable $str] }
	default {
	    set res {}
	    foreach t {Pathname Procname Variable} {
		if {![catch {Expand$t $str} res] && ($res != "")} { break }
	    }
	}
    }
    set len [llength $res]
    if {$len} {
	set repl [lindex $res 0]
	$w delete $tmp insert
	$w insert $tmp $repl {input stdin}
	if {($len > 1) && $::tk::console::showMatches \
		&& [string equal $repl $str]} {
	    puts stdout [lsort [lreplace $res 0 0]]
	}
    } else { bell }
    return [incr len -1]
}

## ::tk::console::ExpandPathname --
#
# Expand a file pathname based on $str
# This is based on UNIX file name conventions
#
# Arguments:
#	str	- partial file pathname to expand
#
# Calls:	::tk::console::ExpandBestMatch
#
# Returns:	list containing longest unique match followed by all the
#		possible further matches
 
proc ::tk::console::ExpandPathname str {
    set pwd [EvalAttached pwd]
    if {[catch {EvalAttached [list cd [file dirname $str]]} err]} {
	return -code error $err
    }
    set dir [file tail $str]
    ## Check to see if it was known to be a directory and keep the trailing
    ## slash if so (file tail cuts it off)
    if {[string match */ $str]} { append dir / }
    if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} {
	set match {}
    } else {
	if {[llength $m] > 1} {
	    global tcl_platform
	    if {[string match windows $tcl_platform(platform)]} {
		## Windows is screwy because it's case insensitive
		set tmp [ExpandBestMatch [string tolower $m] \
			[string tolower $dir]]
		## Don't change case if we haven't changed the word
		if {[string length $dir]==[string length $tmp]} {
		    set tmp $dir
		}
	    } else {
		set tmp [ExpandBestMatch $m $dir]
	    }
	    if {[string match ?*/* $str]} {
		set tmp [file dirname $str]/$tmp
	    } elseif {[string match /* $str]} {
		set tmp /$tmp
	    }
	    regsub -all { } $tmp {\\ } tmp
	    set match [linsert $m 0 $tmp]
	} else {
	    ## This may look goofy, but it handles spaces in path names
	    eval append match $m
	    if {[file isdir $match]} {append match /}
	    if {[string match ?*/* $str]} {
		set match [file dirname $str]/$match
	    } elseif {[string match /* $str]} {
		set match /$match
	    }
	    regsub -all { } $match {\\ } match
	    ## Why is this one needed and the ones below aren't!!
	    set match [list $match]
	}
    }
    EvalAttached [list cd $pwd]
    return $match
}

# ::tk::console::ExpandProcname --
#
# Expand a tcl proc name based on $str
#
# Arguments:
#	str	- partial proc name to expand
#
# Calls:	::tk::console::ExpandBestMatch
#
# Returns:	list containing longest unique match followed by all the
#		possible further matches

proc ::tk::console::ExpandProcname str {
    set match [EvalAttached [list info commands $str*]]
    if {[llength $match] == 0} {
	set ns [EvalAttached \
		"namespace children \[namespace current\] [list $str*]"]
	if {[llength $ns]==1} {
	    set match [EvalAttached [list info commands ${ns}::*]]
	} else {
	    set match $ns
	}
    }
    if {[llength $match] > 1} {
	regsub -all { } [ExpandBestMatch $match $str] {\\ } str
	set match [linsert $match 0 $str]
    } else {
	regsub -all { } $match {\\ } match
    }
    return $match
}

# ::tk::console::ExpandVariable --
#
# Expand a tcl variable name based on $str
#
# Arguments:
#	str	- partial tcl var name to expand
#
# Calls:	::tk::console::ExpandBestMatch
#
# Returns:	list containing longest unique match followed by all the
#		possible further matches

proc ::tk::console::ExpandVariable str {
    if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
	## Looks like they're trying to expand an array.
	set match [EvalAttached [list array names $ary $str*]]
	if {[llength $match] > 1} {
	    set vars $ary\([ExpandBestMatch $match $str]
	    foreach var $match {lappend vars $ary\($var\)}
	    return $vars
	} else {set match $ary\($match\)}
	## Space transformation avoided for array names.
    } else {
	set match [EvalAttached [list info vars $str*]]
	if {[llength $match] > 1} {
	    regsub -all { } [ExpandBestMatch $match $str] {\\ } str
	    set match [linsert $match 0 $str]
	} else {
	    regsub -all { } $match {\\ } match
	}
    }
    return $match
}

# ::tk::console::ExpandBestMatch --
#
# Finds the best unique match in a list of names.
# The extra $e in this argument allows us to limit the innermost loop a little
# further.  This improves speed as $l becomes large or $e becomes long.
#
# Arguments:
#	l	- list to find best unique match in
# 	e	- currently best known unique match
#
# Returns:	longest unique match in the list

proc ::tk::console::ExpandBestMatch {l {e {}}} {
    set ec [lindex $l 0]
    if {[llength $l]>1} {
	set e  [string length $e]; incr e -1
	set ei [string length $ec]; incr ei -1
	foreach l $l {
	    while {$ei>=$e && [string first $ec $l]} {
		set ec [string range $ec 0 [incr ei -1]]
	    }
	}
    }
    return $ec
}

# now initialize the console

tkConsoleInit