#!/bin/sh
-# The wish executable needs to be Tk4.1+ \
+# \
exec wish "$0" ${1+"$@"}
#
## tkcon.tcl
-## Tk Console Widget, part of the VerTcl system
+## Enhanced Tk Console, part of the VerTcl system
##
-## Based (loosely) off Brent Welch's Tcl Shell Widget
+## Originally based off Brent Welch's Tcl Shell Widget
+## (from "Practical Programming in Tcl and Tk")
##
## Thanks especially to the following for bug reports & code ideas:
-## Steven Wahl <steven@indra.com>
-## Jan Nijtmans <nijtmans@nici.kun.nl>
-## Crimmins < @umich.edu somewhere >
+## Steven Wahl <steven@indra.com>, Jan Nijtmans <nijtmans@nici.kun.nl>
+## Crimmins <markcrim@umich.edu>, Wart <wart@ugcs.caltech.edu>
##
-## Copyright 1995,1996 Jeffrey Hobbs. All rights reserved.
+## Copyright 1995,1996 Jeffrey Hobbs
## Initiated: Thu Aug 17 15:36:47 PDT 1995
##
## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/
##
## source standard_disclaimer.tcl
+## source beer_ware.tcl
+##
if [catch {package require Tk 4.1}] {
- error "TkCon requires at least the stable version of tcl7.5/tk4.1"
+ return -code error \
+ "TkCon requires at least the stable version of tcl7.5/tk4.1"
}
package ifneeded Tk $tk_version {load {} Tk}
-## warn - little helper proc to pop up a tk_dialog warning message
-# ARGS: msg - message you want to display to user
-##
-proc warn { msg } {
- bell
- tk_dialog ._warning Warning $msg warning 0 OK
-}
-
## tkConInit - inits tkCon
# ARGS: root - widget pathname of the tkCon console root
# title - title for the console root and main (.) windows
color,stderr red
blinktime 500
+ debugPrompt {(level \#[expr [info level]-1]) debug > }
font fixed
history 32
+ dead {}
library {}
lightbrace 1
- lightcmd 0
- loadTk 0
+ lightcmd 1
+ autoload {}
maineval {}
nontcl 0
prompt1 {([file tail [pwd]]) [history nextid] % }
- prompt2 {[history nextid] cont > }
rcfile .tkconrc
scrollypos left
showmultiple 1
subhistory 1
exec slave app {} appname {} apptype slave cmd {} cmdbuf {} cmdsave {}
- event 1 svnt 1 cols 80 rows 24 deadapp 0
- errorInfo {}
- slavealias { tkcon warn }
- slaveprocs { alias clear dir dump lremove puts tclindex \
- auto_execpath unknown unalias which }
- version 0.52
+ event 1 svnt 1 cols 80 rows 24 deadapp 0 debugging 0
+ find {} find,case 0 find,reg 0
+ errorInfo {}
+ slavealias { tkcon warn }
+ slaveprocs { alias clear dir dump lremove puts echo tclindex idebug \
+ auto_execpath unknown tcl_unknown unalias which observe observe_var }
+ version 0.63
+ release {September 1996}
root .
}
eval lappend auto_path $tkCon(library)
}
- set dir [file dir [info nameofexec]]
- foreach dir [list $dir [file join [file dir $dir] lib]] {
+ set dir [file dirname [info nameofexec]]
+ ## Change to work with IncrTcl
+ ##foreach dir [list $dir [file join [file dirname $dir] lib]]
+ if [string comp {} [info commands ensemble]] {
+ set lib [file join lib itcl]
+ } else {
+ set lib lib
+ }
+ foreach dir [list $dir [file join [file dirname $dir] $lib]] {
if [file exists [file join $dir pkgIndex.tcl]] {
if {[lsearch -exact $auto_path $dir] < 0} {
lappend auto_path $dir
## and slave is created, but before initializing UI or setting packages.
set slaveargs {}
set slavefiles {}
+ set truth {^(1|yes|true|on)$}
for {set i 0} {$i < $argc} {incr i} {
set arg [lindex $argv $i]
if [regexp -- {-.+} $arg] {
+ set val [lindex $argv [incr i]]
## Handle arg based options
switch -- $arg {
- -rcfile { incr i }
- -maineval - -e -
- -eval { append tkCon(maineval) [lindex $argv [incr i]]\n }
- -slave - -slavescript -
- -slaveeval { append tkCon(slaveeval) [lindex $argv [incr i]]\n }
- -package - -pkg -
- -load { set tkCon(load[lindex $argv [incr i]]) 1 }
- -nontcl { set tkCon(nontcl) 0 }
- -root { set tkCon(root) [lindex $argv [incr i]] }
- default { lappend slaveargs $arg }
+ -- - -argv {
+ set argv [concat -- [lrange $argv $i end]]
+ set argc [llength $argv]
+ break
+ }
+ -main - -e - -eval { append tkCon(maineval) $val\n }
+ -package - -load { lappend tkCon(autoload) $val }
+ -slave { append tkCon(slaveeval) $val\n }
+ -nontcl { set tkCon(nontcl) [regexp -nocase $truth $val] }
+ -root { set tkCon(root) $val }
+ -rcfile {}
+ default { lappend slaveargs $arg; incr i -1 }
}
} elseif {[file isfile $arg]} {
lappend slavefiles $arg
eval tkConInitSlave $tkCon(exec) $slaveargs
}
+ ## Attach to the slave, tkConEvalAttached will then be effective
tkConAttach $tkCon(appname) $tkCon(apptype)
tkConInitUI $title
- ## Set up package info for the slave
- tkConCheckPackages
+ ## Autoload specified packages in slave
+ set pkgs [tkConEvalSlave package names]
+ foreach pkg $tkCon(autoload) {
+ puts -nonewline "autoloading package \"$pkg\" ... "
+ if {[lsearch -exact $pkgs $pkg]>-1} {
+ if [catch {tkConEvalSlave package require $pkg} pkgerr] {
+ puts stderr "error:\n$pkgerr"
+ } else { puts "OK" }
+ } else {
+ puts stderr "error: package does not exist"
+ }
+ }
## Evaluate maineval in slave
if {[string comp {} $tkCon(maineval)] &&
## Source extra command line argument files into slave executable
foreach fn $slavefiles {
- puts -nonewline "slave sourcing $fn ... "
+ puts -nonewline "slave sourcing \"$fn\" ... "
if {[catch {tkConEvalSlave source $fn} fnerr]} {
puts stderr "error:\n$fnerr"
- } else {
- puts "OK"
- }
+ } else { puts "OK" }
}
- interp alias {} ls {} dir
- #interp alias $tkCon(exec) clean {} tkConStateRevert tkCon
- #tkConStateCheckpoint tkCon
-
## Evaluate slaveeval in slave
if {[string comp {} $tkCon(slaveeval)] &&
[catch {interp eval $tkCon(exec) $tkCon(slaveeval)} serr]} {
- puts stderr "error in slave script:\n$serr"
+ puts stderr "error in slave eval:\n$serr"
}
## Output any error/output that may have been returned from rcfile
if {[info exists code] && [string comp {} $err]} {
proc tkConInitSlave {slave args} {
global tkCon argv0 tcl_interactive
if [string match {} $slave] {
- error "Don't init the master interpreter, goofball"
+ return -code error "Don't init the master interpreter, goofball"
}
if ![interp exists $slave] { interp create $slave }
- if {[string match {} [$slave eval info command tcl_puts]]} {
- interp eval $slave rename puts tcl_puts
- }
+ interp eval $slave {catch {rename puts tcl_puts}}
foreach cmd $tkCon(slaveprocs) { interp eval $slave [dump proc $cmd] }
foreach cmd $tkCon(slavealias) { interp alias $slave $cmd {} $cmd }
interp alias $slave ls $slave dir
interp eval $slave set tcl_interactive $tcl_interactive \; \
set argv0 [list $argv0] \; set argc [llength $args] \; \
- set argv [list $args] \; history keep $tkCon(history)
-
+ set argv [list $args] \; history keep $tkCon(history) \; {
+ if {[string match {} [info command bgerror]]} {
+ proc bgerror err {
+ global errorInfo
+ set body [info body bgerror]
+ rename bgerror {}
+ if [auto_load bgerror] { return [bgerror $err] }
+ proc bgerror err $body
+ tkcon bgerror $err $errorInfo
+ }
+ }
+ }
+
foreach pkg [lremove [package names] Tcl] {
foreach v [package versions $pkg] {
interp eval $slave [list package ifneeded $pkg $v \
}
}
+## tkConInitInterp - inits an interpreter by placing key
+## procs and aliases in it.
+# ARGS: name - interp name
+# type - interp type (slave|interp)
+##
+proc tkConInitInterp {name type} {
+ global tkCon
+ ## Don't allow messing up a local master interpreter
+ if {[string match slave $type] && \
+ [regexp {^([Mm]ain|Slave[0-9]+)$} $name]} return
+ set old [tkConAttach]
+ catch {
+ tkConAttach $name $type
+ tkConEvalAttached {catch {rename puts tcl_puts}}
+ foreach cmd $tkCon(slaveprocs) { tkConEvalAttached [dump proc $cmd] }
+ if [string match slave $type] {
+ foreach cmd $tkCon(slavealias) {
+ tkConMain interp alias $name $cmd $tkCon(name) $cmd
+ }
+ } else {
+ set name [tk appname]
+ foreach cmd $tkCon(slavealias) {
+ tkConEvalAttached "proc $cmd args { send [list $name] $cmd \$args }"
+ }
+ }
+ ## Catch in case it's a 7.4 (no 'interp alias') interp
+ tkConEvalAttached {catch {interp alias {} ls {} dir}}
+ return
+ } err
+ eval tkConAttach $old
+ if [string comp {} $err] { return -code error $err }
+}
+
## tkConInitUI - inits UI portion (console) of tkCon
## Creates all elements of the console window and sets up the text tags
# ARGS: root - widget pathname of the tkCon console root
set tkCon(base) $w
wm withdraw $root
+ option add *Menu.font $tkCon(font) widgetDefault
set tkCon(menubar) [frame $w.mbar -relief raised -bd 2]
set tkCon(console) [text $w.text -font $tkCon(font) -wrap char \
-yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin)]
set tkCon(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 \
-command "$w.text yview"]
- tkConInitMenus $tkCon(menubar)
+ tkConInitMenus $tkCon(menubar) $title
+ tkConBindings
if $tkCon(showmenu) { pack $tkCon(menubar) -fill x }
pack $tkCon(scrolly) -side $tkCon(scrollypos) -fill y
$w.text tag configure $col -foreground $tkCon(color,$col)
}
$w.text tag configure blink -background $tkCon(color,blink)
+ $w.text tag configure find -background $tkCon(color,blink)
bind $w.text <Configure> {
scan [wm geometry [winfo toplevel %W]] "%%dx%%d" tkCon(cols) tkCon(rows)
wm title $root "tkCon $tkCon(version) $title"
wm deiconify $root
- focus $w.text
+ focus -force $w.text
}
## tkConEval - evaluates commands input into console window
incr ev -1
if {[string match !! $cmd]} {
set err [catch {tkConEvalSlave history event $ev} cmd]
+ if !$err {$w insert output $cmd\n stdin}
} elseif [regexp {^!(.+)$} $cmd dummy event] {
set err [catch {tkConEvalSlave history event $event} cmd]
+ if !$err {$w insert output $cmd\n stdin}
} elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new] {
if ![set err [catch {tkConEvalSlave history event $ev} cmd]] {
regsub -all -- $old $cmd $new cmd
+ $w insert output $cmd\n stdin
}
}
}
}
} else {
if [catch [list tkConEvalAttached $cmd] res] {
- set tkCon(errorInfo) [tkConEvalAttached set errorInfo]
+ if [catch {tkConEvalAttached set errorInfo} err] {
+ set tkCon(errorInfo) {Error attempting to retrieve errorInfo}
+ } else {
+ set tkCon(errorInfo) $err
+ }
set err 1
}
}
}
}
tkConPrompt
- set tkCon(svnt) [set tkCon(event) [tkConEvalSlave history nextid]]
+ set tkCon(event) [tkConEvalSlave history nextid]
}
## tkConEvalSlave - evaluates the args in the associated slave
+## args should be passed to this procedure like they would be at
+## the command line (not like to 'eval').
# ARGS: args - the command and args to evaluate
##
proc tkConEvalSlave args {
interp eval $tkCon(exec) $args
}
+## tkConEvalOther - evaluate a command in a foreign interp or slave
+## without attaching to it. No check for existence is made.
+# ARGS: app - interp/slave name
+# type - (slave|interp)
+##
+proc tkConEvalOther {app type args} {
+ if [string match slave $type] {
+ if [string match Main $app] { set app {} }
+ tkConMain interp eval $app $args
+ } else {
+ eval send [list $app] $args
+ }
+}
+
## tkConEvalSend - sends the args to the attached interpreter
## Varies from 'send' by determining whether attachment is dead
## when an error is received
set code [catch {eval send [list $tkCon(app)] $args} result]
if {$code && [lsearch -exact [winfo interps] $tkCon(app)]<0} {
## Interpreter disappeared
- if [tk_dialog $tkCon(base).dead "Dead Attachment" \
- "\"$tkCon(app)\" appears to have died.\nReturn to primary slave interpreter?" questhead 0 OK No] {
+ if {[string compare leave $tkCon(dead)] && \
+ ([string match ignore $tkCon(dead)] || \
+ [tk_dialog $tkCon(base).dead "Dead Attachment" \
+ "\"$tkCon(app)\" appears to have died.\
+ \nReturn to primary slave interpreter?" questhead 0 OK No])} {
set tkCon(appname) "DEAD:$tkCon(appname)"
set tkCon(deadapp) 1
} else {
set err "Attached Tk interpreter \"$tkCon(app)\" died."
tkConAttach {}
+ set tkCon(deadapp) 0
tkConEvalSlave set errorInfo $err
}
tkConPrompt \n [tkConCmdGet $tkCon(console)]
# ARGS: w - console text widget
# Outputs: prompt (specified in tkCon(prompt1)) to console
##
-proc tkConPrompt {{pre {}} {post {}}} {
+proc tkConPrompt {{pre {}} {post {}} {prompt {}}} {
global tkCon
set w $tkCon(console)
if [string comp {} $pre] { $w insert end $pre stdout }
if [string comp {} $tkCon(appname)] {
$w insert end ">$tkCon(appname)< " prompt
}
- $w insert end [tkConEvalSlave subst $tkCon(prompt1)] prompt
+ if [string comp {} $prompt] {
+ $w insert end $prompt prompt
+ } else {
+ $w insert end [tkConEvalSlave subst $tkCon(prompt1)] prompt
+ }
$w mark set output $i
+ $w mark set insert end
$w mark set limit insert
$w mark gravity limit left
if [string comp {} $post] { $w insert end $post stdin }
global tkCon
tk_dialog $tkCon(base).about "About TkCon v$tkCon(version)" \
"Jeffrey Hobbs, Copyright 1995-96\njhobbs@cs.uoregon.edu\
- \nhttp://www.cs.uoregon.edu/~jhobbs/" questhead 0 OK
+ \nhttp://www.cs.uoregon.edu/~jhobbs/\
+ \nRelease Date: $tkCon(release)" questhead 0 OK
}
## tkConHelp - gives help info for tkCon
-##
+##
proc tkConHelp {} {
global tkCon
- tk_dialog $tkCon(base).help "Help on TkCon v$tkCon(version)" \
- "Jeffrey Hobbs, jhobbs@cs.uoregon.edu\nHelp available at:\
- http://www.cs.uoregon.edu/~jhobbs/work/tkcon/" questhead 0 OK
+ set page "http://www.cs.uoregon.edu/~jhobbs/work/tkcon/"
+ set email "jhobbs@cs.uoregon.edu"
+ if [tk_dialog $tkCon(base).help "Help on TkCon v$tkCon(version)" \
+ "Jeffrey Hobbs, $email\nHelp available at:\n$page" \
+ questhead 0 OK "Load into Netscape"] {
+ update
+ if {[catch {exec netscape -remote "openURL($page)"}]
+ && [catch {exec netscape $page &}]} {
+ warn "Couldn't launch Netscape.\nSorry."
+ }
+ }
}
-## tkConInitMenus - inits the menus for the console
+## tkConInitMenus - inits the menubar and popup for the console
# ARGS: w - console text widget
##
-proc tkConInitMenus w {
+proc tkConInitMenus {w title} {
global tkCon
- pack [menubutton $w.con -text Console -un 0 -menu $w.con.m] -side left
- pack [menubutton $w.edit -text Edit -un 0 -menu $w.edit.m] -side left
- #pack [menubutton $w.insp -text Inspect -un 0 -menu $w.insp.m] -side left
- pack [menubutton $w.pkgs -text Packages -un 0 -menu $w.pkgs.m] -side left
- pack [menubutton $w.pref -text Prefs -un 0 -menu $w.pref.m] -side left
- pack [menubutton $w.help -text Help -un 0 -menu $w.help.m] -side right
-
menu $w.pop -tearoff 0
- $w.pop add cascade -label Console -un 0 -menu $w.pop.con
- $w.pop add cascade -label Edit -un 0 -menu $w.pop.edit
- #$w.pop add cascade -label Inspect -un 0 -menu $w.pop.insp
- $w.pop add cascade -label Packages -un 0 -menu $w.pop.pkgs
- $w.pop add cascade -label Prefs -un 0 -menu $w.pop.pref
- $w.pop add cascade -label Help -un 0 -menu $w.pop.help
bind [winfo toplevel $w] <Button-3> "tk_popup $w.pop %X %Y"
+ pack [menubutton $w.con -text "Console" -un 0 -menu $w.con.m] -side left
+ $w.pop add cascade -label "Console" -un 0 -menu $w.pop.con
+
+ pack [menubutton $w.edit -text "Edit" -un 0 -menu $w.edit.m] -side left
+ $w.pop add cascade -label "Edit" -un 0 -menu $w.pop.edit
+
+ pack [menubutton $w.int -text "Interp" -un 0 -menu $w.int.m] -side left
+ $w.pop add cascade -label "Interp" -un 0 -menu $w.pop.int
+
+ pack [menubutton $w.pref -text "Prefs" -un 0 -menu $w.pref.m] -side left
+ $w.pop add cascade -label "Prefs" -un 0 -menu $w.pop.pref
+
+ pack [menubutton $w.help -text "Help" -un 0 -menu $w.help.m] -side right
+ $w.pop add cascade -label "Help" -un 0 -menu $w.pop.help
+
## Console Menu
##
- foreach m [list [menu $w.con.m] [menu $w.pop.con]] {
+ foreach m [list [menu $w.con.m -disabledfore $tkCon(color,prompt)] \
+ [menu $w.pop.con -disabledfore $tkCon(color,prompt)]] {
+ $m add command -label "$title Console" -state disabled
$m add command -label "New Console" -un 0 -acc Ctrl-N -com tkConNew
$m add command -label "Close Console " -un 0 -acc Ctrl-w -com tkConDestroy
+ $m add command -label "Clear Console " -un 1 -acc Ctrl-l \
+ -com { clear; tkConPrompt }
$m add separator
$m add cascade -label "Attach Console " -un 0 -menu $m.apps
$m add separator
- $m add command -label Quit -un 0 -acc Ctrl-q -command exit
+ $m add command -label "Quit" -un 0 -acc Ctrl-q -command exit
## Attach Console Menu
##
##
set text $tkCon(console)
foreach m [list [menu $w.edit.m] [menu $w.pop.edit]] {
- $m add command -label Cut -un 1 -acc Ctrl-x -command "tkConCut $text"
- $m add command -label Copy -un 1 -acc Ctrl-c -command "tkConCopy $text"
- $m add command -label Paste -un 0 -acc Ctrl-v -command "tkConPaste $text"
- }
-
- ## Inspect Menu
- ## Currently disabled
- foreach m {} {
- $m add command -label Procedures -command "tkConInspect procs"
- $m add command -label "Global Vars" -command "tkConInspect vars"
- $m add command -label Interpreters -command "tkConInspect interps"
- $m add command -label Aliases -command "tkConInspect aliases"
- $m add command -label Images -command "tkConInspect images"
- $m add command -label "All Widgets" -command "tkConInspect widgets"
- $m add command -label "Canvas Widgets" -command "tkConInspect canvases"
- $m add command -label "Menu Widgets" -command "tkConInspect menus"
- $m add command -label "Text Widgets" -command "tkConInspect texts"
- }
-
- ## Packages Menu
+ $m add command -label "Cut" -un 1 -acc Ctrl-x -command "tkConCut $text"
+ $m add command -label "Copy" -un 1 -acc Ctrl-c -command "tkConCopy $text"
+ $m add command -label "Paste" -un 0 -acc Ctrl-v -command "tkConPaste $text"
+ $m add separator
+ $m add command -label "Find" -un 0 -acc Ctrl-F \
+ -command "tkConFindBox $text"
+ }
+
+ ## Interp Menu
##
- menu $w.pkgs.m -disabledforeground $tkCon(color,prompt) \
- -postcommand "tkConCheckPackages $w.pkgs.m"
- menu $w.pop.pkgs -disabledforeground $tkCon(color,prompt) \
- -postcommand "tkConCheckPackages $w.pop.pkgs"
+ foreach m [list $w.int.m $w.pop.int] {
+ menu $m -disabledfore $tkCon(color,prompt) -postcom "tkConInterpMenu $m"
+ }
## Prefs Menu
##
## Scrollbar Menu
##
set m [menu $m.scroll -tearoff 0]
- $m add radio -label Left -var tkCon(scrollypos) -value left -command {
+ $m add radio -label "Left" -var tkCon(scrollypos) -value left -command {
pack config $tkCon(scrolly) -side left
}
- $m add radio -label Right -var tkCon(scrollypos) -value right -command {
+ $m add radio -label "Right" -var tkCon(scrollypos) -value right -command {
pack config $tkCon(scrolly) -side right
}
}
foreach m [list [menu $w.help.m] [menu $w.pop.help]] {
$m add command -label "About " -un 0 -acc Ctrl-A -command tkConAbout
$m add separator
- $m add command -label Help -un 0 -acc Ctrl-H -command tkConHelp
+ $m add command -label "Help" -un 0 -acc Ctrl-H -command tkConHelp
}
+}
- ## It's OK to bind to all because it's specific to each interpreter
- bind all <Control-q> exit
- bind all <Control-N> tkConNew
- bind all <Control-w> tkConDestroy
- bind all <Control-A> tkConAbout
- bind all <Control-H> tkConHelp
- bind all <Control-Key-1> {
- tkConAttach {}
- tkConPrompt \n [tkConCmdGet $tkCon(console)]
+## tkConInterpMenu - dynamically build the menu for attached interpreters
+##
+# ARGS: w - menu widget
+##
+proc tkConInterpMenu w {
+ global tkCon
+
+ if ![winfo exists $w] return
+ set i [tkConAttach]
+ set app [lindex $i 0]
+ set type [lindex $i 1]
+ $w delete 0 end
+ $w add command -label "[string toup $type]: $app" -state disabled
+ $w add separator
+ if {($tkCon(nontcl) && [string match interp $type]) || $tkCon(deadapp)} {
+ $w add command -state disabled -label "Communication disabled to"
+ $w add command -state disabled -label "dead or non-Tcl interps"
+ return
}
- bind all <Control-Key-2> {
- if [string comp {} $tkCon(name)] {
- tkConAttach $tkCon(name)
- } else {
- tkConAttach Main
+ $w add cascade -label Inspect -un 0 -menu $w.ins
+ $w add cascade -label Packages -un 0 -menu $w.pkg
+
+ set isnew [tkConEvalAttached expr \[info tclversion\]>7.4]
+ set hastk [tkConEvalAttached info exists tk_library]
+
+ ## Inspect Cascaded Menu
+ set m $w.ins
+ if [winfo exists $m] {
+ $m delete 0 end
+ } else {
+ menu $m -tearoff no -disabledfore $tkCon(color,prompt)
+ }
+ if [string comp {} [package provide TkConInspect]] {
+ $m add command -label "Procedures" \
+ -command [list tkConInspect $app $type procs]
+ $m add command -label "Global Vars" \
+ -command [list tkConInspect $app $type vars]
+ if $isnew {
+ $m add command -label "Interpreters" \
+ -command [list tkConInspect $app $type interps]
+ $m add command -label "Aliases" \
+ -command [list tkConInspect $app $type aliases]
+ }
+ if $hastk {
+ $m add separator
+ $m add command -label "All Widgets" \
+ -command [list tkConInspect $app $type widgets]
+ $m add command -label "Canvas Widgets" \
+ -command [list tkConInspect $app $type canvases]
+ $m add command -label "Menu Widgets" \
+ -command [list tkConInspect $app $type menus]
+ $m add command -label "Text Widgets" \
+ -command [list tkConInspect $app $type texts]
+ if $isnew {
+ $m add command -label "Images" \
+ -command [list tkConInspect $app $type images]
+ }
}
- tkConPrompt \n [tkConCmdGet $tkCon(console)]
}
- bind all <Control-Key-3> {
- tkConAttach Main
- tkConPrompt \n [tkConCmdGet $tkCon(console)]
+
+ ## Packages Cascaded Menu
+ ##
+ set m $w.pkg
+ if [winfo exists $m] { $m delete 0 end } else {
+ menu $m -tearoff no -disabledfore $tkCon(color,prompt)
}
-}
-## tkConCheckPackages - checks which packages are currently loaded
-## Requires two loops to make sure that packages which auto-load Tk
-## set everything properly.
-# ARGS: w - menu name
-##
-proc tkConCheckPackages {{w {}}} {
- global tkCon
- foreach pkg [lsort [lremove [package names] Tcl]] {
- if {![info exists tkCon(load$pkg)]} { set tkCon(load$pkg) 0 }
- if {$tkCon(load$pkg)==1} {
- if [catch {tkConEvalSlave package require $pkg}] {
- bgerror "$pkg cannot be loaded. Check your pkgIndex.tcl file!!!"
- set tkCon(load$pkg) -1
- }
+ foreach pkg [tkConEvalAttached [list info loaded {}]] {
+ set loaded([lindex $pkg 1]) {}
+ }
+ foreach pkg [info loaded] {
+ set pkg [lindex $pkg 1]
+ if ![info exists loaded($pkg)] {
+ set loadable($pkg) [list load {} $pkg]
}
}
- if [string comp {} [tkConEvalSlave info commands .]] { set tkCon(loadTk) 1 }
- if ![winfo exists $w] return
- $w delete 0 end
- foreach pkg [lsort [lremove [package names] Tcl]] {
- if {$tkCon(load$pkg)==-1} {
- $w add command -label "$pkg Load Failed" -state disabled
- } elseif $tkCon(load$pkg) {
- $w add command -label "$pkg Loaded" -state disabled
- } else {
- $w add checkbutton -label "Load $pkg" -var tkCon(load$pkg) \
- -command "tkConCheckPackages"
+ foreach pkg [lremove [tkConEvalAttached package names] Tcl] {
+ if ![info exists loaded($pkg)] {
+ set loadable($pkg) [list package require $pkg]
}
}
+ foreach pkg [array names loadable] {
+ $m add command -label "Load $pkg" \
+ -command "tkConEvalOther [list $app] $type $loadable($pkg)"
+ }
+ if {[info exists loaded] && [info exists loadable]} { $m add separator }
+ foreach pkg [array names loaded] {
+ $m add command -label "$pkg Loaded" -state disabled
+ }
+
+ ## Show Last Error
+ ##
+ $w add separator
+ $w add command -label "Show Last Error" \
+ -command "tkcon error [list $app] $type"
+
+ ## State Checkpoint/Revert
+ ##
+ $w add separator
+ $w add command -label "Checkpoint State" \
+ -command [list tkConStateCheckpoint $app $type]
+ $w add command -label "Revert State" \
+ -command [list tkConStateRevert $app $type]
+ $w add command -label "View State Change" \
+ -command [list tkConStateCompare $app $type]
+
+ ## Init Interp
+ ##
+ $w add separator
+ $w add command -label "Send TkCon Commands" \
+ -command [list tkConInitInterp $app $type]
}
## tkConFillAppsMenu - fill in in the applications sub-menu
proc tkConFillAppsMenu {m} {
global tkCon
- set self [tk appname]
- set masters [tkConMain set tkCon(interps)]
- set masternm [tkConSlave]
- foreach i $masternm {
- if [tkConSlave $i set tkCon(loadTk)] {
- lappend slaves [tkConSlave $i tkConEvalSlave tk appname]
- } else {
- lappend slaves "no Tk"
- }
- }
- set path [concat $tkCon(name) $tkCon(exec)]
- set tmp [tkConInterps]
- array set interps $tmp
- array set tknames [concat [lrange $tmp 1 end] [list [lindex $tmp 0]]]
+ array set interps [set tmp [tkConInterps]]
+ foreach {i j} $tmp { set tknames($j) {} }
catch {$m delete 0 last}
set cmd {tkConPrompt \n [tkConCmdGet $tkCon(console)]}
- $m add radio -label {None (use local slave) } -var tkCon(app) -value $path \
- -command "tkConAttach {}; $cmd" -acc Ctrl-1
+ $m add radio -label {None (use local slave) } -var tkCon(app) \
+ -value [concat $tkCon(name) $tkCon(exec)] -acc Ctrl-1 \
+ -command "tkConAttach {}; $cmd"
$m add separator
$m add command -label "Foreign Tk Interpreters" -state disabled
- foreach i [lsort [lremove [winfo interps] \
- [concat $masters $slaves [array names tknames]]]] {
+ foreach i [lsort [lremove [winfo interps] [array names tknames]]] {
$m add radio -label $i -var tkCon(app) -value $i \
-command "tkConAttach [list $i] interp; $cmd"
}
foreach i [lsort [array names interps]] {
if [string match {} $interps($i)] { set interps($i) "no Tk" }
if [regexp {^Slave[0-9]+} $i] {
- if [string comp $tkCon(name) $i] {
- $m add radio -label "$i ($interps($i))" -var tkCon(app) -value $i \
- -command "tkConAttach [list $i] slave; $cmd"
- } else {
- $m add radio -label "$i ($interps($i))" -var tkCon(app) -value $i \
- -acc Ctrl-2 \
- -command "tkConAttach [list $i] slave; $cmd"
- }
+ set opts [list -label "$i ($interps($i))" -var tkCon(app) -value $i \
+ -command "tkConAttach [list $i] slave; $cmd"]
+ if [string match $tkCon(name) $i] { append opts " -acc Ctrl-2" }
+ eval $m add radio $opts
} else {
set name [concat Main $i]
if [string match Main $name] {
}
}
+## tkConFindBox - creates minimal dialog interface to tkConFind
+# ARGS: w - text widget
+# str - optional seed string for tkCon(find)
+##
+proc tkConFindBox {w {str {}}} {
+ global tkCon
+
+ set base $tkCon(base).find
+ if ![winfo exists $base] {
+ toplevel $base
+ wm withdraw $base
+ wm title $base "TkCon Find"
+
+ pack [frame $base.f] -fill x -expand 1
+ label $base.f.l -text "Find:"
+ entry $base.f.e -textvar tkCon(find)
+ pack [frame $base.opt] -fill x
+ checkbutton $base.opt.c -text "Case Sensitive" -variable tkCon(find,case)
+ checkbutton $base.opt.r -text "Use Regexp" -variable tkCon(find,reg)
+ pack $base.f.l -side left
+ pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
+ pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
+ pack [frame $base.btn] -fill both
+ button $base.btn.fnd -text "Find" -width 6
+ button $base.btn.clr -text "Clear" -width 6
+ button $base.btn.dis -text "Dismiss" -width 6
+ eval pack [winfo children $base.btn] -padx 4 -pady 2 -side left -fill both
+
+ focus $base.f.e
+
+ bind $base.f.e <Return> [list $base.btn.fnd invoke]
+ bind $base.f.e <Escape> [list $base.btn.dis invoke]
+ }
+ $base.btn.fnd config -command "tkConFind $w \$tkCon(find)"
+ $base.btn.clr config -command "
+ $w tag remove find 1.0 end
+ set tkCon(find) {}
+ "
+ $base.btn.dis config -command "
+ $w tag remove find 1.0 end
+ wm withdraw $base
+ "
+ if [string comp {} $str] {
+ set tkCon(find) $str
+ $base.btn.fnd invoke
+ }
+
+ if {[string comp normal [wm state $base]]} {
+ wm deiconify $base
+ } else { raise $base }
+ $base.f.e select range 0 end
+}
+
+## tkConFind - searches in text widget $w for $str and highlights it
+## If $str is empty, it just deletes any highlighting
+# ARGS: w - text widget
+# str - string to search for
+##
+proc tkConFind {w str} {
+ global tkCon
+ $w tag remove find 1.0 end
+ ## FIX ; should accept -case and -regexp switches
+ if [string match {} $str] { return } else { set tkCon(find) $str }
+ $w mark set findmark 1.0
+ if $tkCon(find,case) { append opts {} } else { set opts {-nocase } }
+ if $tkCon(find,reg) { append opts -regexp } else { append opts -exact }
+ while {[string comp {} [set ix [eval $w search $opts -count numc -- \
+ [list $str] findmark end]]]} {
+ $w tag add find $ix ${ix}+${numc}c
+ $w mark set findmark ${ix}+1c
+ }
+ catch {$w see find.first}
+ return [expr [llength [$w tag ranges find]]/2]
+}
+
## tkConAttach - called to attach tkCon to an interpreter
# ARGS: an - application name to which tkCon sends commands
# This is either a slave interperter name or tk appname.
# Results: tkConEvalAttached is recreated to evaluate in the
# appropriate interpreter
##
-proc tkConAttach {an {type slave}} {
+proc tkConAttach {{an <NONE>} {type slave}} {
global tkCon
+ if [string match <NONE> $an] {
+ if [string match {} $tkCon(appname)] {
+ return [list [concat $tkCon(name) $tkCon(exec)] $tkCon(apptype)]
+ } else {
+ return [list $tkCon(appname) $tkCon(apptype)]
+ }
+ }
set app -
set path [concat $tkCon(name) $tkCon(exec)]
if [string comp {} $an] {
set an [concat $path $an]
set type slave
} elseif {[lsearch [winfo interps] $an] > -1} {
- if {$tkCon(loadTk) && [string match $an [tkConEvalSlave tk appname]]} {
+ if {[tkConEvalSlave info exists tk_library]
+ && [string match $an [tkConEvalSlave tk appname]]} {
set an {}
set app $path
set type slave
set type interp
}
} else {
- error "No known interpreter \"$an\""
+ return -code error "No known interpreter \"$an\""
}
} else {
set app $path
set tkCon(app) $app
set tkCon(appname) $an
set tkCon(apptype) $type
+ set tkCon(deadapp) 0
- ## tkConEvalAttached - evaluates the args in the attached interpreter
- ## This procedure is dynamic. It is rewritten by the proc tkConAttach
- ## to ensure it evals in the right place.
+ ## tkConEvalAttached - evaluates the args in the attached interp
+ ## args should be passed to this procedure as if they were being
+ ## passed to the 'eval' procedure. This procedure is dynamic to
+ ## ensure evaluation occurs in the right interp.
# ARGS: args - the command and args to evaluate
##
switch $type {
slave {
if [string match {} $an] {
- interp alias {} tkConEvalAttached {} tkConEvalSlave
+ interp alias {} tkConEvalAttached {} tkConEvalSlave eval
} elseif [string match Main $tkCon(app)] {
interp alias {} tkConEvalAttached {} tkConMain eval
} elseif [string match $tkCon(name) $tkCon(app)] {
interp alias {} tkConEvalAttached {} tkConEvalSend
}
}
- default { error "[lindex [info level 0] 0] did not specify type" }
+ default {
+ return -code error "[lindex [info level 0] 0] did not specify\
+ a valid type: must be slave or interp"
+ }
}
return
}
proc tkConLoad {{fn {}}} {
global tkCon
if {[string match {} $fn] &&
- ([catch {tkFileSelect} fn] || [string match {} $fn])} return
- tkConEvalAttached source $fn
+ ([catch {tk_getOpenFile} fn] || [string match {} $fn])} return
+ tkConEvalAttached [list source $fn]
}
## tkConSave - saves the console buffer to a file
proc tkConSave {{fn {}}} {
global tkCon
if {[string match {} $fn] &&
- ([catch {tkFileSelect} fn] || [string match {} $fn])} return
+ ([catch {tk_getSaveFile} fn] || [string match {} $fn])} return
if [catch {open $fn w} fid] {
- error "Save Error: Unable to open '$fn' for writing\n$fid"
+ return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
}
puts $fid [$tkCon(console) get 1.0 end-1c]
close $fid
}
-## tkConResource - re'source's this script into current console
-## Meant primarily for my development of this program. It's seems loopy
-## due to quirks in Tcl on windows.
-##
-set tkCon(SCRIPT) [info script]
-if [string match relative [file pathtype [info script]]] {
- set tkCon(SCRIPT) [file join [pwd] [info script]]
-}
-set tkCon(SCRIPT) [eval file join [file split $tkCon(SCRIPT)]]
-proc tkConResource {} "uplevel \#0 [list source $tkCon(SCRIPT)]; return"
-
## tkConMainInit
## This is only called for the main interpreter to include certain procs
## that we don't want to include (or rather, just alias) in slave interps.
set argv0 [list $argv0]
$tmp eval [list set tkCon(name) $tmp]
$tmp eval [list source $tkCon(SCRIPT)]
- $tmp alias tkConDestroy tkConDestroy $tmp
- $tmp alias tkConNew tkConNew
- $tmp alias tkConMain tkConInterpEval Main
- $tmp alias tkConSlave tkConInterpEval
- $tmp alias tkConInterps tkConInterps
+ $tmp alias tkConDestroy tkConDestroy $tmp
+ $tmp alias tkConNew tkConNew
+ $tmp alias tkConMain tkConInterpEval Main
+ $tmp alias tkConSlave tkConInterpEval
+ $tmp alias tkConInterps tkConInterps
+ $tmp alias tkConStateCheckpoint tkConStateCheckpoint
+ $tmp alias tkConStateCompare tkConStateCompare
+ $tmp alias tkConStateRevert tkConStateRevert
return $tmp
}
}
proc tkConInterps {{ls {}} {interp {}}} {
- if [string match {} $interp] { lappend ls {} [list [tk appname]] }
+ if [string match {} $interp] { lappend ls {} [tk appname] }
foreach i [interp slaves $interp] {
if [string comp {} $interp] { set i "$interp $i" }
- if [catch "interp eval [list $i] tk appname" name] {
- lappend ls $i {}
+ if [string comp {} [interp eval $i package provide Tk]] {
+ lappend ls $i [interp eval $i tk appname]
} else {
- lappend ls $i $name
+ lappend ls $i {}
}
set ls [tkConInterps $ls $i]
}
return $ls
}
-}
+ ##
+ ## The following state checkpoint/revert procedures are very sketchy
+ ## and prone to problems. They do not track modifications to currently
+ ## existing procedures/variables, and they can really screw things up
+ ## if you load in libraries (especially Tk) between checkpoint and
+ ## revert. Only with this knowledge in mind should you use these.
+ ##
-## 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) [tkConEvalAttached info commands *]
- set a(variables) [tkConEvalAttached info vars *]
- return
-}
+ ## FIX ; cleanup state data when attached app is deleted
-## 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)]"
-}
+ ## tkConStateCheckpoint - checkpoints the current state of the system
+ ## This allows you to return to this state with tkConStateRevert
+ # ARGS:
+ ##
+ proc tkConStateCheckpoint {app type} {
+ global tkCon
+ upvar \#0 tkCon($type,$app) a
+ if {[array exists a] &&
+ [tk_dialog $tkCon(base).warning "Overwrite Previous State?" \
+ "Are you sure you want to lose previously checkpointed state of $type \"$app\"?" \
+ questhead 1 "Do It" "Cancel"]} return
+ set a(cmd) [tkConEvalOther $app $type info comm *]
+ set a(var) [tkConEvalOther $app $type info vars *]
+ return
+ }
-## tkConStateRevert - reverts interpreter to a previous state
-# ARGS: ary - an array with checkpointed state
-##
-proc tkConStateRevert {ary} {
- upvar $ary a
- foreach i [lremove [tkConEvalAttached info commands *] $a(commands)] {
- catch "tkConEvalAttached rename $i {}"
+ ## tkConStateCompare - compare two states and output difference
+ # ARGS:
+ ##
+ proc tkConStateCompare {app type {verbose 0}} {
+ global tkCon
+ upvar \#0 tkCon($type,$app) a
+ if ![array exists a] {
+ return -code error "No previously checkpointed state for $type \"$app\""
+ }
+ set w $tkCon(base).compare
+ if [winfo exists $w] {
+ $w.text config -state normal
+ $w.text delete 1.0 end
+ } else {
+ toplevel $w
+ frame $w.btn
+ scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
+ text $w.text -font $tkCon(font) -yscrollcommand [list $w.sy set] \
+ -height 12
+ pack $w.btn -side bottom -fill x
+ pack $w.sy -side right -fill y
+ pack $w.text -fill both -expand 1
+ button $w.btn.close -text Dismiss -width 11 -command [list destroy $w]
+ button $w.btn.check -text Recheckpoint -width 11
+ button $w.btn.revert -text Revert -width 11
+ button $w.btn.expand -text Verbose -width 11
+ button $w.btn.update -text Update -width 11
+ pack $w.btn.check $w.btn.revert $w.btn.expand $w.btn.update \
+ $w.btn.close -side left -fill x -padx 4 -pady 2 -expand 1
+ $w.text tag config red -foreground red
+ }
+ wm title $w "Compare State: $type [list $app]"
+
+ $w.btn.check config -command "tkConStateCheckpoint [list $app] $type; \
+ tkConStateCompare [list $app] $type $verbose"
+ $w.btn.revert config -command "tkConStateRevert [list $app] $type; \
+ tkConStateCompare [list $app] $type $verbose"
+ $w.btn.update config -command [info level 0]
+ if $verbose {
+ $w.btn.expand config -text Brief \
+ -command [list tkConStateCompare $app $type 0]
+ } else {
+ $w.btn.expand config -text Verbose \
+ -command [list tkConStateCompare $app $type 1]
+ }
+ ## Don't allow verbose mode unless 'dump' exists in $app
+ ## We're assuming this is TkCon's dump command
+ set hasdump [string comp {} [tkConEvalOther $app $type info comm dump]]
+ if $hasdump {
+ $w.btn.expand config -state normal
+ } else {
+ $w.btn.expand config -state disabled
+ }
+
+ set cmds [lremove [tkConEvalOther $app $type info comm *] $a(cmd)]
+ set vars [lremove [tkConEvalOther $app $type info vars *] $a(var)]
+
+ if {$hasdump && $verbose} {
+ set cmds [tkConEvalOther $app $type eval dump c -nocomplain $cmds]
+ set vars [tkConEvalOther $app $type eval dump v -nocomplain $vars]
+ }
+ $w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \
+ $cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {}
+
+ raise $w
+ $w.text config -state disabled
}
- foreach i [lremove [tkConEvalAttached info vars *] $a(variables)] {
- catch "tkConEvalAttached unset $i"
+
+ ## tkConStateRevert - reverts interpreter to previous state
+ # ARGS:
+ ##
+ proc tkConStateRevert {app type} {
+ global tkCon
+ upvar \#0 tkCon($type,$app) a
+ if ![array exists a] {
+ return -code error "No previously checkpointed state for $type \"$app\""
+ }
+ if {![tk_dialog $tkCon(base).warning "Revert State?" \
+ "Are you sure you want to revert the state in $type \"$app\"?" \
+ questhead 1 "Do It" "Cancel"]} {
+ foreach i [lremove [tkConEvalOther $app $type info comm *] $a(cmd)] {
+ catch {tkConEvalOther $app $type rename $i {}}
+ }
+ foreach i [lremove [tkConEvalOther $app $type info vars *] $a(var)] {
+ catch {tkConEvalOther $app $type unset $i}
+ }
+ }
}
}
+## warn - little helper proc to pop up a tk_dialog warning message
+# ARGS: msg - message you want to display to user
+##
+proc warn { msg } {
+ bell
+ tk_dialog ._warning Warning $msg warning 0 OK
+}
## tkcon - command that allows control over the console
# ARGS: totally variable, see internal comments
##
-proc tkcon {args} {
- global tkCon
- switch -- [lindex $args 0] {
- close {
- ## Closes the console
+proc tkcon {cmd args} {
+ global tkCon errorInfo
+ switch -glob -- $cmd {
+ bg* {
+ ## 'bgerror' Brings up an error dialog
+ set errorInfo [lindex $args 1]
+ bgerror [lindex $args 0]
+ }
+ cl* {
+ ## 'close' Closes the console
tkConDestroy
}
- clean {
- ## 'cleans' the interpreter - reverting to original tkCon state
- ## FIX
- ## tkConStateRevert tkCon
+ con* {
+ ## 'console' - passes the args to the text widget of the console.
+ eval $tkCon(console) $args
}
- console {
- ## Passes the args to the text widget of the console.
- eval $tkCon(console) [lreplace $args 0 0]
- }
- error {
+ err* {
## Outputs stack caused by last error.
- if [string match {} $tkCon(errorInfo)] {
- set tkCon(errorInfo) {errorInfo empty}
- }
+ if {[llength $args]==2} {
+ set app [lindex $args 0]
+ set type [lindex $args 1]
+ if [catch {tkConEvalOther $app $type set errorInfo} info] {
+ set info "error getting info from $type $app:\n$info"
+ }
+ } else { set info $tkCon(errorInfo) }
+ if [string match {} $info] { set info {errorInfo empty} }
catch {destroy $tkCon(base).error}
set w [toplevel $tkCon(base).error]
- button $w.close -text Dismiss -command "destroy $w"
- scrollbar $w.sy -takefocus 0 -bd 1 -command "$w.text yview"
- text $w.text -font $tkCon(font) -yscrollcommand "$w.sy set"
+ wm title $w "TkCon Last Error"
+ button $w.close -text Dismiss -command [list destroy $w]
+ scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
+ text $w.text -font $tkCon(font) -yscrollcommand [list $w.sy set]
pack $w.close -side bottom -fill x
pack $w.sy -side right -fill y
pack $w.text -fill both -expand 1
- $w.text insert 1.0 $tkCon(errorInfo)
+ $w.text insert 1.0 $info
$w.text config -state disabled
}
- eval {
- ## evals contents in master interpreter
- eval [lreplace $args 0 0]
+ fi* {
+ ## 'find' string
+ tkConFind $tkCon(console) $args
}
- font {
- ## "tkcon font ?fontname?". Sets the font of the console
- if [string comp {} [lindex $args 1]] {
- return [$tkCon(console) config -font [lindex $args 1]]
+ fo* {
+ ## 'font' ?fontname? - gets/sets the font of the console
+ if [string comp {} $args] {
+ return [$tkCon(console) config -font $args]
} else {
return [$tkCon(console) config -font]
}
}
- hide {
- ## Hides the console with 'withdraw'.
+ get* {
+ ## 'gets' a replacement for [gets stdin varname]
+ ## This forces a complete command to be input though
+ set old [bind Console <Return>]
+ bind Console <Return> { set tkCon(wait) 0 }
+ bind Console <KP_Enter> { set tkCon(wait) 0 }
+ set w $tkCon(console)
+ vwait tkCon(wait)
+ set line [tkConCmdGet $tkCon(console)]
+ $w insert end \n
+ while {![info complete $line]} {
+ vwait tkCon(wait)
+ set line [tkConCmdGet $tkCon(console)]
+ $w insert end \n
+ }
+ bind Console <Return> $old
+ bind Console <KP_Enter> $old
+ if [string match {} $args] {
+ return $line
+ } else {
+ upvar [lindex $args 0] data
+ set data $line
+ return [string length $line]
+ }
+ }
+ hid* {
+ ## 'hide' - hides the console with 'withdraw'.
wm withdraw $tkCon(root)
}
- iconify {
- ## Iconifies the console with 'iconify'.
+ his* {
+ ## 'history'
+ set sub {\2}
+ if [string match -n* $args] { append sub "\n" }
+ set h [tkConEvalSlave history]
+ regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h
+ return $h
+ }
+ ico* {
+ ## 'iconify' - iconifies the console with 'iconify'.
wm iconify $tkCon(root)
}
- show - deiconify {
- ## "tkcon show|deiconify". Deiconifies the console.
+ mas* - eval {
+ ## 'master' - evals contents in master interpreter
+ uplevel \#0 $args
+ }
+ set {
+ ## 'set' - set (or get, or unset) simple variables (not whole arrays)
+ ## from the master console interpreter
+ ## possible formats:
+ ## tkcon set <var>
+ ## tkcon set <var> <value>
+ ## tkcon set <var> <interp> <var1> <var2> w
+ ## tkcon set <var> <interp> <var1> <var2> u
+ ## tkcon set <var> <interp> <var1> <var2> r
+ if {[llength $args]==5} {
+ ## This is for use with 'tkcon upvar' and only works with slaves
+ set var [lindex $args 0]
+ set i [lindex $args 1]
+ set var1 [lindex $args 2]
+ set var2 [lindex $args 3]
+ if [string compare {} $var2] { append var1 "($var2)" }
+ set op [lindex $args 4]
+ switch $op {
+ u { uplevel \#0 [list unset $var] }
+ w {
+ return [uplevel \#0 set \{$var\} [interp eval $i set \{$var1\}]]
+ }
+ r {
+ return [interp eval $i set \{$var1\} [uplevel \#0 set \{$var\}]]
+ }
+ }
+ }
+ return [uplevel \#0 set $args]
+ }
+ sh* - dei* {
+ ## 'show|deiconify' - deiconifies the console.
wm deiconify $tkCon(root)
+ raise $tkCon(root)
}
- title {
- ## "tkcon title ?title?". Retitles the console
- if [string comp {} [lindex $args 1]] {
- return [wm title $tkCon(root) [lindex $args 1]]
+ ti* {
+ ## 'title' ?title? - gets/sets the console's title
+ if [string comp {} $args] {
+ return [wm title $tkCon(root) $args]
} else {
return [wm title $tkCon(root)]
}
}
- version {
+ u* {
+ ## 'upvar' masterVar slaveVar
+ ## link slave variable slaveVar to the master variable masterVar
+ ## only works masters<->slave
+ set masterVar [lindex $args 0]
+ set slaveVar [lindex $args 1]
+ if [info exists $masterVar] {
+ interp eval $tkCon(exec) [list set $myVar [set $masterVar]]
+ } else {
+ catch {interp eval $tkCon(exec) [list unset $myVar]}
+ }
+ interp eval $tkCon(exec) [list trace variable $myVar rwu \
+ [list tkcon set $masterVar $tkCon(exec)]]
+ return
+ }
+ v* {
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]
+ set new tkCon[string toup [string index $cmd 0]][string range $cmd 1 end]
+ if [string comp {} [info command $new]] {
+ uplevel \#0 $new $args
} else {
- error "bad option \"[lindex $args 0]\": must be attach, close,\
- console, destroy, eval, font, hide, iconify,\
- load, main, new, save, show, slave, deiconify, title"
+ return -code error "bad option \"$cmd\": must be\
+ [join [lsort [list attach close console destroy font hide \
+ iconify load main master new save show slave deiconify \
+ version title bgerror]] {, }]"
}
}
}
# 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
+if ![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 tkcon console insert output [lreplace $args 0 1] $tmp
+ eval tcl_puts $args
}
- tkcon console see output
- } else {
- eval tcl_puts $args
}
}
+## echo
+## Relaxes the one string restriction of 'puts'
+# ARGS: any number of strings to output to stdout
+##
+proc echo args { puts [concat $args] }
+
## 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)"
+ return -code error \
+ "invalid percentage to clear: must be 1-100 (100 default)"
} elseif {$pcnt == 100} {
tkcon console delete 1.0 end
} else {
if [string match {} $newcmd] {
set res {}
foreach a [interp aliases] {
- lappend res [list $a: [interp alias {} $a]]
+ lappend res [list $a -> [interp alias {} $a]]
}
return [join $res \n]
} elseif {[string match {} $args]} {
interp alias {} $newcmd
} else {
- eval interp alias {{}} $newcmd {{}} $args
+ eval interp alias [list {} $newcmd {}] $args
}
}
set args [lreplace $args 0 0]
}
if {$whine && [string match {} $args]} {
- error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?"
+ return -code error "wrong \# args:\
+ [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?"
}
set res {}
switch -glob -- $type {
+ c* {
+ # command
+ # outpus commands by figuring out, as well as possible, what it is
+ # this does not attempt to auto-load anything
+ foreach arg $args {
+ if [string comp {} [set cmds [info comm $arg]]] {
+ foreach cmd [lsort $cmds] {
+ if {[lsearch -exact [interp aliases] $cmd] > -1} {
+ append res "\#\# ALIAS: $cmd => [interp alias {} $cmd]\n"
+ } elseif [string comp {} [info procs $cmd]] {
+ if {[catch {dump p $cmd} msg] && $whine} { set code error }
+ append res $msg\n
+ } else {
+ append res "\#\# COMMAND: $cmd\n"
+ }
+ }
+ } elseif $whine {
+ append res "\#\# No known command $arg\n"
+ set code error
+ }
+ }
+ }
v* {
# variable
# outputs variables value(s), whether array or simple.
foreach var [lsort $vars] {
upvar $var v
if {[array exists v]} {
+ set nest {}
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 }
+ upvar 0 v\($i\) __ary
+ if {[array exists __ary]} {
+ append nest "\#\# NESTED ARRAY ELEMENT: $i\n"
+ append nest "upvar 0 $var\($i\) __ary; [dump v __ary]\n"
+ #if $whine { set code error }
} else {
append res " [list $i $v($i)]\n"
}
}
- append res "\}\n"
+ append res "\}\n$nest"
} else {
append res [list set $var $v]\n
}
p* {
# procedure
foreach arg $args {
- if {[string comp {} [set ps [info proc $arg]]]} {
+ if {[string comp {} [set ps [info proc $arg]]] ||
+ ([auto_load $arg] &&
+ [string comp {} [set ps [info proc $arg]]])} {
foreach p [lsort $ps] {
set as {}
foreach a [info args $p] {
}
} elseif $whine {
append res "\#\# No known proc $arg\n"
+ set code error
}
}
}
w* {
# widget
+ ## The user should have Tk loaded
+ if [string match {} [info command winfo]] {
+ return -code error "winfo not present, cannot dump widgets"
+ }
+ foreach arg $args {
+ if [string comp {} [set ws [info command $arg]]] {
+ foreach w [lsort $ws] {
+ if [winfo exists $w] {
+ if [catch {$w configure} cfg] {
+ append res "\#\# Widget $w does not support configure method"
+ set code error
+ } else {
+ append res "\#\# [winfo class $w] $w\n$w configure"
+ foreach c $cfg {
+ if {[llength $c] != 5} continue
+ append res " \\\n\t[list [lindex $c 0] [lindex $c 4]]"
+ }
+ append res \n
+ }
+ }
+ }
+ } elseif $whine {
+ append res "\#\# No known widget $arg\n"
+ set code error
+ }
+ }
}
default {
return -code error "bad [lindex [info level 0] 0] option\
- \"[lindex $args 0]\":\ must be procedure, variable, widget"
+ \"$type\":\ must be procedure, variable, widget"
}
}
return -code $code [string trimr $res \n]
}
+## idebug - interactive debugger
+# ARGS: opt
+#
+##
+proc idebug {opt args} {
+ global IDEBUG
+
+ if ![info exists IDEBUG(on)] { array set IDEBUG { on 0 id * debugging 0 } }
+ set level [expr [info level]-1]
+ switch -glob -- $opt {
+ on {
+ if [string comp {} $args] { set IDEBUG(id) $args }
+ return [set IDEBUG(on) 1]
+ }
+ off { return [set IDEBUG(on) 0] }
+ id {
+ if [string match {} $args] {
+ return $IDEBUG(id)
+ } else { return [set IDEBUG(id) $args] }
+ }
+ break {
+ if {!$IDEBUG(on) || $IDEBUG(debugging) || ([string comp {} $args] \
+ && ![string match $IDEBUG(id) $args]) || [info level]<1} return
+ set IDEBUG(debugging) 1
+ puts stderr "idebug at level \#$level: [lindex [info level -1] 0]"
+ set tkcon [string comp {} [info command tkcon]]
+ if $tkcon {
+ tkcon show
+ set prompt [tkcon set tkCon(debugPrompt)]
+ set slave [tkcon set tkCon(exec)]
+ set event [tkcon set tkCon(event)]
+ tkcon set tkCon(exec) [tkcon master interp create debugger]
+ tkcon set tkCon(event) 1
+ }
+ set max $level
+ while 1 {
+ set err {}
+ if $tkcon {
+ tkcon prompt {} {} [subst $prompt]
+ set line [tkcon gets]
+ tkcon console mark set output end
+ } else {
+ puts -nonewline stderr "(level \#$level) debug > "
+ gets stdin line
+ while {![info complete $line]} {
+ puts -nonewline "> "
+ append line "\n[gets stdin]"
+ }
+ }
+ if [string match {} $line] continue
+ set key [lindex $line 0]
+ if ![regexp {^([\#-]?[0-9]+)} [lreplace $line 0 0] lvl] {
+ set lvl \#$level
+ }
+ set res {}; set c 0
+ switch -- $key {
+ + {
+ ## Allow for jumping multiple levels
+ if {$level < $max} { idebug trace [incr level] $level 0 VERBOSE }
+ }
+ - {
+ ## Allow for jumping multiple levels
+ if {$level > 1} { idebug trace [incr level -1] $level 0 VERBOSE }
+ }
+ . { set c [catch { idebug trace $level $level 0 VERBOSE } res] }
+ v { set c [catch { idebug show vars $lvl } res] }
+ V { set c [catch { idebug show vars $lvl VERBOSE } res] }
+ l { set c [catch { idebug show locals $lvl } res] }
+ L { set c [catch { idebug show locals $lvl VERBOSE } res] }
+ g { set c [catch { idebug show globals $lvl } res] }
+ G { set c [catch { idebug show globals $lvl VERBOSE } res] }
+ t { set c [catch { idebug trace 1 $max $level } res] }
+ T { set c [catch { idebug trace 1 $max $level VERBOSE } res] }
+ b { set c [catch { idebug body $lvl } res] }
+ o { set res [set IDEBUG(on) [expr !$IDEBUG(on)]] }
+ h - ? {
+ puts stderr " + Move down in call stack
+ - Move up in call stack
+ . Show current proc name and params
+
+ v Show names of variables currently in scope
+ V Show names of variables currently in scope with values
+ l Show names of local (transient) variables
+ L Show names of local (transient) variables with values
+ g Show names of declared global variables
+ G Show names of declared global variables with values
+ t Show a stack trace
+ T Show a verbose stack trace
+
+ b Show body of current proc
+ o Toggle on/off any further debugging
+ c,q Continue regular execution (Quit debugger)
+ h,? Print this help
+ default Evaluate line at current level (\#$level)"
+ }
+ c - q break
+ default { set c [catch {uplevel \#$level $line} res] }
+ }
+ if $tkcon {
+ tkcon set tkCon(event) \
+ [tkcon evalSlave eval history add [list $line] \; history nextid]
+ }
+ if $c { puts stderr $res } elseif {[string comp {} $res]} { puts $res }
+ }
+ set IDEBUG(debugging) 0
+ if $tkcon {
+ tkcon master interp delete debugger
+ tkcon set tkCon(exec) $slave
+ tkcon set tkCon(event) $event
+ }
+ }
+ bo* {
+ if [regexp {^([\#-]?[0-9]+)} $args level] {
+ return [uplevel $level { dump com -no [lindex [info level 0] 0] }]
+ }
+ }
+ t* {
+ if {[llength $args]<2} return
+ set min [set max [set lvl $level]]
+ if ![regexp {^\#?([0-9]+)? ?\#?([0-9]+) ?\#?([0-9]+)? ?(VERBOSE)?} \
+ $args junk min max lvl verbose] return
+ for {set i $max} {
+ $i>=$min && ![catch {uplevel \#$i info level 0} info]
+ } {incr i -1} {
+ if {$i==$lvl} {
+ puts -nonewline stderr "* \#$i:\t"
+ } else {
+ puts -nonewline stderr " \#$i:\t"
+ }
+ set name [lindex $info 0]
+ if {[string comp VERBOSE $verbose] || \
+ [string match {} [info procs $name]]} {
+ puts $info
+ } else {
+ puts "proc $name {[info args $name]} { ... }"
+ set idx 0
+ foreach arg [info args $name] {
+ if [string match args $arg] {
+ puts "\t$arg = [lrange $info [incr idx] end]"; break
+ } else {
+ puts "\t$arg = [lindex $info [incr idx]]"
+ }
+ }
+ }
+ }
+ }
+ s* {
+ #var, local, global
+ set level \#$level
+ if ![regexp {^([vgl][^ ]*) ?([\#-]?[0-9]+)? ?(VERBOSE)?} \
+ $args junk type level verbose] return
+ switch -glob -- $type {
+ v* { set vars [uplevel $level {lsort [info vars]}] }
+ l* { set vars [uplevel $level {lsort [info locals]}] }
+ g* { set vars [lremove [uplevel $level {info vars}] \
+ [uplevel $level {info locals}]] }
+ }
+ if [string match VERBOSE $verbose] {
+ return [uplevel $level dump var -nocomplain $vars]
+ } else {
+ return $vars
+ }
+ }
+ e* - pu* {
+ if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} {
+ set id [lindex [info level 0] 0]
+ } else {
+ set id [lindex $opt 1]
+ }
+ if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} {
+ if [string match e* $opt] {
+ puts [concat $args]
+ } else { eval puts $args }
+ }
+ }
+ default {
+ return -code error "bad [lindex [info level 0] 0] option \"$opt\":\
+ must be [join [lsort [list on off id break print body trace \
+ show puts echo]] {, }]"
+ }
+ }
+}
+
+## observe - like trace, but not
+# ARGS: opt - option
+# name - name of variable or command
+##
+proc observe {opt name args} {
+ global tcl_observe
+ switch -glob -- $opt {
+ co* {
+ if [regexp {^(set|puts|for|incr|info|uplevel)$} $name] {
+ return -code error \
+ "cannot observe \"$name\": infinite eval loop will occur"
+ }
+ set old ${name}@
+ while {[string comp {} [info command $old]]} { append old @ }
+ rename $name $old
+ set max 4
+ regexp {^[0-9]+} $args max
+ ## idebug trace could be used here
+ proc $name args "
+ for {set i \[info level\]; set max \[expr \[info level\]-$max\]} {
+ \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\]
+ } {incr i -1} {
+ puts -nonewline stderr \" \#\$i:\t\"
+ puts \$info
+ }
+ uplevel \[lreplace \[info level 0\] 0 0 $old\]
+ "
+ set tcl_observe($name) $old
+ }
+ cd* {
+ if {[info exists tcl_observe($name)] && [catch {
+ rename $name {}
+ rename $tcl_observe($name) $name
+ unset tcl_observe($name)
+ } err]} { return -code error $err }
+ }
+ ci* {
+ ## What a useless method...
+ if [info exists tcl_observe($name)] {
+ set i $tcl_observe($name)
+ set res "\"$name\" observes true command \"$i\""
+ while {[info exists tcl_observe($i)]} {
+ append res "\n\"$name\" observes true command \"$i\""
+ set i $tcl_observe($name)
+ }
+ return $res
+ }
+ }
+ va* - vd* {
+ set type [lindex $args 0]
+ set args [lrange $args 1 end]
+ if ![regexp {^[rwu]} $type type] {
+ return -code error "bad [lindex [info level 0] 0] $opt type\
+ \"$type\": must be read, write or unset"
+ }
+ if [string match {} $args] { set args observe_var }
+ uplevel [list trace $opt $name $type $args]
+ }
+ vi* {
+ uplevel [list trace vinfo $name]
+ }
+ default {
+ return -code error "bad [lindex [info level 0] 0] option\
+ \"[lindex $args 0]\": must be [join [lsort [list procedure \
+ pdelete pinfo variable vdelete vinfo]] {, }]"
+ }
+ }
+}
+
+## observe_var - auxilary function for observing vars, called by trace
+## via observe
+# ARGS: name - variable name
+# el - array element name, if any
+# op - operation type (rwu)
+##
+proc observe_var {name el op} {
+ if [string match u $op] {
+ if [string comp {} $el] {
+ puts "unset \"$name\($el\)\""
+ } else {
+ puts "unset \"$name\""
+ }
+ } else {
+ upvar \#0 $name $name
+ if [info exists $name\($el\)] {
+ puts [dump v $name\($el\)]
+ } else {
+ puts [dump v $name]
+ }
+ }
+}
+
## 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 {[string comp {} [info commands $cmd]] ||
+ ([auto_load $cmd] && [string comp {} [info commands $cmd]])} {
if {[lsearch -exact [interp aliases] $cmd] > -1} {
return "$cmd:\taliased to [alias $cmd]"
} elseif [string comp {} [info procs $cmd]] {
} elseif [auto_execok $cmd] {
return [auto_execpath $cmd]
} else {
- return "$cmd:\tunknown command"
+ return -code error "$cmd:\tunknown command"
}
}
##
proc dir {args} {
array set s {
- all 0 full 0 long 0 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
+ all 0 full 0 long 0
+ 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
}
while {[string match \-* [lindex $args 0]]} {
set str [lindex $args 0]
set args [lreplace $args 0 0]
switch -glob -- $str {
- -a* {set s(all) 1} -f* {set s(full) 1} -l* {set s(long) 1} -- break
+ -a* {set s(all) 1} -f* {set s(full) 1}
+ -l* {set s(long) 1} -- break
default {
- error "Passed unknown arg $str, should be one of: -all, -full, -long"
+ return -code error \
+ "unknown option \"$str\", should be one of: -all, -full, -long"
}
}
}
}
}
set i [expr $i+2+$s(full)]
- set j [expr [tkcon eval set tkCon(cols)]/$i]
+ ## This gets the number of cols in the TkCon console widget
+ set j [expr [tkcon master set tkCon(cols)]/$i]
set k 0
foreach f [lindex $o 1] {
set f [file tail $f]
}
return [string trimr $res]
}
-
+interp alias {} ls {} dir
## tclindex - creates the tclIndex file
# OPTS: -ext - extensions to auto index (defaults to *.tcl)
+# -pkg - whether to create a pkgIndex.tcl file
+# -idx - whether to create a tclIndex file
# ARGS: args - directories to auto index (defaults to pwd)
# Outputs: tclIndex file to each directory
##
proc tclindex args {
- set ext {*.tcl}
- if [string match \-e* [lindex $args 0]] {
- set ext [lindex $args 1]
- set args [lreplace $args 0 1]
+ set truth {^(1|yes|true|on)$}; set pkg 0; set idx 1;
+ while {[regexp -- {^-[^ ]+} $args opt] && [string comp {} $args]} {
+ switch -glob -- $opt {
+ -- { set args [lreplace $args 0 0]; break }
+ -e* {
+ set ext [lindex $args 1]
+ set args [lreplace $args 0 1]
+ }
+ -p* {
+ set pkg [regexp -nocase $truth [lindex $args 1]]
+ set args [lreplace $args 0 1]
+ }
+ -i* {
+ set idx [regexp -nocase $truth [lindex $args 1]]
+ set args [lreplace $args 0 1]
+ }
+ default {
+ return -code error "bad option \"$opt\": must be one of\
+ [join [lsort [list -- -extension -package -index]] {, }]"
+ }
+ }
+ }
+ if ![info exists ext] {
+ set ext {*.tcl}
+ if $pkg { lappend ext *[info sharedlibextension] }
}
if [string match {} $args] {
- eval auto_mkindex [list [pwd]] $ext
+ if $idx { eval auto_mkindex [list [pwd]] $ext }
+ if $pkg { eval pkg_mkIndex [list [pwd]] $ext }
} else {
foreach dir $args {
- if [file isdir $dir] { eval auto_mkindex [list $dir] $ext }
+ if [file isdir $dir] {
+ if $idx { eval auto_mkindex [list [pwd]] $ext }
+ if $pkg { eval pkg_mkIndex [list [pwd]] $ext }
+ }
}
}
}
## 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
+# args items to remove
##
proc lremove {args} {
set all 0
set l [lreplace $l $ix $ix]
if $all {
while {[set ix [lsearch -exact $l $i]] != -1} {
- set l [lreplace $l $i $i]
+ set l [lreplace $l $ix $ix]
}
}
}
+ idebug break
return $l
}
-
## Unknown changed to get output into tkCon window
# unknown:
+# Invoked automatically whenever an unknown command is encountered.
+# Works through a list of "unknown handlers" that have been registered
+# to deal with unknown commands. Extensions can integrate their own
+# handlers into the "unknown" facility via "unknown_handle".
+#
+# If a handler exists that recognizes the command, then it will
+# take care of the command action and return a valid result or a
+# Tcl error. Otherwise, it should return "-code continue" (=2)
+# and responsibility for the command is passed to the next handler.
+#
+# Arguments:
+# args - A list whose elements are the words of the original
+# command, including the command name.
+
+proc unknown args {
+ global unknown_handler_order unknown_handlers errorInfo errorCode
+
+ #
+ # Be careful to save error info now, and restore it later
+ # for each handler. Some handlers generate their own errors
+ # and disrupt handling.
+ #
+ set savedErrorCode $errorCode
+ set savedErrorInfo $errorInfo
+
+ if {![info exists unknown_handler_order] || ![info exists unknown_handlers]} {
+ set unknown_handlers(tcl) tcl_unknown
+ set unknown_handler_order tcl
+ }
+
+ foreach handler $unknown_handler_order {
+ set status [catch {uplevel $unknown_handlers($handler) $args} result]
+
+ if {$status == 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 $status -errorcode $errorCode \
+ -errorinfo $new $result
+
+ } elseif {$status != 4} {
+ return -code $status $result
+ }
+
+ set errorCode $savedErrorCode
+ set errorInfo $savedErrorInfo
+ }
+
+ set name [lindex $args 0]
+ return -code error "invalid command name \"$name\""
+}
+
+# tcl_unknown:
# Invoked when a Tcl command is invoked that doesn't exist in the
# interpreter:
#
# args - A list whose elements are the words of the original
# command, including the command name.
-proc unknown args {
+proc tcl_unknown args {
global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon
global errorCode errorInfo
set unknown_pending($name) pending;
set ret [catch {auto_load $name} msg]
unset unknown_pending($name);
- if {$ret != 0} {
+ if $ret {
return -code $ret -errorcode $errorCode \
"error while autoloading \"$name\": $msg"
}
}
}
}
- return -code error "invalid command name \"$name\""
-}
-
-
-#-------------------------------------------------------------------------
-# Elements of tkPriv that are used in this file:
-#
-# char - Character position on the line; kept in order
-# to allow moving up or down past short lines while
-# still remembering the desired position.
-# mouseMoved - Non-zero means the mouse has moved a significant
-# amount since the button went down (so, for example,
-# start dragging out a selection).
-# prevPos - Used when moving up or down lines via the keyboard.
-# Keeps track of the previous insert position, so
-# we can distinguish a series of ups and downs, all
-# in a row, from a new up or down.
-# selectMode - The style of selection currently underway:
-# char, word, or line.
-# x, y - Last known mouse coordinates for scanning
-# and auto-scanning.
-#-------------------------------------------------------------------------
-
-# 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 tkConClipboardKeysyms {copy cut paste} {
- bind Console <$copy> {tkConCopy %W}
- bind Console <$cut> {tkConCut %W}
- bind Console <$paste> {tkConPaste %W}
-}
+ return -code continue
+}
+
+proc tkConBindings {} {
+ global tkCon tcl_platform
+
+ ## FIX ; rewrite so that virtual events are used as well as preventing
+ ## the overwriting of user events
+
+ #-----------------------------------------------------------------------
+ # Elements of tkPriv that are used in this file:
+ #
+ # char - Character position on the line; kept in order
+ # to allow moving up or down past short lines while
+ # still remembering the desired position.
+ # mouseMoved - Non-zero means the mouse has moved a significant
+ # amount since the button went down (so, for example,
+ # start dragging out a selection).
+ # prevPos - Used when moving up or down lines via the keyboard.
+ # Keeps track of the previous insert position, so
+ # we can distinguish a series of ups and downs, all
+ # in a row, from a new up or down.
+ # selectMode - The style of selection currently underway:
+ # char, word, or line.
+ # x, y - Last known mouse coordinates for scanning
+ # and auto-scanning.
+ #-----------------------------------------------------------------------
+
+ switch -glob $tcl_platform(platform) {
+ win* { set tkCon(meta) Alt }
+ mac* { set tkCon(meta) Command }
+ default { set tkCon(meta) Meta }
+ }
+
+ ## <<TkCon_Exit>>
+ bind $tkCon(root) <Control-q> exit
+ ## <<TkCon_New>>
+ bind $tkCon(root) <Control-N> { tkConNew }
+ ## <<TkCon_Close>>
+ bind $tkCon(root) <Control-w> { tkConDestroy }
+ ## <<TkCon_About>>
+ bind $tkCon(root) <Control-A> { tkConAbout }
+ ## <<TkCon_Help>>
+ bind $tkCon(root) <Control-H> { tkConHelp }
+ ## <<TkCon_Find>>
+ bind $tkCon(root) <Control-F> { tkConFindBox $tkCon(console) }
+ ## <<TkCon_Slave>>
+ bind $tkCon(root) <Control-Key-1> {
+ tkConAttach {}
+ tkConPrompt "\n" [tkConCmdGet $tkCon(console)]
+ }
+ ## <<TkCon_Master>>
+ bind $tkCon(root) <Control-Key-2> {
+ if [string comp {} $tkCon(name)] {
+ tkConAttach $tkCon(name)
+ } else {
+ tkConAttach Main
+ }
+ tkConPrompt "\n" [tkConCmdGet $tkCon(console)]
+ }
+ ## <<TkCon_Main>>
+ bind $tkCon(root) <Control-Key-3> {
+ tkConAttach Main
+ tkConPrompt "\n" [tkConCmdGet $tkCon(console)]
+ }
-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}
+ ## Menu items need null PostCon bindings to avoid the TagProc
+ ##
+ foreach ev [bind $tkCon(root)] {
+ bind PostCon $ev {
+ # empty
+ }
+ }
+
+ # 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 tkConClipboardKeysyms {copy cut paste} {
+ bind Console <$copy> {tkConCopy %W}
+ bind Console <$cut> {tkConCut %W}
+ bind Console <$paste> {tkConPaste %W}
+ }
+
+ 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 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 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}
+ }
}
-}
-## Get all Text bindings into Console except Unix cut/copy/paste
-## and newline insertion
-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
+ ## Get all Text bindings into Console except Unix cut/copy/paste
+ ## and newline insertion
+ foreach ev [lremove [bind Text] {<Control-Key-y> <Control-Key-w> \
+ <Meta-Key-w> <Control-Key-o>}] {
+ bind Console $ev [bind Text $ev]
+ }
-## Redefine for Console what we need
-##
-tkConClipboardKeysyms F16 F20 F18
-tkConClipboardKeysyms Control-c Control-x Control-v
+ ## 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 <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) == [tkConEvalSlave history nextid]} {
- set tkCon(cmdbuf) [tkConCmdGet %W]
+ bind Console <Triple-1> {+
+ catch {
+ eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
+ %W mark set insert sel.first
}
- if [catch {tkConEvalSlave \
- history event [incr tkCon(event) -1]} tkCon(tmp)] {
- incr tkCon(event)
+ }
+
+ ## binding editor needed
+ ## binding <events> for .tkconrc
+
+ ## <<TkCon_Previous>>
+ bind Console <Up> {
+ if [%W compare {insert linestart} != {limit linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W -1]
} else {
- %W delete limit end
- %W insert limit $tkCon(tmp)
- %W see end
+ if {$tkCon(event) == [tkConEvalSlave history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ }
+ if [catch {tkConEvalSlave \
+ 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) < [tkConEvalSlave history nextid]} {
- %W delete limit end
- if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} {
- %W insert limit $tkCon(cmdbuf)
- } else {
- %W insert limit [tkConEvalSlave history event $tkCon(event)]
+ ## <<TkCon_Next>>
+ bind Console <Down> {
+ if [%W compare {insert linestart} != {end-1c linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W 1]
+ } else {
+ if {$tkCon(event) < [tkConEvalSlave history nextid]} {
+ %W delete limit end
+ if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} {
+ %W insert limit $tkCon(cmdbuf)
+ } else {
+ %W insert limit [tkConEvalSlave history event $tkCon(event)]
+ }
+ %W see end
}
- %W see end
}
}
-}
-bind Console <Tab> {
- if [%W compare insert > limit] {tkConExpand %W path}
-}
-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
+ ## <<TkCon_ExpandFile>>
+ bind Console <Tab> {
+ if [%W compare insert > limit] {tkConExpand %W path}
}
-}
-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
+ ## <<TkCon_ExpandProc>>
+ bind Console <Control-P> {
+ if [%W compare insert > limit] {tkConExpand %W proc}
}
-}
-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 > limit]} {
- %W delete insert-1c
- %W see insert
+ ## <<TkCon_ExpandVar>>
+ bind Console <Control-V> {
+ if [%W compare insert > limit] {tkConExpand %W var}
}
-}
-bind Console <Control-h> [bind Console <BackSpace>]
+ ## <<TkCon_Tab>>
+ bind Console <Control-i> {
+ if [%W compare insert >= limit] {
+ tkConInsert %W \t
+ }
+ }
+ ## <<TkCon_Eval>> - no mod
+ 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 > limit]} {
+ %W delete insert-1c
+ %W see insert
+ }
+ }
+ bind Console <Control-h> [bind Console <BackSpace>]
-bind Console <KeyPress> {
- tkConInsert %W %A
-}
+ 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-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}] {
+ bind Console <Control-d> {
+ if [%W compare insert < limit] break
%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 {} $tkCon(tmp)
-}
-bind Console <Control-n> {
- ## Goto next command in history
- if {$tkCon(event) < [tkConEvalSlave history nextid]} {
- %W delete limit end
- if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} {
- %W insert limit $tkCon(cmdbuf)
+ bind Console <Control-k> {
+ if [%W compare insert < limit] break
+ if [%W compare insert == {insert lineend}] {
+ %W delete insert
} else {
- %W insert limit [tkConEvalSlave history event $tkCon(event)]
+ %W delete insert {insert lineend}
}
- %W see end
- }
-}
-bind Console <Control-p> {
- ## Goto previous command in history
- if {$tkCon(event) == [tkConEvalSlave history nextid]} {
- set tkCon(cmdbuf) [tkConCmdGet %W]
}
- if [catch {tkConEvalSlave history event [incr tkCon(event) -1]} tkCon(tmp)] {
- incr tkCon(event)
- } else {
- %W delete limit end
- %W insert limit $tkCon(tmp)
- %W see end
+ ## <<TkCon_Clear>>
+ bind Console <Control-l> {
+ ## Clear console buffer, without losing current command line input
+ set tkCon(tmp) [tkConCmdGet %W]
+ clear
+ tkConPrompt {} $tkCon(tmp)
}
-}
-bind Console <Control-r> {
- ## Search history reverse
- if {$tkCon(svnt) == [tkConEvalSlave history nextid]} {
- set tkCon(cmdbuf) [tkConCmdGet %W]
- }
- set tkCon(tmp1) [string len $tkCon(cmdbuf)]
- incr tkCon(tmp1) -1
- while 1 {
- if {[catch {tkConEvalSlave \
- history event [incr tkCon(svnt) -1]} tkCon(tmp)]} {
- incr tkCon(svnt)
- break
- } elseif {![string comp $tkCon(cmdbuf) \
- [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
+ ## <<TkCon_NextImmediate>>
+ bind Console <Control-n> {
+ ## Goto next command in history
+ if {$tkCon(event) < [tkConEvalSlave history nextid]} {
%W delete limit end
- %W insert limit $tkCon(tmp)
- break
+ if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} {
+ %W insert limit $tkCon(cmdbuf)
+ } else {
+ %W insert limit [tkConEvalSlave history event $tkCon(event)]
+ }
+ %W see end
}
}
- %W see end
-}
-bind Console <Control-s> {
- ## Search history forward
- set tkCon(tmp1) [string len $tkCon(cmdbuf)]
- incr tkCon(tmp1) -1
- while {$tkCon(svnt) < [tkConEvalSlave history nextid]} {
- if {[incr tkCon(svnt)] == [tkConEvalSlave history nextid]} {
- %W delete limit end
- %W insert limit $tkCon(cmdbuf)
- break
- } elseif {![catch {tkConEvalSlave history event $tkCon(svnt)} tkCon(tmp)] \
- && ![string comp $tkCon(cmdbuf) \
- [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
+ ## <<TkCon_PreviousImmediate>>
+ bind Console <Control-p> {
+ ## Goto previous command in history
+ if {$tkCon(event) == [tkConEvalSlave history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ }
+ if [catch {tkConEvalSlave history event \
+ [incr tkCon(event) -1]} tkCon(tmp)] {
+ incr tkCon(event)
+ } else {
%W delete limit end
%W insert limit $tkCon(tmp)
- break
+ %W see end
}
}
- %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
+ ## <<TkCon_PreviousSearch>>
+ bind Console <Control-r> {
+ ## Search history reverse
+ if {$tkCon(event) == [tkConEvalSlave history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ } elseif 0 {
+ ## FIX
+ ## event ids get confusing (to user) when they 'cancel' a history
+ ## search. This should reassign the event id properly.
+ }
+ set tkCon(tmp1) [string len $tkCon(cmdbuf)]
+ incr tkCon(tmp1) -1
+ while 1 {
+ if {[catch {tkConEvalSlave history event \
+ [incr tkCon(event) -1]} tkCon(tmp)]} {
+ incr tkCon(event)
+ 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
}
- 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}
+ ## <<TkCon_NextSearch>>
+ bind Console <Control-s> {
+ ## Search history forward
+ set tkCon(tmp1) [string len $tkCon(cmdbuf)]
+ incr tkCon(tmp1) -1
+ while {$tkCon(event) < [tkConEvalSlave history nextid]} {
+ if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} {
+ %W delete limit end
+ %W insert limit $tkCon(cmdbuf)
+ break
+ } elseif {![catch {tkConEvalSlave history event \
+ $tkCon(event)} 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 <Meta-BackSpace> {
- if [%W compare {insert -1c wordstart} >= limit] {
- %W delete {insert -1c wordstart} insert
+ ## <<TkCon_Transpose>>
+ bind Console <Control-t> {
+ ## Transpose current and previous chars
+ if [%W compare insert > limit] { tkTextTranspose %W }
}
-}
-bind Console <Meta-Delete> {
- if [%W compare insert >= limit] {
- %W delete insert {insert wordend}
+ ## <<TkCon_ClearLine>>
+ bind Console <Control-u> {
+ ## Clear command line (Unix shell staple)
+ %W delete limit end
}
-}
-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)
+ ## <<TkCon_SaveCommand>>
+ bind Console <Control-z> {
+ ## Save command buffer (swaps with current command)
+ set tkCon(tmp) $tkCon(cmdsave)
+ set tkCon(cmdsave) [tkConCmdGet %W]
+ if {[string match {} $tkCon(cmdsave)]} {
+ set tkCon(cmdsave) $tkCon(tmp)
} else {
- %W insert @%x,%y $tkCon(tmp)
+ %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 <$tkCon(meta)-d> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+ }
+ bind Console <$tkCon(meta)-BackSpace> {
+ if [%W compare {insert -1c wordstart} >= limit] {
+ %W delete {insert -1c wordstart} insert
+ }
+ }
+ bind Console <$tkCon(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}
}
- if [string match *\n* $tkCon(tmp)] {tkConEval %W}
}
-}
-##
-## End weird bindings
-##
+ ##
+ ## End Console bindings
+ ##
-##
-## 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 \( \) limit
+ ##
+ ## 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 \( \) limit
+ }
}
-}
-bind PostCon <Key-bracketright> {
- if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
- [string comp \\ [%W get insert-2c]]} {
- tkConMatchPair %W \[ \] limit
+ bind PostCon <Key-bracketright> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchPair %W \[ \] limit
+ }
}
-}
-bind PostCon <Key-braceright> {
- if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
- [string comp \\ [%W get insert-2c]]} {
- tkConMatchPair %W \{ \} limit
+ bind PostCon <Key-braceright> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchPair %W \{ \} limit
+ }
}
-}
-bind PostCon <Key-quotedbl> {
- if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
- [string comp \\ [%W get insert-2c]]} {
- tkConMatchQuote %W limit
+ bind PostCon <Key-quotedbl> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchQuote %W limit
+ }
}
-}
-bind PostCon <KeyPress> {
- if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W }
+ bind PostCon <KeyPress> {
+ if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W }
+ }
}
## tkConTagProc - tags a procedure in the console if it's recognized
##
proc tkConExpand {w type} {
set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
- set tmp [$w search -back -regexp $exp insert limit]
+ 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]
$w insert $tmp [lindex $res 0]
if {$len > 1} {
global tkCon
- if {$tkCon(showmultiple) && [string match [lindex $res 0] $str]} {
+ if {$tkCon(showmultiple) && ![string comp [lindex $res 0] $str]} {
puts stdout [lreplace $res 0 0]
}
}
##
proc tkConExpandPathname str {
set pwd [tkConEvalAttached pwd]
- if [catch {tkConEvalAttached cd [file dir $str]} err] {
+ if [catch {tkConEvalAttached [list cd [file dirname $str]]} err] {
return -code error $err
}
if [catch {lsort [tkConEvalAttached glob [file tail $str]*]} m] {
if {[llength $m] > 1} {
set tmp [tkConExpandBestMatch $m [file tail $str]]
if [string match ?*/* $str] {
- set tmp [file dir $str]/$tmp
+ set tmp [file dirname $str]/$tmp
} elseif [string match /* $str] {
set tmp /$tmp
}
eval append match $m
if [file isdir $match] {append match /}
if [string match ?*/* $str] {
- set match [file dir $str]/$match
+ set match [file dirname $str]/$match
} elseif [string match /* $str] {
set match /$match
}
set match [list $match]
}
}
- tkConEvalAttached cd $pwd
+ tkConEvalAttached [list cd $pwd]
return $match
}
return $ec
}
+## tkConResource - re'source's this script into current console
+## Meant primarily for my development of this program. It follows
+## links until the ultimate source is found.
+##
+set tkCon(SCRIPT) [info script]
+while {[string match link [file type $tkCon(SCRIPT)]]} {
+ set link [file readlink $tkCon(SCRIPT)]
+ if [string match relative [file pathtype $link]] {
+ set tkCon(SCRIPT) [file join [file dirname $tkCon(SCRIPT)] $link]
+ } else {
+ set tkCon(SCRIPT) $link
+ }
+}
+if [string match relative [file pathtype $tkCon(SCRIPT)]] {
+ set tkCon(SCRIPT) [file join [pwd] $tkCon(SCRIPT)]
+}
+proc tkConResource {} {
+ global tkCon
+ uplevel \#0 [list source $tkCon(SCRIPT)]
+ tkConBindings
+ tkConInitSlave $tkCon(exec)
+}
## Initialize only if we haven't yet
##
projects / tkcon / commitdiff