summaryrefslogtreecommitdiffstats
path: root/tkcon/extra/stripped.tcl
diff options
context:
space:
mode:
Diffstat (limited to 'tkcon/extra/stripped.tcl')
-rwxr-xr-xtkcon/extra/stripped.tcl1083
1 files changed, 0 insertions, 1083 deletions
diff --git a/tkcon/extra/stripped.tcl b/tkcon/extra/stripped.tcl
deleted file mode 100755
index 64ef1f5..0000000
--- a/tkcon/extra/stripped.tcl
+++ /dev/null
@@ -1,1083 +0,0 @@
-#!/bin/sh
-# \
-exec wish4.1 "$0" ${1+"$@"}
-
-#
-## stripped.tcl
-## Stripped down version of Tk Console Widget, part of the VerTcl system
-## Stripped to work with Netscape Tk Plugin.
-##
-## Copyright (c) 1995,1996 by Jeffrey Hobbs
-## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/
-## source standard_disclaimer.tcl
-
-if {[info tclversion] < 7.5} {
- error "TkCon requires at least the stable version of tcl7.5/tk4.1"
-}
-
-## tkConInit - inits tkCon
-# ARGS: root - widget pathname of the tkCon console root
-# title - title for the console root and main (.) windows
-# Calls: tkConInitUI
-# Outputs: errors found in tkCon resource file
-##
-proc tkConInit {{title Main}} {
- global tkCon tcl_platform env auto_path tcl_interactive
-
- set tcl_interactive 1
-
- array set tkCon {
- color,blink yellow
- color,proc darkgreen
- color,prompt brown
- color,stdin black
- color,stdout blue
- color,stderr red
-
- blinktime 500
- font fixed
- lightbrace 1
- lightcmd 1
- prompt1 {[history nextid] % }
- prompt2 {[history nextid] cont > }
- showmultiple 1
- slavescript {}
-
- cmd {} cmdbuf {} cmdsave {} event 1 svnt 1 cols 80 rows 24
-
- version {0.5x Stripped}
- base .console
- }
-
- if [string comp $tcl_platform(platform) unix] {
- array set tkCon {
- font {Courier 12 {}}
- }
- }
-
- tkConInitUI $title
-
- interp alias {} clean {} tkConStateRevert tkCon
- tkConStateCheckpoint tkCon
-}
-
-## tkConInitUI - inits UI portion (console) of tkCon
-## Creates all elements of the console window and sets up the text tags
-# ARGS: title - title for the console root and main (.) windows
-# Calls: tkConInitMenus, tkConPrompt
-##
-proc tkConInitUI {title} {
- global tkCon
-
- set root $tkCon(base)
- if [string match $root .] { set w {} } else { set w [frame $root] }
-
- set tkCon(console) [text $w.text -font $tkCon(font) -wrap char \
- -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin)]
- bindtags $w.text "$w.text PreCon Console PostCon $root all"
- set tkCon(scrolly) [scrollbar $w.sy \
- -command "$w.text yview" -takefocus 0 -bd 1]
-
- pack $w.sy -side left -fill y
- set tkCon(scrollypos) left
- pack $w.text -fill both -expand 1
-
- $w.text insert insert "$title console display active\n" stdout
- tkConPrompt $w.text
-
- foreach col {prompt stdout stderr stdin proc} {
- $w.text tag configure $col -foreground $tkCon(color,$col)
- }
- $w.text tag configure blink -background $tkCon(color,blink)
-
- pack $root -fill both -expand 1
- focus $w.text
-}
-
-## tkConEval - evaluates commands input into console window
-## This is the first stage of the evaluating commands in the console.
-## They need to be broken up into consituent commands (by tkConCmdSep) in
-## case a multiple commands were pasted in, then each is eval'ed (by
-## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed.
-# ARGS: w - console text widget
-# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd
-##
-proc tkConEval {w} {
- global tkCon
- tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd)
- $w mark set insert end-1c
- $w insert end \n
- if [llength $cmds] {
- foreach cmd $cmds {tkConEvalCmd $w $cmd}
- $w insert insert $tkCon(cmd) {}
- } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} {
- tkConEvalCmd $w $tkCon(cmd)
- }
- $w see insert
-}
-
-## tkConEvalCmd - evaluates a single command, adding it to history
-# ARGS: w - console text widget
-# cmd - the command to evaluate
-# Calls: tkConPrompt
-# Outputs: result of command to stdout (or stderr if error occured)
-# Returns: next event number
-##
-proc tkConEvalCmd {w cmd} {
- global tkCon
- $w mark set output end
- if [catch {uplevel \#0 history add [list $cmd] exec} result] {
- $w insert output $result\n stderr
- } elseif [string comp {} $result] {
- $w insert output $result\n stdout
- }
- tkConPrompt $w
- set tkCon(svnt) [set tkCon(event) [history nextid]]
-}
-
-## tkConCmdGet - gets the current command from the console widget
-# ARGS: w - console text widget
-# Returns: text which compromises current command line
-##
-proc tkConCmdGet w {
- if [string match {} [set ix [$w tag nextrange prompt limit end]]] {
- $w tag add stdin limit end-1c
- return [$w get limit end-1c]
- }
-}
-
-## tkConCmdSep - separates multiple commands into a list and remainder
-# ARGS: cmd - (possible) multiple command to separate
-# list - varname for the list of commands that were separated.
-# rmd - varname of any remainder (like an incomplete final command).
-# If there is only one command, it's placed in this var.
-# Returns: constituent command info in varnames specified by list & rmd.
-##
-proc tkConCmdSep {cmd ls rmd} {
- upvar $ls cmds $rmd tmp
- set tmp {}
- set cmds {}
- foreach cmd [split [set cmd] \n] {
- if [string comp {} $tmp] {
- append tmp \n$cmd
- } else {
- append tmp $cmd
- }
- if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} {
- lappend cmds $tmp
- set tmp {}
- }
- }
- if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} {
- set tmp [lindex $cmds end]
- set cmds [lreplace $cmds end end]
- }
-}
-
-## tkConPrompt - displays the prompt in the console widget
-# ARGS: w - console text widget
-# Outputs: prompt (specified in tkCon(prompt1)) to console
-##
-proc tkConPrompt w {
- global tkCon env
- set i [$w index end-1c]
- $w insert end [subst $tkCon(prompt1)] prompt
- $w mark set output $i
- $w mark set limit insert
- $w mark gravity limit left
-}
-
-## tkConStateCheckpoint - checkpoints the current state of the system
-## This allows you to return to this state with tkConStateRevert
-# ARGS: ary an array into which several elements are stored:
-# commands - the currently defined commands
-# variables - the current global vars
-# This is the array you would pass to tkConRevertState
-##
-proc tkConStateCheckpoint {ary} {
- global tkCon
- upvar $ary a
- set a(commands) [uplevel \#0 info commands *]
- set a(variables) [uplevel \#0 info vars *]
- return
-}
-
-## tkConStateCompare - compare two states and output difference
-# ARGS: ary1 an array with checkpointed state
-# ary2 a second array with checkpointed state
-# Outputs:
-##
-proc tkConStateCompare {ary1 ary2} {
- upvar $ary1 a1 $ary2 a2
- puts "Commands unique to $ary1:\n[lremove $a1(commands) $a2(commands)]"
- puts "Commands unique to $ary2:\n[lremove $a2(commands) $a1(commands)]"
- puts "Variables unique to $ary1:\n[lremove $a1(variables) $a2(variables)]"
- puts "Variables unique to $ary2:\n[lremove $a2(variables) $a1(variables)]"
-}
-
-## tkConStateRevert - reverts interpreter to a previous state
-# ARGS: ary an array with checkpointed state
-##
-proc tkConStateRevert {ary} {
- upvar $ary a
- tkConStateCheckpoint tmp
- foreach i [lremove $tmp(commands) $a(commands)] { catch "rename $i {}" }
- foreach i [lremove $tmp(variables) $a(variables)] { uplevel \#0 unset $i }
-}
-
-##
-## Some procedures to make up for lack of built-in shell commands
-##
-
-## puts
-## This allows me to capture all stdout/stderr to the console window
-# ARGS: same as usual
-# Outputs: the string with a color-coded text tag
-##
-catch {rename puts tcl_puts}
-proc puts args {
- set len [llength $args]
- if {$len==1} {
- eval tkcon console insert output $args stdout {\n} stdout
- tkcon console see output
- } elseif {$len==2 &&
- [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} {
- if [string comp $tmp -nonewline] {
- eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp
- } else {
- eval tkcon console insert output [lreplace $args 0 0] stdout
- }
- tkcon console see output
- } elseif {$len==3 &&
- [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} {
- if [string comp [lreplace $args 1 2] -nonewline] {
- eval tkcon console insert output [lrange $args 1 1] $tmp
- } else {
- eval tkcon console insert output [lreplace $args 0 1] $tmp
- }
- tkcon console see output
- } else {
- eval tcl_puts $args
- }
-}
-
-## alias - akin to the csh alias command
-## If called with no args, then it prints out all current aliases
-## If called with one arg, returns the alias of that arg (or {} if none)
-# ARGS: newcmd - (optional) command to bind alias to
-# args - command and args being aliased
-##
-proc alias {{newcmd {}} args} {
- if [string match $newcmd {}] {
- set res {}
- foreach a [interp aliases] {
- lappend res [list $a: [interp alias {} $a]]
- }
- return [join $res \n]
- } elseif {[string match {} $args]} {
- interp alias {} $newcmd
- } else {
- eval interp alias {{}} $newcmd {{}} $args
- }
-}
-
-## unalias - unaliases an alias'ed command
-# ARGS: cmd - command to unbind as an alias
-##
-proc unalias {cmd} {
- interp alias {} $cmd {}
-}
-
-## tkcon - command that allows control over the console
-# ARGS: totally variable, see internal comments
-##
-proc tkcon {args} {
- global tkCon
- switch -- [lindex $args 0] {
- clean {
- ## 'cleans' the interpreter - reverting to original tkCon state
- tkConStateRevert tkCon
- }
- console {
- ## Passes the args to the text widget of the console.
- eval $tkCon(console) [lreplace $args 0 0]
- }
- font {
- ## "tkcon font ?fontname?". Sets the font of the console
- if [string comp {} [lindex $args 1]] {
- return [$tkCon(console) config -font [lindex $args 1]]
- } else {
- return [$tkCon(console) config -font]
- }
- }
- version {
- return $tkCon(version)
- }
- default {
- ## tries to determine if the command exists, otherwise throws error
- set cmd [lindex $args 0]
- set cmd tkCon[string toup [string index $cmd 0]][string range $cmd 1 end]
- if [string match $cmd [info command $cmd]] {
- eval $cmd [lreplace $args 0 0]
- } else {
- error "bad option \"[lindex $args 0]\": must be attach,\
- clean, console, font"
- }
- }
- }
-}
-
-## clear - clears the buffer of the console (not the history though)
-## This is executed in the parent interpreter
-##
-proc clear {{pcnt 100}} {
- if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
- error "invalid percentage to clear: must be 1-100 (100 default)"
- } elseif {$pcnt == 100} {
- tkcon console delete 1.0 end
- } else {
- set tmp [expr $pcnt/100.0*[tkcon console index end]]
- tkcon console delete 1.0 "$tmp linestart"
- }
-}
-
-## dump - outputs variables/procedure/widget info in source'able form.
-## Accepts glob style pattern matching for the names
-# ARGS: type - type of thing to dump: must be variable, procedure, widget
-# OPTS: -nocomplain don't complain if no vars match something
-# Returns: the values of the variables in a 'source'able form
-##
-proc dump {type args} {
- set whine 1
- set code ok
- if [string match \-n* [lindex $args 0]] {
- set whine 0
- set args [lreplace $args 0 0]
- }
- if {$whine && [string match {} $args]} {
- error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?"
- }
- set res {}
- switch -glob -- $type {
- v* {
- # variable
- # outputs variables value(s), whether array or simple.
- foreach arg $args {
- if {[string match {} [set vars [uplevel info vars [list $arg]]]]} {
- if {[uplevel info exists $arg]} {
- set vars $arg
- } elseif $whine {
- append res "\#\# No known variable $arg\n"
- set code error
- continue
- } else continue
- }
- foreach var [lsort $vars] {
- upvar $var v
- if {[array exists v]} {
- append res "array set $var \{\n"
- foreach i [lsort [array names v]] {
- upvar 0 v\($i\) w
- if {[array exists w]} {
- append res " [list $i {NESTED VAR ERROR}]\n"
- if $whine { set code error }
- } else {
- append res " [list $i $v($i)]\n"
- }
- }
- append res "\}\n"
- } else {
- append res [list set $var $v]\n
- }
- }
- }
- }
- p* {
- # procedure
- foreach arg $args {
- if {[string comp {} [set ps [info proc $arg]]]} {
- foreach p [lsort $ps] {
- set as {}
- foreach a [info args $p] {
- if {[info default $p $a tmp]} {
- lappend as [list $a $tmp]
- } else {
- lappend as $a
- }
- }
- append res [list proc $p $as [info body $p]]\n
- }
- } elseif $whine {
- append res "\#\# No known proc $arg\n"
- }
- }
- }
- w* {
- # widget
- }
- default {
- return -code error "bad [lindex [info level 0] 0] option\
- \"[lindex $args 0]\":\ must be procedure, variable, widget"
- }
- }
- return -code $code [string trimr $res \n]
-}
-
-## which - tells you where a command is found
-# ARGS: cmd - command name
-# Returns: where command is found (internal / external / unknown)
-##
-proc which cmd {
- if [string comp {} [info commands $cmd]] {
- if {[lsearch -exact [interp aliases] $cmd] > -1} {
- return "$cmd:\taliased to [alias $cmd]"
- } elseif [string comp {} [info procs $cmd]] {
- return "$cmd:\tinternal proc"
- } else {
- return "$cmd:\tinternal command"
- }
- } else {
- return "$cmd:\tunknown command"
- }
-}
-
-## lremove - remove items from a list
-# OPTS: -all remove all instances of each item
-# ARGS: l a list to remove items from
-# is a list of items to remove
-##
-proc lremove {args} {
- set all 0
- if [string match \-a* [lindex $args 0]] {
- set all 1
- set args [lreplace $args 0 0]
- }
- set l [lindex $args 0]
- eval append is [lreplace $args 0 0]
- foreach i $is {
- if {[set ix [lsearch -exact $l $i]] == -1} continue
- set l [lreplace $l $ix $ix]
- if $all {
- while {[set ix [lsearch -exact $l $i]] != -1} {
- set l [lreplace $l $i $i]
- }
- }
- }
- return $l
-}
-
-
-## Unknown changed to get output into tkCon window
-## See $tcl_library/init.tcl for an explanation
-##
-proc unknown args {
- global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon
- global errorCode errorInfo
-
- # Save the values of errorCode and errorInfo variables, since they
- # may get modified if caught errors occur below. The variables will
- # be restored just before re-executing the missing command.
-
- set savedErrorCode $errorCode
- set savedErrorInfo $errorInfo
- set name [lindex $args 0]
- if ![info exists auto_noload] {
- #
- # Make sure we're not trying to load the same proc twice.
- #
- if [info exists unknown_pending($name)] {
- unset unknown_pending($name)
- if {[array size unknown_pending] == 0} {
- unset unknown_pending
- }
- return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
- }
- set unknown_pending($name) pending;
- set ret [catch {auto_load $name} msg]
- unset unknown_pending($name);
- if {$ret != 0} {
- return -code $ret -errorcode $errorCode \
- "error while autoloading \"$name\": $msg"
- }
- if ![array size unknown_pending] {
- unset unknown_pending
- }
- if $msg {
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
- set code [catch {uplevel $args} msg]
- if {$code == 1} {
- #
- # Strip the last five lines off the error stack (they're
- # from the "uplevel" command).
- #
-
- set new [split $errorInfo \n]
- set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
- return -code error -errorcode $errorCode \
- -errorinfo $new $msg
- } else {
- return -code $code $msg
- }
- }
- }
- if {[info level] == 1 && [string match {} [info script]] \
- && [info exists tcl_interactive] && $tcl_interactive} {
- if ![info exists auto_noexec] {
- if [auto_execok $name] {
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
- return [uplevel exec $args]
- #return [uplevel exec >&@stdout <@stdin $args]
- }
- }
- set errorCode $savedErrorCode
- set errorInfo $savedErrorInfo
- if {[string match $name !!]} {
- catch {set tkCon(cmd) [history event]}
- return [uplevel {history redo}]
- } elseif [regexp {^!(.+)$} $name dummy event] {
- catch {set tkCon(cmd) [history event $event]}
- return [uplevel [list history redo $event]]
- } elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
- catch {set tkCon(cmd) [history substitute $old $new]}
- return [uplevel [list history substitute $old $new]]
- }
- set cmds [info commands $name*]
- if {[llength $cmds] == 1} {
- return [uplevel [lreplace $args 0 0 $cmds]]
- } elseif {[llength $cmds]} {
- if {$name == ""} {
- return -code error "empty command name \"\""
- } else {
- return -code error \
- "ambiguous command name \"$name\": [lsort $cmds]"
- }
- }
- }
- return -code error "invalid command name \"$name\""
-}
-
-
-# tkConClipboardKeysyms --
-# This procedure is invoked to identify the keys that correspond to
-# the "copy", "cut", and "paste" functions for the clipboard.
-#
-# Arguments:
-# copy - Name of the key (keysym name plus modifiers, if any,
-# such as "Meta-y") used for the copy operation.
-# cut - Name of the key used for the cut operation.
-# paste - Name of the key used for the paste operation.
-
-proc tkConCut w {
- if [string match $w [selection own -displayof $w]] {
- clipboard clear -displayof $w
- catch {
- clipboard append -displayof $w [selection get -displayof $w]
- if [$w compare sel.first >= limit] {$w delete sel.first sel.last}
- }
- }
-}
-proc tkConCopy w {
- if [string match $w [selection own -displayof $w]] {
- clipboard clear -displayof $w
- catch {clipboard append -displayof $w [selection get -displayof $w]}
- }
-}
-
-proc tkConPaste w {
- if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] {
- if [$w compare insert < limit] {$w mark set insert end}
- $w insert insert $tmp
- $w see insert
- if [string match *\n* $tmp] {tkConEval $w}
- }
-}
-
-proc tkConClipboardKeysyms {copy cut paste} {
- bind Console <$copy> {tkConCopy %W}
- bind Console <$cut> {tkConCut %W}
- bind Console <$paste> {tkConPaste %W}
-}
-
-## Get all Text bindings into Console
-##
-foreach ev [lremove [bind Text] {<Control-Key-y> <Control-Key-w> \
- <Meta-Key-w> <Control-Key-o>}] {
- bind Console $ev [bind Text $ev]
-}
-unset ev
-
-## Redefine for Console what we need
-##
-tkConClipboardKeysyms F16 F20 F18
-tkConClipboardKeysyms Control-c Control-x Control-v
-
-bind Console <Insert> {catch {tkConInsert %W [selection get -displayof %W]}}
-
-bind Console <Up> {
- if [%W compare {insert linestart} != {limit linestart}] {
- tkTextSetCursor %W [tkTextUpDownLine %W -1]
- } else {
- if {$tkCon(event) == [history nextid]} {
- set tkCon(cmdbuf) [tkConCmdGet %W]
- }
- if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] {
- incr tkCon(event)
- } else {
- %W delete limit end
- %W insert limit $tkCon(tmp)
- %W see end
- }
- }
-}
-bind Console <Down> {
- if [%W compare {insert linestart} != {end-1c linestart}] {
- tkTextSetCursor %W [tkTextUpDownLine %W 1]
- } else {
- if {$tkCon(event) < [history nextid]} {
- %W delete limit end
- if {[incr tkCon(event)] == [history nextid]} {
- %W insert limit $tkCon(cmdbuf)
- } else {
- %W insert limit [history event $tkCon(event)]
- }
- %W see end
- }
- }
-}
-bind Console <Control-P> {
- if [%W compare insert > limit] {tkConExpand %W proc}
-}
-bind Console <Control-V> {
- if [%W compare insert > limit] {tkConExpand %W var}
-}
-bind Console <Control-i> {
- if [%W compare insert >= limit] {
- tkConInsert %W \t
- }
-}
-bind Console <Return> {
- tkConEval %W
-}
-bind Console <KP_Enter> [bind Console <Return>]
-bind Console <Delete> {
- if {[string comp {} [%W tag nextrange sel 1.0 end]] \
- && [%W compare sel.first >= limit]} {
- %W delete sel.first sel.last
- } elseif [%W compare insert >= limit] {
- %W delete insert
- %W see insert
- }
-}
-bind Console <BackSpace> {
- if {[string comp {} [%W tag nextrange sel 1.0 end]] \
- && [%W compare sel.first >= limit]} {
- %W delete sel.first sel.last
- } elseif {[%W compare insert != 1.0] && [%W compare insert-1c >= limit]} {
- %W delete insert-1c
- %W see insert
- }
-}
-bind Console <Control-h> [bind Console <BackSpace>]
-
-bind Console <KeyPress> {
- tkConInsert %W %A
-}
-
-bind Console <Control-a> {
- if [%W compare {limit linestart} == {insert linestart}] {
- tkTextSetCursor %W limit
- } else {
- tkTextSetCursor %W {insert linestart}
- }
-}
-bind Console <Control-d> {
- if [%W compare insert < limit] break
- %W delete insert
-}
-bind Console <Control-k> {
- if [%W compare insert < limit] break
- if [%W compare insert == {insert lineend}] {
- %W delete insert
- } else {
- %W delete insert {insert lineend}
- }
-}
-bind Console <Control-l> {
- ## Clear console buffer, without losing current command line input
- set tkCon(tmp) [tkConCmdGet %W]
- clear
- tkConPrompt
- tkConInsert %W $tkCon(tmp)
-}
-bind Console <Control-n> {
- ## Goto next command in history
- if {$tkCon(event) < [history nextid]} {
- %W delete limit end
- if {[incr tkCon(event)] == [history nextid]} {
- %W insert limit $tkCon(cmdbuf)
- } else {
- %W insert limit [history event $tkCon(event)]
- }
- %W see end
- }
-}
-bind Console <Control-p> {
- ## Goto previous command in history
- if {$tkCon(event) == [history nextid]} {
- set tkCon(cmdbuf) [tkConCmdGet %W]
- }
- if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] {
- incr tkCon(event)
- } else {
- %W delete limit end
- %W insert limit $tkCon(tmp)
- %W see end
- }
-}
-bind Console <Control-r> {
- ## Search history reverse
- if {$tkCon(svnt) == [history nextid]} {
- set tkCon(cmdbuf) [tkConCmdGet %W]
- }
- set tkCon(tmp1) [string len $tkCon(cmdbuf)]
- incr tkCon(tmp1) -1
- while 1 {
- if {[catch {history event [incr tkCon(svnt) -1]} tkCon(tmp)]} {
- incr tkCon(svnt)
- break
- } elseif {![string comp $tkCon(cmdbuf) \
- [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
- %W delete limit end
- %W insert limit $tkCon(tmp)
- break
- }
- }
- %W see end
-}
-bind Console <Control-s> {
- ## Search history forward
- set tkCon(tmp1) [string len $tkCon(cmdbuf)]
- incr tkCon(tmp1) -1
- while {$tkCon(svnt) < [history nextid]} {
- if {[incr tkCon(svnt)] == [history nextid]} {
- %W delete limit end
- %W insert limit $tkCon(cmdbuf)
- break
- } elseif {![catch {history event $tkCon(svnt)} tkCon(tmp)]
- && ![string comp $tkCon(cmdbuf) \
- [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
- %W delete limit end
- %W insert limit $tkCon(tmp)
- break
- }
- }
- %W see end
-}
-bind Console <Control-t> {
- ## Transpose current and previous chars
- if [%W compare insert > limit] {
- tkTextTranspose %W
- }
-}
-bind Console <Control-u> {
- ## Clear command line (Unix shell staple)
- %W delete limit end
-}
-bind Console <Control-z> {
- ## Save command buffer
- set tkCon(tmp) $tkCon(cmdsave)
- set tkCon(cmdsave) [tkConCmdGet %W]
- if {[string match {} $tkCon(cmdsave)]} {
- set tkCon(cmdsave) $tkCon(tmp)
- } else {
- %W delete limit end-1c
- }
- tkConInsert %W $tkCon(tmp)
- %W see end
-}
-catch {bind Console <Key-Page_Up> { tkTextScrollPages %W -1 }}
-catch {bind Console <Key-Prior> { tkTextScrollPages %W -1 }}
-catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
-catch {bind Console <Key-Next> { tkTextScrollPages %W 1 }}
-bind Console <Meta-d> {
- if [%W compare insert >= limit] {
- %W delete insert {insert wordend}
- }
-}
-bind Console <Meta-BackSpace> {
- if [%W compare {insert -1c wordstart} >= limit] {
- %W delete {insert -1c wordstart} insert
- }
-}
-bind Console <Meta-Delete> {
- if [%W compare insert >= limit] {
- %W delete insert {insert wordend}
- }
-}
-bind Console <ButtonRelease-2> {
- if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \
- && ![catch {selection get -displayof %W} tkCon(tmp)]} {
- if [%W compare @%x,%y < limit] {
- %W insert end $tkCon(tmp)
- } else {
- %W insert @%x,%y $tkCon(tmp)
- }
- if [string match *\n* $tkCon(tmp)] {tkConEval %W}
- }
-}
-
-##
-## End weird bindings
-##
-
-##
-## PostCon bindings, for doing special things based on certain keys
-##
-bind PostCon <Key-parenright> {
- if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
- [string comp \\ [%W get insert-2c]]} {
- tkConMatchPair %W \( \)
- }
-}
-bind PostCon <Key-bracketright> {
- if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
- [string comp \\ [%W get insert-2c]]} {
- tkConMatchPair %W \[ \]
- }
-}
-bind PostCon <Key-braceright> {
- if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
- [string comp \\ [%W get insert-2c]]} {
- tkConMatchPair %W \{ \}
- }
-}
-bind PostCon <Key-quotedbl> {
- if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
- [string comp \\ [%W get insert-2c]]} {
- tkConMatchQuote %W
- }
-}
-
-bind PostCon <KeyPress> {
- if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W }
-}
-
-## tkConTagProc - tags a procedure in the console if it's recognized
-## This procedure is not perfect. However, making it perfect wastes
-## too much CPU time... Also it should check the existence of a command
-## in whatever is the connected slave, not the master interpreter.
-##
-proc tkConTagProc w {
- set i [$w index "insert-1c wordstart"]
- set j [$w index "insert-1c wordend"]
- if {[string comp {} [info command [list [$w get $i $j]]]]} {
- $w tag add proc $i $j
- } else {
- $w tag remove proc $i $j
- }
-}
-
-
-## tkConMatchPair - 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.
-# ARGS: w - console text widget
-# c1 - first char of pair
-# c2 - second char of pair
-# Calls: tkConBlink
-##
-proc tkConMatchPair {w c1 c2} {
- if [string comp {} [set ix [$w search -back $c1 insert limit]]] {
- while {[string match {\\} [$w get $ix-1c]] &&
- [string comp {} [set ix [$w search -back $c1 $ix-1c limit]]]} {}
- set i1 insert-1c
- while {[string comp {} $ix]} {
- set i0 $ix
- set j 0
- while {[string comp {} [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 comp {} [set ix [$w search -back $c1 $ix limit]]]} {
- if {[string match {\\} [$w get $ix-1c]]} continue
- incr j -1
- }
- }
- if [string match {} $ix] { set ix [$w index limit] }
- } else { set ix [$w index limit] }
- tkConBlink $w $ix [$w index insert]
-}
-
-## tkConMatchQuote - 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'.
-# ARGS: w - console text widget
-# Calls: tkConBlink
-##
-proc tkConMatchQuote w {
- set i insert-1c
- set j 0
- while {[string comp {} [set i [$w search -back \" $i limit]]]} {
- if {[string match {\\} [$w get $i-1c]]} continue
- if {!$j} {set i0 $i}
- incr j
- }
- if [expr $j%2] {
- tkConBlink $w $i0 [$w index insert]
- } else {
- tkConBlink $w [$w index insert-1c] [$w index insert]
- }
-}
-
-## tkConBlink - blinks between 2 indices for a specified duration.
-# ARGS: 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 tkConBlink {w i1 i2} {
- global tkCon
- $w tag add blink $i1 $i2
- after $tkCon(blinktime) $w tag remove blink $i1 $i2
- return
-}
-
-
-## tkConInsert
-## 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.
-# ARGS: w - text window in which to insert the string
-# s - string to insert (usually just a single char)
-# Outputs: $s to text widget
-##
-proc tkConInsert {w s} {
- if {[string match {} $s] || [string match disabled [$w cget -state]]} {
- return
- }
- if [$w comp insert < limit] {
- $w mark set insert end
- }
- catch {
- if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} {
- $w delete sel.first sel.last
- }
- }
- $w insert insert $s
- $w see insert
-}
-
-## tkConExpand -
-# ARGS: w - text widget in which to expand str
-# type - type of expansion (path / proc / variable)
-# Calls: tkConExpand(Pathname|Procname|Variable)
-# Outputs: The string to match is expanded to the longest possible match.
-# If tkCon(showmultiple) is non-zero and the user 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 tkConExpand {w type} {
- set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
- set tmp [$w search -back -regexp $exp insert-1c limit-1c]
- if [string compare {} $tmp] {append tmp +2c} else {set tmp limit}
- if [$w compare $tmp >= insert] return
- set str [$w get $tmp insert]
- switch -glob $type {
- pr* {set res [tkConExpandProcname $str]}
- v* {set res [tkConExpandVariable $str]}
- default {set res {}}
- }
- set len [llength $res]
- if $len {
- $w delete $tmp insert
- $w insert $tmp [lindex $res 0]
- if {$len > 1} {
- global tkCon
- if {$tkCon(showmultiple) && [string match [lindex $res 0] $str]} {
- puts stdout [lreplace $res 0 0]
- }
- }
- }
- return [incr len -1]
-}
-
-## tkConExpandProcname - expand a tcl proc name based on $str
-# ARGS: str - partial proc name to expand
-# Calls: tkConExpandBestMatch
-# Returns: list containing longest unique match followed by all the
-# possible further matches
-##
-proc tkConExpandProcname str {
- set match [info commands $str*]
- if {[llength $match] > 1} {
- regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str
- set match [linsert $match 0 $str]
- } else {
- regsub -all { } $match {\\ } match
- }
- return $match
-}
-
-## tkConExpandVariable - expand a tcl variable name based on $str
-# ARGS: str - partial tcl var name to expand
-# Calls: tkConExpandBestMatch
-# Returns: list containing longest unique match followed by all the
-# possible further matches
-##
-proc tkConExpandVariable str {
- if [regexp {([^\(]*)\((.*)} $str junk ary str] {
- set match [uplevel \#0 array names $ary $str*]
- if {[llength $match] > 1} {
- set vars $ary\([tkConExpandBestMatch $match $str]
- foreach var $match {lappend vars $ary\($var\)}
- return $vars
- } else {set match $ary\($match\)}
- } else {
- set match [uplevel \#0 info vars $str*]
- if {[llength $match] > 1} {
- regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str
- set match [linsert $match 0 $str]
- } else {
- regsub -all { } $match {\\ } match
- }
- }
- return $match
-}
-
-## tkConExpandBestMatch - 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.
-# ARGS: l - list to find best unique match in
-# e - currently best known unique match
-# Returns: longest unique match in the list
-##
-proc tkConExpandBestMatch {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
-}
-
-
-## Initialize only if we haven't yet
-##
-if [catch {winfo exists $tkCon(base)}] tkConInit
generated by cgit v0.12 at 2024-10-01 14:10:39 (GMT)