From bcb9e1158b63d347a395f78b8a303c1b2bbf5f2d Mon Sep 17 00:00:00 2001 From: Jeff Hobbs Date: Tue, 19 Sep 2000 18:42:16 +0000 Subject: [PATCH] tkcon.tcl: updated v0.71 to v1.02 version, tagged tkcon-1-02 --- ChangeLog | 1 + tkcon.tcl | 5918 +++++++++++++++++++++++++++-------------------------- 2 files changed, 3062 insertions(+), 2857 deletions(-) diff --git a/ChangeLog b/ChangeLog index 4385d2b..75e9ad2 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,6 @@ 2000-09-19 Jeff Hobbs + * tkcon.tcl: updated v0.71 to v1.02 version, tagged tkcon-1-02 * tkcon.tcl: updated v0.69 to v0.71 version, tagged tkcon-0-71 * tkcon.tcl: updated v0.68 to v0.69 version, tagged tkcon-0-69 * tkcon.tcl: updated v0.67 to v0.68 version, tagged tkcon-0-68 diff --git a/tkcon.tcl b/tkcon.tcl index 55b7fdc..b0dbd0a 100755 --- a/tkcon.tcl +++ b/tkcon.tcl @@ -13,235 +13,253 @@ exec wish "$0" ${1+"$@"} ## Steven Wahl , Jan Nijtmans ## Crimmins , Wart ## -## Copyright 1995,1996 Jeffrey Hobbs +## Copyright 1995-1997 Jeffrey Hobbs ## Initiated: Thu Aug 17 15:36:47 PDT 1995 ## -## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/ +## jeff.hobbs@acm.org, http://www.cs.uoregon.edu/~jhobbs/ ## ## source standard_disclaimer.tcl ## source beer_ware.tcl ## +## FIX NOTES - ideas on the block: +## + if {$tcl_version>=8.0} { - package require Tk -} elseif {[catch {package require -exact Tk [expr $tcl_version-3.4]}]} { - return -code error \ - "TkCon requires at least the stable version of tcl7.5/tk4.1" + package require Tk +} elseif {[catch {package require -exact Tk [expr {$tcl_version-3.4}]}]} { + return -code error "TkCon requires at least Tcl7.6/Tk4.2" } foreach pkg [info loaded {}] { - set file [lindex $pkg 0] - set name [lindex $pkg 1] - if {![catch {set version [package require $name]}]} { - if {[string match {} [package ifneeded $name $version]]} { - package ifneeded $name $version "load [list $file $name]" + set file [lindex $pkg 0] + set name [lindex $pkg 1] + if {![catch {set version [package require $name]}]} { + if {[string match {} [package ifneeded $name $version]]} { + package ifneeded $name $version [list load $file $name] + } } - } } -catch {unset file name version} +catch {unset pkg file name version} -set tkCon(WWW) [info exists embed_args] +set TKCON(WWW) [info exists embed_args] ## 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 {} { - global auto_path tcl_platform env tcl_pkgPath \ - tkCon argc argv tcl_interactive - - set tcl_interactive 1 - - if [info exists tkCon(name)] { - set title $tkCon(name) - } else { - tkConMainInit - set title Main - } - - array set tkCon { - color,blink yellow - color,proc darkgreen - color,prompt brown - color,stdin black - color,stdout blue - color,stderr red - - blinktime 500 - debugPrompt {(level \#$level) debug [history nextid] > } - font fixed - history 32 - dead {} - library {} - lightbrace 1 - lightcmd 1 - autoload {} - maineval {} - nontcl 0 - rcfile .tkconrc - scrollypos right - showmultiple 1 - showmenu 1 - slaveeval {} - subhistory 1 - - exec slave app {} appname {} apptype slave cmd {} cmdbuf {} cmdsave {} - event 1 cols 80 rows 24 deadapp 0 debugging 0 histid 0 - find {} find,case 0 find,reg 0 - errorInfo {} - slavealias { tkcon } - slaveprocs { alias clear dir dump lremove puts echo tclindex idebug \ - unknown tcl_unknown unalias which observe observe_var auto_execok } - version 0.71 - release {December 1996} - root . - } - - if $tkCon(WWW) { - set tkCon(prompt1) {[history nextid] % } - } else { - set tkCon(prompt1) {([file tail [pwd]]) [history nextid] % } - } - - ## If there appear to be children of '.', then make sure we use - ## a disassociated toplevel. - if [string compare {} [winfo children .]] { - set tkCon(root) .tkcon - } - - if [string compare unix $tcl_platform(platform)] { - array set tkCon { - font {Courier 12 {}} - rcfile tkcon.cfg - } - } - - if [info exists env(HOME)] { - set tkCon(rcfile) [file join $env(HOME) $tkCon(rcfile)] - } - if 0 { - ## This would get the resource file from the right place - switch $tcl_platform(platform) { - macintosh { - set pref_folder $env(PREF_FOLDER) - cd [file dirname [info script]] - } - windows { set pref_folder $env(WINDIR) } - unix { set pref_folder $env(HOME) } - } - } - - ## Handle command line arguments before sourcing resource file to - ## find if resource file is being specified (let other args pass). - for {set i 0} {$i < $argc} {incr i} { - if [string match \-rcfile [lindex $argv $i]] { - set tkCon(rcfile) [lindex $argv [incr i]] - } - } - - if {!$tkCon(WWW) && [file exists $tkCon(rcfile)]} { - set code [catch [list uplevel \#0 source $tkCon(rcfile)] err] - } - - if [info exists env(TK_CON_LIBRARY)] { - eval lappend auto_path $env(TK_CON_LIBRARY) - } else { - eval lappend auto_path $tkCon(library) - } - - if {![info exists tcl_pkgPath]} { - set dir [file join [file dirname [info nameofexec]] lib] - if [string comp {} [info commands @scope]] { - set dir [file join $dir itcl] - } - catch {source [file join $dir pkgIndex.tcl]} - } - catch {tclPkgUnknown dummy-name dummy-version} - - ## Handle rest of command line arguments after sourcing resource file - ## 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 { - -- - -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 +;proc tkConInit {} { + global auto_path tcl_platform env tcl_pkgPath \ + TKCON argc argv tcl_interactive + + set tcl_interactive 1 + + if {[info exists TKCON(name)]} { + set title $TKCON(name) } else { - lappend slaveargs $arg - } - } - - ## Create slave executable - if [string comp {} $tkCon(exec)] { - eval tkConInitSlave $tkCon(exec) $slaveargs - } - - ## Attach to the slave, tkConEvalAttached will then be effective - tkConAttach $tkCon(appname) $tkCon(apptype) - tkConInitUI $title - - ## 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" } + tkConMainInit + set title Main + } + + array set TKCON { + color,blink \#FFFF00 + color,proc \#008800 + color,prompt \#8F4433 + color,stdin \#000000 + color,stdout \#0000FF + color,stderr \#FF0000 + + autoload {} + blinktime 500 + blinkrange 1 + calcmode 0 + cols 80 + debugPrompt {(level \#$level) debug [history nextid] > } + dead {} + expandorder {Pathname Variable Procname} + history 32 + library {} + lightbrace 1 + lightcmd 1 + maineval {} + nontcl 0 + rcfile .tkconrc + rows 20 + scrollypos right + showmenu 1 + showmultiple 1 + slaveeval {} + slaveexit close + subhistory 1 + + exec slave + app {} + appname {} + apptype slave + namesp :: + cmd {} + cmdbuf {} + cmdsave {} + event 1 + deadapp 0 + debugging 0 + histid 0 + find {} + find,case 0 + find,reg 0 + errorInfo {} + slavealias { tkcon } + slaveprocs { + alias auto_execok clear dir dump echo idebug lremove tkcon_puts + tclindex tcl_unknown observe observe_var unalias unknown which + } + version 1.02 + release {June 10 1997} + docs {http://www.cs.uoregon.edu/research/tcl/script/tkcon/} + email {jeff.hobbs@acm.org} + root . + } + + if {$TKCON(WWW)} { + set TKCON(prompt1) {[history nextid] % } } else { - puts stderr "error: package does not exist" - } - } - - ## Evaluate maineval in slave - if {[string comp {} $tkCon(maineval)] && - [catch {uplevel \#0 $tkCon(maineval)} merr]} { - puts stderr "error in eval:\n$merr" - } - - ## Source extra command line argument files into slave executable - foreach fn $slavefiles { - puts -nonewline "slave sourcing \"$fn\" ... " - if {[catch {tkConEvalSlave source $fn} fnerr]} { - puts stderr "error:\n$fnerr" - } else { puts "OK" } - } - - ## Evaluate slaveeval in slave - if {[string comp {} $tkCon(slaveeval)] && - [catch {interp eval $tkCon(exec) $tkCon(slaveeval)} 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]} { - if $code { - puts stderr "error in $tkCon(rcfile):\n$err" + set TKCON(prompt1) {([file tail [pwd]]) [history nextid] % } + } + + ## If there appear to be children of '.', then make sure we use + ## a disassociated toplevel. + if {[string compare {} [winfo children .]]} { + set TKCON(root) .tkcon + } + + ## Use tkcon.cfg filename for resource filename on non-unix systems + if {[string compare unix $tcl_platform(platform)]} { + set TKCON(rcfile) tkcon.cfg + } + + ## Determine what directory the resource file should be in + ## Windows could possibly use env(WINDIR) + switch $tcl_platform(platform) { + macintosh { + set envHome PREF_FOLDER + cd [file dirname [info script]] + } + windows - unix { set envHome HOME } + } + if {[info exists env($envHome)]} { + set TKCON(rcfile) [file join $env($envHome) $TKCON(rcfile)] + } + + ## Handle command line arguments before sourcing resource file to + ## find if resource file is being specified (let other args pass). + if {[set i [lsearch -exact $argv -rcfile]] != -1} { + set TKCON(rcfile) [lindex $argv [incr i]] + } + + if {!$TKCON(WWW) && [file exists $TKCON(rcfile)]} { + set code [catch [list uplevel \#0 source $TKCON(rcfile)] err] + } + + if {[info exists env(TK_CON_LIBRARY)]} { + uplevel \#0 lappend auto_path $env(TK_CON_LIBRARY) } else { - puts stdout "returned from $tkCon(rcfile):\n$err" + uplevel \#0 lappend auto_path $TKCON(library) } - } - tkConStateCheckpoint [concat $tkCon(name) $tkCon(exec)] slave - tkConStateCheckpoint $tkCon(name) slave + + if {![info exists tcl_pkgPath]} { + set dir [file join [file dirname [info nameofexec]] lib] + if {[string compare {} [info commands @scope]]} { + set dir [file join $dir itcl] + } + catch {source [file join $dir pkgIndex.tcl]} + } + catch {tclPkgUnknown dummy-name dummy-version} + + ## Handle rest of command line arguments after sourcing resource file + ## 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 { + -- - -argv { + set argv [concat -- [lrange $argv $i end]] + set argc [llength $argv] + break + } + -main - -e - -eval { append TKCON(maineval) \n$val\n } + -package - -load { lappend TKCON(autoload) $val } + -slave { append TKCON(slaveeval) \n$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 + } else { + lappend slaveargs $arg + } + } + + ## Create slave executable + if {[string compare {} $TKCON(exec)]} { + eval tkConInitSlave $TKCON(exec) $slaveargs + } + + ## Attach to the slave, tkConEvalAttached will then be effective + tkConAttach $TKCON(appname) $TKCON(apptype) + tkConInitUI $title + + ## rename puts to tcl_puts now so that all further 'puts' go to the + ## console window + if {![catch {rename puts tcl_puts}]} { + interp alias {} puts {} tkcon_puts + } + + ## 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 [list $pkg]} pkgerr]} { + puts stderr "error:\n$pkgerr" + } else { puts "OK" } + } else { + puts stderr "error: package does not exist" + } + } + + ## Evaluate maineval in slave + if {[string compare {} $TKCON(maineval)] && \ + [catch {uplevel \#0 $TKCON(maineval)} merr]} { + puts stderr "error in eval:\n$merr" + } + + ## Source extra command line argument files into slave executable + foreach fn $slavefiles { + puts -nonewline "slave sourcing \"$fn\" ... " + if {[catch {tkConEvalSlave source [list $fn]} fnerr]} { + puts stderr "error:\n$fnerr" + } else { puts "OK" } + } + + ## Evaluate slaveeval in slave + if {[string compare {} $TKCON(slaveeval)] && \ + [catch {interp eval $TKCON(exec) $TKCON(slaveeval)} serr]} { + puts stderr "error in slave eval:\n$serr" + } + ## Output any error/output that may have been returned from rcfile + if {[info exists code] && $code && [string compare {} $err]} { + puts stderr "error in $TKCON(rcfile):\n$err" + } + tkConStateCheckpoint [concat $TKCON(name) $TKCON(exec)] slave + tkConStateCheckpoint $TKCON(name) slave } ## tkConInitSlave - inits the slave by placing key procs and aliases in it @@ -250,46 +268,48 @@ proc tkConInit {} { # ARGS: slave - name of slave to init. If it does not exist, it is created. # args - args to pass to a slave as argv/argc ## -proc tkConInitSlave {slave args} { - global tkCon argv0 tcl_interactive tcl_library env - if [string match {} $slave] { - return -code error "Don't init the master interpreter, goofball" - } - if ![interp exists $slave] { interp create $slave } - if {[interp eval $slave info command source] == ""} { - $slave alias source tkConSafeSource $slave - $slave alias load tkConSafeLoad $slave - $slave alias open tkConSafeOpen $slave - $slave alias exit exit - $slave alias file file - interp eval $slave [dump var tcl_library env] - interp eval $slave [list source [file join $tcl_library init.tcl]] - } - 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) \; { - 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 \ - [package ifneeded $pkg $v]] - } - } +;proc tkConInitSlave {slave args} { + global TKCON argv0 tcl_interactive tcl_library env + if {[string match {} $slave]} { + return -code error "Don't init the master interpreter, goofball" + } + if {![interp exists $slave]} { interp create $slave } + if {[interp eval $slave info command source] == ""} { + $slave alias source tkConSafeSource $slave + $slave alias load tkConSafeLoad $slave + $slave alias open tkConSafeOpen $slave + $slave alias exit exit + $slave alias file file + interp eval $slave [dump var tcl_library env] + interp eval $slave { catch {source [file join $tcl_library init.tcl]} } + interp eval $slave { catch unknown } + } + interp eval $slave { catch {rename puts tcl_puts} } + foreach cmd $TKCON(slaveprocs) { $slave eval [dump proc $cmd] } + foreach cmd $TKCON(slavealias) { $slave alias $cmd $cmd } + interp alias $slave ls $slave dir + interp alias $slave puts $slave tkcon_puts + interp eval $slave set tcl_interactive $tcl_interactive \; \ + set argv0 [list $argv0] \; set argc [llength $args] \; \ + 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 \ + [package ifneeded $pkg $v]] + } + } } ## tkConInitInterp - inits an interpreter by placing key @@ -297,32 +317,40 @@ proc tkConInitSlave {slave args} { # 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 } +;proc tkConInitInterp {name type} { + global TKCON + ## Don't allow messing up a local master interpreter + if {[string match namespace $type] || ([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] } + switch -exact $type { + slave { + foreach cmd $TKCON(slavealias) { + tkConMain interp alias $name $cmd $TKCON(name) $cmd + } + } + interp { + 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 -full}} + tkConEvalAttached { + if {[catch {interp alias {} puts {} tkcon_puts}]} { + catch {rename tkcon_puts puts} + } + } + return + } {err} + eval tkConAttach $old + if {[string compare {} $err]} { return -code error $err } } ## tkConInitUI - inits UI portion (console) of tkCon @@ -331,45 +359,49 @@ proc tkConInitInterp {name type} { # title - title for the console root and main (.) windows # Calls: tkConInitMenus, tkConPrompt ## -proc tkConInitUI {title} { - global tkCon - - set root $tkCon(root) - if [string match . $root] { set w {} } else { set w [toplevel $root] } - catch {wm withdraw $root} - set tkCon(base) $w - - ## Menus - option add *Menu.font $tkCon(font) widgetDefault - set tkCon(menubar) [frame $w.mbar -relief raised -bd 2] - set tkCon(console) [set con [text $w.text -font $tkCon(font) -wrap char \ - -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin) \ - -width $tkCon(cols) -height $tkCon(rows)]] - bindtags $con "$con PreCon Console PostCon $root all" - set tkCon(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 -command "$con yview"] - - tkConInitMenus $tkCon(menubar) $title - tkConBindings - - if $tkCon(showmenu) { pack $tkCon(menubar) -fill x } - pack $w.sy -side $tkCon(scrollypos) -fill y - pack $con -fill both -expand 1 - - tkConPrompt "$title console display active\n" - - foreach col {prompt stdout stderr stdin proc} { - $con tag configure $col -foreground $tkCon(color,$col) - } - $con tag configure blink -background $tkCon(color,blink) - $con tag configure find -background $tkCon(color,blink) - - if ![catch {wm title $root "tkCon $tkCon(version) $title"}] { - bind $con { - scan [wm geometry [winfo toplevel %W]] "%%dx%%d" tkCon(cols) tkCon(rows) +;proc tkConInitUI {title} { + global TKCON + + set root $TKCON(root) + if {[string match . $root]} { set w {} } else { set w [toplevel $root] } + catch {wm withdraw $root} + set TKCON(base) $w + + ## Menus + set TKCON(menubar) [frame $w.mbar -relief raised -bd 2] + ## Text Console + set TKCON(console) [set con [text $w.text -wrap char \ + -yscrollcommand [list $w.sy set] -setgrid 1 \ + -foreground $TKCON(color,stdin) \ + -width $TKCON(cols) -height $TKCON(rows)]] + bindtags $con [list $con PreCon TkConsole PostCon $root all] + ## Scrollbar + set TKCON(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 \ + -command [list $con yview]] + + tkConInitMenus $TKCON(menubar) $title + tkConBindings + + if {$TKCON(showmenu)} { pack $TKCON(menubar) -fill x } + pack $w.sy -side $TKCON(scrollypos) -fill y + pack $con -fill both -expand 1 + + tkConPrompt "$title console display active\n" + + foreach col {prompt stdout stderr stdin proc} { + $con tag configure $col -foreground $TKCON(color,$col) + } + $con tag configure blink -background $TKCON(color,blink) + $con tag configure find -background $TKCON(color,blink) + + if {![catch {wm title $root "TkCon $TKCON(version) $title"}]} { + bind $con { + scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \ + TKCON(cols) TKCON(rows) + } + wm deiconify $root } - wm deiconify $root - } - focus -force $tkCon(console) + focus -force $TKCON(console) } ## tkConEval - evaluates commands input into console window @@ -380,18 +412,19 @@ proc tkConInitUI {title} { # 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 +;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 @@ -401,62 +434,64 @@ proc tkConEval {w} { # 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 [string comp {} $cmd] { - set err 0 - if $tkCon(subhistory) { - set ev [tkConEvalSlave history nextid] - 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 - } - } - } - if $err { - $w insert output $cmd\n stderr - } else { - if [string match {} $tkCon(appname)] { - if [catch {tkConEvalSlave eval $cmd} res] { - set tkCon(errorInfo) [tkConEvalSlave set errorInfo] - set err 1 - } - } else { - if {$tkCon(nontcl) && [string match interp $tkCon(apptype)]} { - if [catch "tkConEvalSend $cmd" res] { - set tkCon(errorInfo) {Non-Tcl errorInfo not available} - set err 1 - } +;proc tkConEvalCmd {w cmd} { + global TKCON + $w mark set output end + if {[string compare {} $cmd]} { + set code 0 + if {$TKCON(subhistory)} { + set ev [tkConEvalSlave history nextid] + incr ev -1 + if {[string match !! $cmd]} { + set code [catch {tkConEvalSlave history event $ev} cmd] + if {!$code} {$w insert output $cmd\n stdin} + } elseif {[regexp {^!(.+)$} $cmd dummy event]} { + ## Check last event because history event is broken + set code [catch {tkConEvalSlave history event $ev} cmd] + if {!$code && ![string match ${event}* $cmd]} { + set code [catch {tkConEvalSlave history event $event} cmd] + } + if {!$code} {$w insert output $cmd\n stdin} + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { + set code [catch {tkConEvalSlave history event $ev} cmd] + if {!$code} { + regsub -all -- $old $cmd $new cmd + $w insert output $cmd\n stdin + } + } elseif {$TKCON(calcmode) && ![catch {expr $cmd} err]} { + tkConEvalSlave history add $cmd + set cmd $err + set code -1 + } + } + if {$code} { + $w insert output $cmd\n stderr } else { - if [catch [list tkConEvalAttached $cmd] res] { - if [catch {tkConEvalAttached set errorInfo} err] { - set tkCon(errorInfo) {Error attempting to retrieve errorInfo} + if {$TKCON(nontcl) && [string match interp $TKCON(apptype)]} { + set code [catch "tkConEvalSend $cmd" res] + if {$code == 1} { + set TKCON(errorInfo) "Non-Tcl errorInfo not available" + } } else { - set tkCon(errorInfo) $err + set code [catch {tkConEvalAttached $cmd} res] + if {$code == 1} { + if {[catch {tkConEvalAttached {set errorInfo}} err]} { + set TKCON(errorInfo) "Error getting errorInfo:\n$err" + } else { + set TKCON(errorInfo) $err + } + } + } + tkConEvalSlave history add $cmd + if {$code} { + $w insert output $res\n stderr + } elseif {[string compare {} $res]} { + $w insert output $res\n stdout } - set err 1 - } } - } - tkConEvalSlave history add $cmd - if $err { - $w insert output $res\n stderr - } elseif {[string comp {} $res]} { - $w insert output $res\n stdout - } } - } - tkConPrompt - set tkCon(event) [tkConEvalSlave history nextid] + tkConPrompt + set TKCON(event) [tkConEvalSlave history nextid] } ## tkConEvalSlave - evaluates the args in the associated slave @@ -464,9 +499,9 @@ proc tkConEvalCmd {w cmd} { ## the command line (not like to 'eval'). # ARGS: args - the command and args to evaluate ## -proc tkConEvalSlave args { - global tkCon - interp eval $tkCon(exec) $args +;proc tkConEvalSlave args { + global TKCON + interp eval $TKCON(exec) $args } ## tkConEvalOther - evaluate a command in a foreign interp or slave @@ -474,13 +509,13 @@ proc tkConEvalSlave args { # 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 - } +;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 @@ -489,47 +524,91 @@ proc tkConEvalOther {app type args} { # ARGS: args - the args to send across # Returns: the result of the command ## -proc tkConEvalSend args { - global tkCon - if $tkCon(deadapp) { - if {[lsearch -exact [winfo interps] $tkCon(app)]<0} { - return - } else { - set tkCon(appname) [string range $tkCon(appname) 5 end] - set tkCon(deadapp) 0 - tkConPrompt "\n\"$tkCon(app)\" alive\n" [tkConCmdGet $tkCon(console)] - } - } - set code [catch {eval send [list $tkCon(app)] $args} result] - if {$code && [lsearch -exact [winfo interps] $tkCon(app)]<0} { - ## Interpreter disappeared - 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 +;proc tkConEvalSend args { + global TKCON + if {$TKCON(deadapp)} { + if {[lsearch -exact [winfo interps] $TKCON(app)]<0} { + return + } else { + set TKCON(appname) [string range $TKCON(appname) 5 end] + set TKCON(deadapp) 0 + tkConPrompt "\n\"$TKCON(app)\" alive\n" \ + [tkConCmdGet $TKCON(console)] + } + } + set code [catch {eval send [list $TKCON(app)] $args} result] + if {$code && [lsearch -exact [winfo interps] $TKCON(app)]<0} { + ## Interpreter disappeared + 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)] + } + return -code $code $result +} + +## tkConEvalNamespace - evaluates the args in a particular namespace +## This is an override for tkConEvalAttached for when the user wants +## to attach to a particular namespace of the attached interp +# ARGS: attached +# namespace the namespace to evaluate in +# args the args to evaluate +# RETURNS: the result of the command +## +;proc tkConEvalNamespace { attached namespace args } { + global TKCON + if {[string compare {} $args]} { + uplevel \#0 $attached namespace [list $namespace $args] + } +} + +## tkConNamespaces - return all the namespaces descendent from $ns +## +# +## +;proc tkConNamespaces { {ns ::} } { + global TKCON + if {$TKCON(A:itcl)} { + return [tkConNamespacesItcl $ns] } else { - set err "Attached Tk interpreter \"$tkCon(app)\" died." - tkConAttach {} - set tkCon(deadapp) 0 - tkConEvalSlave set errorInfo $err + return [tkConNamespacesTcl8 $ns] + } +} + +;proc tkConNamespacesTcl8 { ns {l {}} } { + if {[string compare {} $ns]} { lappend l $ns } + foreach i [tkConEvalAttached [list namespace children $ns]] { + set l [tkConNamespacesTcl8 $i $l] } - tkConPrompt \n [tkConCmdGet $tkCon(console)] - } - return -code $code $result + return $l +} + +;proc tkConNamespacesItcl { ns {l {}} } { + if {[string compare {} $ns]} { lappend l $ns } + set names [tkConEvalAttached [list info namespace children $ns]] + foreach i $names { set l [tkConNamespacesItcl $i $l] } + return $l } ## 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] - } +;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 @@ -539,431 +618,471 @@ proc tkConCmdGet w { # 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 +;proc tkConCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if {[string compare {} $tmp]} { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } } - if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { - lappend cmds $tmp - set tmp {} + if {[string compare {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] } - } - 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 +# Outputs: prompt (specified in TKCON(prompt1)) to console ## -proc tkConPrompt {{pre {}} {post {}} {prompt {}}} { - global tkCon - set w $tkCon(console) - if [string comp {} $pre] { $w insert end $pre stdout } - set i [$w index end-1c] - if [string comp {} $tkCon(appname)] { - $w insert end ">$tkCon(appname)< " 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 } - $w see end -} - -## FIX - place these in state disabled text widgets. +;proc tkConPrompt {{pre {}} {post {}} {prompt {}}} { + global TKCON + set w $TKCON(console) + if {[string compare {} $pre]} { $w insert end $pre stdout } + set i [$w index end-1c] + if {[string compare {} $TKCON(appname)]} { + $w insert end ">$TKCON(appname)< " prompt + } + if {[string compare :: $TKCON(namesp)]} { + $w insert end "<$TKCON(namesp)> " prompt + } + if {[string compare {} $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 compare {} $post]} { $w insert end $post stdin } + $w see end +} + ## tkConAbout - gives about info for tkCon ## -proc tkConAbout {} { - 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/\ - \nRelease Date: v$tkCon(version), $tkCon(release)" questhead 0 OK +;proc tkConAbout {} { + global TKCON + set w $TKCON(base).about + if {[winfo exists $w]} { + wm deiconify $w + } else { + global tk_patchLevel tcl_patchLevel tcl_platform + toplevel $w + wm title $w "About TkCon v$TKCON(version)" + button $w.b -text Dismiss -command [list wm withdraw $w] + text $w.text -height 9 -bd 1 -width 60 + pack $w.b -fill x -side bottom + pack $w.text -fill both -side left -expand 1 + $w.text tag config center -justify center + if {[string compare unix $tcl_platform(platform)] \ + || [info tclversion] >= 8} { + $w.text tag config title -justify center -font {Courier 18 bold} + } else { + $w.text tag config title -justify center -font *Courier*Bold*18* + } + $w.text insert 1.0 "About TkCon v$TKCON(version)\n\n" title \ + "Copyright 1995-1997 Jeffrey Hobbs, $TKCON(email)\ + \nhttp://www.cs.uoregon.edu/~jhobbs/\ + \nRelease Date: v$TKCON(version), $TKCON(release)\ + \nDocumentation available at:\n$TKCON(docs)\ + \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center + $w.text config -state disabled + } } -## tkConHelp - gives help info for tkCon -## -proc tkConHelp {} { - global tkCon - 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 &}]} { - tk_dialog $tkCon(base).dialog "Couldn't exec Netscape" \ - "Couldn't exec Netscape.\nMake sure it's in your path" \ - warning 0 Bummer - } - } -} ## tkConInitMenus - inits the menubar and popup for the console # ARGS: w - console text widget ## -proc tkConInitMenus {w title} { - global tkCon +;proc tkConInitMenus {w title} { + global TKCON - if [catch {menu $w.pop -tearoff 0}] { - label $w.label -text "Menus not available in plugin mode" - pack $w.label - return - } - bind [winfo toplevel $w] "tk_popup $w.pop %X %Y" + if {[catch {menu $w.pop -tearoff 0}]} { + label $w.label -text "Menus not available in plugin mode" + pack $w.label + return + } + bind [winfo toplevel $w] "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.file -text "File" -und 0 -menu $w.file.m] -side left + $w.pop add cascade -label "File" -und 0 -menu $w.pop.file - 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.con -text "Console" -und 0 -menu $w.con.m] -side left + $w.pop add cascade -label "Console" -und 0 -menu $w.pop.con - 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.edit -text "Edit" -und 0 -menu $w.edit.m] -side left + $w.pop add cascade -label "Edit" -und 0 -menu $w.pop.edit - 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.int -text "Interp" -und 0 -menu $w.int.m] -side left + $w.pop add cascade -label "Interp" -und 0 -menu $w.pop.int - pack [menubutton $w.hist -text "History" -un 0 -menu $w.hist.m] -side left - $w.pop add cascade -label "History" -un 0 -menu $w.pop.hist + pack [menubutton $w.pref -text "Prefs" -und 0 -menu $w.pref.m] -side left + $w.pop add cascade -label "Prefs" -und 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 + pack [menubutton $w.hist -text "History" -und 0 -menu $w.hist.m] -side left + $w.pop add cascade -label "History" -und 0 -menu $w.pop.hist - ## Console Menu - ## - 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 + pack [menubutton $w.help -text "Help" -und 0 -menu $w.help.m] -side right + $w.pop add cascade -label "Help" -und 0 -menu $w.pop.help - ## Attach Console Menu + ## File Menu ## - menu $m.apps -disabledforeground $tkCon(color,prompt) \ - -postcommand "tkConFillAppsMenu $m.apps" - } - - ## Edit 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" - $m add separator - $m add command -label "Find" -un 0 -acc Ctrl-F \ - -command "tkConFindBox $text" - } - - ## Interp Menu - ## - foreach m [list $w.int.m $w.pop.int] { - menu $m -disabledfore $tkCon(color,prompt) -postcom "tkConInterpMenu $m" - } - - ## Prefs Menu - ## - foreach m [list [menu $w.pref.m] [menu $w.pop.pref]] { - $m add checkbutton -label "Brace Highlighting" -var tkCon(lightbrace) - $m add checkbutton -label "Command Highlighting" -var tkCon(lightcmd) - $m add checkbutton -label "History Substitution" -var tkCon(subhistory) - $m add checkbutton -label "Non-Tcl Attachments" -var tkCon(nontcl) - $m add checkbutton -label "Show Multiple Matches" -var tkCon(showmultiple) - $m add checkbutton -label "Show Menubar" -var tkCon(showmenu) \ - -command "if \$tkCon(showmenu) { \ - pack $w -fill x -before $tkCon(console) -before $tkCon(scrolly) \ - } else { pack forget $w }" - $m add cascade -label Scrollbar -un 0 -menu $m.scroll - - ## Scrollbar Menu + foreach m [list [menu $w.file.m -disabledfore $TKCON(color,prompt)] \ + [menu $w.pop.file -disabledfore $TKCON(color,prompt)]] { + $m add command -label "Load File" -und 0 -command tkConLoad + $m add cascade -label "Save ..." -und 0 -menu $m.save + $m add separator + $m add command -label "Quit" -und 0 -accel Ctrl-q -command exit + + ## Save Menu + ## + set s $m.save + menu $s -disabledforeground $TKCON(color,prompt) -tearoff 0 + $s add command -label "All" -und 0 -command {tkConSave {} all} + $s add command -label "History" -und 0 -command {tkConSave {} history} + $s add command -label "Stdin" -und 3 -command {tkConSave {} stdin} + $s add command -label "Stdout" -und 3 -command {tkConSave {} stdout} + $s add command -label "Stderr" -und 3 -command {tkConSave {} stderr} + } + + ## Console Menu ## - set m [menu $m.scroll -tearoff 0] - $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 { - pack config $tkCon(scrolly) -side right + 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" -und 0 -accel Ctrl-N \ + -command tkConNew + $m add command -label "Close Console" -und 0 -accel Ctrl-w \ + -command tkConDestroy + $m add command -label "Clear Console" -und 1 -accel Ctrl-l \ + -command { clear; tkConPrompt } + $m add separator + $m add cascade -label "Attach Console" -und 0 -menu $m.apps + $m add cascade -label "Attach Namespace" -und 1 -menu $m.name + + ## Attach Console Menu + ## + menu $m.apps -disabledforeground $TKCON(color,prompt) \ + -postcommand [list tkConAttachMenu $m.apps] + + ## Attach Namespace Menu + ## + menu $m.name -disabledforeground $TKCON(color,prompt) -tearoff 0 \ + -postcommand [list tkConNamespaceMenu $m.name] + } + + ## Edit Menu + ## + set text $TKCON(console) + foreach m [list [menu $w.edit.m] [menu $w.pop.edit]] { + $m add command -label "Cut" -underline 2 -accel Ctrl-x \ + -command "tkConCut $text" + $m add command -label "Copy" -underline 0 -accel Ctrl-c \ + -command "tkConCopy $text" + $m add command -label "Paste" -underline 0 -accel Ctrl-v \ + -command "tkConPaste $text" + $m add separator + $m add command -label "Find" -underline 0 -accel Ctrl-F \ + -command "tkConFindBox $text" + } + + ## Interp Menu + ## + foreach m [list $w.int.m $w.pop.int] { + menu $m -disabledforeground $TKCON(color,prompt) \ + -postcommand [list tkConInterpMenu $m] } - } - ## History Menu - ## - foreach m [list $w.hist.m $w.pop.hist] { - menu $m -disabledfore $tkCon(color,prompt) -postcom "tkConHistoryMenu $m" - } + ## Prefs Menu + ## + foreach m [list [menu $w.pref.m] [menu $w.pop.pref]] { + $m add check -label "Brace Highlighting" \ + -underline 0 -variable TKCON(lightbrace) + $m add check -label "Command Highlighting" \ + -underline 0 -variable TKCON(lightcmd) + $m add check -label "History Substitution" \ + -underline 0 -variable TKCON(subhistory) + $m add check -label "Non-Tcl Attachments" \ + -underline 0 -variable TKCON(nontcl) + $m add check -label "Calculator Mode" \ + -underline 1 -variable TKCON(calcmode) + $m add check -label "Show Multiple Matches" \ + -underline 0 -variable TKCON(showmultiple) + $m add check -label "Show Menubar" \ + -underline 5 -variable TKCON(showmenu) \ + -command "if \$TKCON(showmenu) { \ + pack $w -fill x -before $TKCON(console) \ + -before $TKCON(scrolly) \ + } else { pack forget $w }" + $m add cascade -label Scrollbar -underline 2 -menu $m.scroll + + ## Scrollbar Menu + ## + set m [menu $m.scroll -tearoff 0] + $m add radio -label "Left" -variable TKCON(scrollypos) -value left \ + -command { pack config $TKCON(scrolly) -side left } + $m add radio -label "Right" -variable TKCON(scrollypos) -value right \ + -command { pack config $TKCON(scrolly) -side right } + } + + ## History Menu + ## + foreach m [list $w.hist.m $w.pop.hist] { + menu $m -disabledforeground $TKCON(color,prompt) \ + -postcommand [list tkConHistoryMenu $m] + } - ## Help Menu - ## - 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 - } + ## Help Menu + ## + foreach m [list [menu $w.help.m] [menu $w.pop.help]] { + $m add command -label "About " -und 0 -accel Ctrl-A -command tkConAbout + } } ## tkConHistoryMenu - dynamically build the menu for attached interpreters ## -# ARGS: w - menu widget +# ARGS: m - menu widget ## -proc tkConHistoryMenu w { - global tkCon - - if ![winfo exists $w] return - set id [tkConEvalSlave history nextid] - if {$tkCon(histid)==$id} return - set tkCon(histid) $id - $w delete 0 end - while {($id>$tkCon(histid)-10) && \ - ![catch {tkConEvalSlave history event [incr id -1]} tmp]} { - set lbl [lindex [split $tmp "\n"] 0] - if {[string len $lbl]>32} { set lbl [string range $tmp 0 30]... } - $w add command -label "$id: $lbl" -command " - $tkCon(console) delete limit end - $tkCon(console) insert limit [list $tmp] - $tkCon(console) see end - tkConEval $tkCon(console) - " - } +;proc tkConHistoryMenu m { + global TKCON + + if {![winfo exists $m]} return + set id [tkConEvalSlave history nextid] + if {$TKCON(histid)==$id} return + set TKCON(histid) $id + $m delete 0 end + while {($id>$TKCON(histid)-10) && \ + ![catch {tkConEvalSlave history event [incr id -1]} tmp]} { + set lbl [lindex [split $tmp "\n"] 0] + if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... } + $m add command -label "$id: $lbl" -command " + $TKCON(console) delete limit end + $TKCON(console) insert limit [list $tmp] + $TKCON(console) see end + tkConEval $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 - } +;proc tkConInterpMenu w { + global TKCON + + if {![winfo exists $w]} return + $w delete 0 end + foreach {app type} [tkConAttach] break + $w add command -label "[string toupper $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 + } + + if {$TKCON(A:version) > 7.4} { + ## Packages Cascaded Menu + ## + $w add cascade -label Packages -und 0 -menu $w.pkg + set m $w.pkg + if {[winfo exists $m]} { + $m delete 0 end + } else { + menu $m -tearoff no -disabledfore $TKCON(color,prompt) + } + + foreach pkg [tkConEvalAttached [list info loaded {}]] { + set loaded([lindex $pkg 1]) [package provide $pkg] + } + foreach pkg [lremove [tkConEvalAttached {package names}] Tcl] { + set version [tkConEvalAttached [list package provide $pkg]] + if {[string compare {} $version]} { + set loaded($pkg) $version + } elseif {![info exists loaded($pkg)]} { + set loadable($pkg) [list package require $pkg] + } + } + foreach pkg [tkConEvalAttached {info loaded}] { + set pkg [lindex $pkg 1] + if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} { + set loadable($pkg) [list load {} $pkg] + } + } + foreach pkg [array names loadable] { + $m add command -label "Load $pkg ([tkConEvalAttached \ + [list package version $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($pkg) Loaded" -state disabled + } + } - set isnew [tkConEvalAttached expr \[info tclversion\]>7.4] - set hastk [tkConEvalAttached info exists tk_library] + ## Show Last Error + ## + $w add separator + $w add command -label "Show Last Error" \ + -command [list tkcon error $app $type] - if 0 { - ## Inspect Cascaded Menu - ## - $w add cascade -label Inspect -un 0 -menu $w.ins - set m $w.ins - if [winfo exists $m] { - $m delete 0 end - } else { - menu $m -tearoff no -disabledfore $tkCon(color,prompt) - } - $m add check -label "Procedures" \ - -command [list tkConInspect $app $type procs] - $m add check -label "Global Vars" \ - -command [list tkConInspect $app $type vars] - if $isnew { - $m add check -label "Interpreters" \ - -command [list tkConInspect $app $type interps] - $m add check -label "Aliases" \ - -command [list tkConInspect $app $type aliases] - } - if $hastk { - $m add separator - $m add check -label "All Widgets" \ - -command [list tkConInspect $app $type widgets] - $m add check -label "Canvas Widgets" \ - -command [list tkConInspect $app $type canvases] - $m add check -label "Menu Widgets" \ - -command [list tkConInspect $app $type menus] - $m add check -label "Text Widgets" \ - -command [list tkConInspect $app $type texts] - if $isnew { - $m add check -label "Images" \ - -command [list tkConInspect $app $type images] - } - } - } - - if $isnew { - ## Packages Cascaded Menu + ## State Checkpoint/Revert ## - $w add cascade -label Packages -un 0 -menu $w.pkg - set m $w.pkg - if [winfo exists $m] { $m delete 0 end } else { - menu $m -tearoff no -disabledfore $tkCon(color,prompt) - } - - foreach pkg [tkConEvalAttached [list info loaded {}]] { - set loaded([lindex $pkg 1]) [package provide $pkg] - } - foreach pkg [lremove [tkConEvalAttached package names] Tcl] { - set version [tkConEvalAttached package provide $pkg] - if [string comp {} $version] { - set loaded($pkg) $version - } elseif {![info exists loaded($pkg)]} { - set loadable($pkg) [list package require $pkg] - } - } - foreach pkg [tkConEvalAttached info loaded] { - set pkg [lindex $pkg 1] - if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} { - set loadable($pkg) [list load {} $pkg] - } - } - foreach pkg [array names loadable] { - $m add command -label "Load $pkg ([tkConEvalAttached package version $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($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 + $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] +} + +## tkConAttachMenu - fill in in the applications sub-menu ## with a list of all the applications that currently exist. ## -proc tkConFillAppsMenu {m} { - global tkCon - - 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 [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] [array names tknames]]] { - $m add radio -label $i -var tkCon(app) -value $i \ - -command "tkConAttach [list $i] interp; $cmd" - } - $m add separator - - $m add command -label "TkCon Interpreters" -state disabled - foreach i [lsort [array names interps]] { - if [string match {} $interps($i)] { set interps($i) "no Tk" } - if [regexp {^Slave[0-9]+} $i] { - 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] { - $m add radio -label "$name ($interps($i))" -var tkCon(app) \ - -value Main -acc Ctrl-3 \ - -command "tkConAttach [list $name] slave; $cmd" - } else { - $m add radio -label "$name ($interps($i))" -var tkCon(app) -value $i \ - -command "tkConAttach [list $name] slave; $cmd" - } +;proc tkConAttachMenu m { + global TKCON + + array set interps [set tmp [tkConInterps]] + foreach {i j} $tmp { set tknames($j) {} } + + $m delete 0 end + set cmd {tkConPrompt \n [tkConCmdGet $TKCON(console)]} + $m add radio -label {None (use local slave) } -variable TKCON(app) \ + -value [concat $TKCON(name) $TKCON(exec)] -accel Ctrl-1 \ + -command "tkConAttach {}; $cmd" + $m add separator + $m add command -label "Foreign Tk Interpreters" -state disabled + foreach i [lsort [lremove [winfo interps] [array names tknames]]] { + $m add radio -label $i -variable TKCON(app) -value $i \ + -command "tkConAttach [list $i] interp; $cmd" + } + $m add separator + + $m add command -label "TkCon Interpreters" -state disabled + foreach i [lsort [array names interps]] { + if {[string match {} $interps($i)]} { set interps($i) "no Tk" } + if {[regexp {^Slave[0-9]+} $i]} { + set opts [list -label "$i ($interps($i))" -variable TKCON(app) \ + -value $i -command "tkConAttach [list $i] slave; $cmd"] + if {[string match $TKCON(name) $i]} { + append opts " -accel Ctrl-2" + } + eval $m add radio $opts + } else { + set name [concat Main $i] + if {[string match Main $name]} { + $m add radio -label "$name ($interps($i))" \ + -variable TKCON(app) -value Main -accel Ctrl-3 \ + -command "tkConAttach [list $name] slave; $cmd" + } else { + $m add radio -label "$name ($interps($i))" \ + -variable TKCON(app) -value $i \ + -command "tkConAttach [list $name] slave; $cmd" + } + } + } + +} + +## Namepaces Cascaded Menu +## +;proc tkConNamespaceMenu m { + global TKCON + + $m delete 0 end + if {!$TKCON(A:namespace) || ($TKCON(deadapp) || \ + ($TKCON(nontcl) && [string match interp $TKCON(apptype)]))} { + $m add command -label "No Namespaces" -state disabled + return + } + + ## Same command as for tkConAttachMenu items + set cmd {tkConPrompt \n [tkConCmdGet $TKCON(console)]} + + foreach i [tkConNamespaces ::] { + if {[string match :: $i]} { + $m add radio -label "Main" -variable TKCON(namesp) -value $i \ + -command "tkConAttachNamespace [list $i]; $cmd" + } else { + $m add radio -label $i -variable TKCON(namesp) -value $i \ + -command "tkConAttachNamespace [list $i]; $cmd" + } } - } } ## tkConFindBox - creates minimal dialog interface to tkConFind # ARGS: w - text widget -# str - optional seed string for tkCon(find) +# str - optional seed string for TKCON(find) ## -proc tkConFindBox {w {str {}}} { - global tkCon - - set base $tkCon(base).find - if ![winfo exists $base] { - toplevel $base +;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 [list $base.btn.fnd invoke] + bind $base.f.e [list $base.btn.dis invoke] + } + $base.btn.fnd config -command "tkConFind $w \$TKCON(find) \ + -case \$TKCON(find,case) -reg \$TKCON(find,reg)" + $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 - 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 [list $base.btn.fnd invoke] - bind $base.f.e [list $base.btn.dis invoke] - } - $base.btn.fnd config -command "tkConFind $w \$tkCon(find) \ - -case \$tkCon(find,case) -reg \$tkCon(find,reg)" - $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 + " + if {[string compare {} $str]} { + set TKCON(find) $str + $base.btn.fnd invoke + } + + if {[string compare 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 @@ -973,31 +1092,31 @@ proc tkConFindBox {w {str {}}} { # -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0 # -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0 ## -proc tkConFind {w str args} { - $w tag remove find 1.0 end - set truth {^(1|yes|true|on)$} - set opts {} - foreach {key val} $args { - switch -glob -- $key { - -c* { if [regexp -nocase $truth $val] { set case 1 } } - -r* { if [regexp -nocase $truth $val] { lappend opts -regexp } } - default { return -code error "Unknown option $key" } - } - } - if ![info exists case] { lappend opts -nocase } - if [string match {} $str] return - $w mark set findmark 1.0 - 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] +;proc tkConFind {w str args} { + $w tag remove find 1.0 end + set truth {^(1|yes|true|on)$} + set opts {} + foreach {key val} $args { + switch -glob -- $key { + -c* { if {[regexp -nocase $truth $val]} { set case 1 } } + -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } } + default { return -code error "Unknown option $key" } + } + } + if {![info exists case]} { lappend opts -nocase } + if {[string match {} $str]} return + $w mark set findmark 1.0 + while {[string compare {} [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 +# ARGS: name - application name to which tkCon sends commands # This is either a slave interperter name or tk appname. # type - (slave|interp) type of interpreter we're attaching to # slave means it's a TkCon interpreter @@ -1005,100 +1124,150 @@ proc tkConFind {w str args} { # Results: tkConEvalAttached is recreated to evaluate in the # appropriate interpreter ## -proc tkConAttach {{an } {type slave}} { - global tkCon - if [string match $an] { - if [string match {} $tkCon(appname)] { - return [list [concat $tkCon(name) $tkCon(exec)] $tkCon(apptype)] +;proc tkConAttach {{name } {type slave}} { + global TKCON + if {[string match $name]} { + if {[string match {} $TKCON(appname)]} { + return [list [concat $TKCON(name) $TKCON(exec)] $TKCON(apptype)] + } else { + return [list $TKCON(appname) $TKCON(apptype)] + } + } + set path [concat $TKCON(name) $TKCON(exec)] + + if {[string match namespace $type]} { + return [uplevel tkConAttachNamespace $name] + } elseif {[string compare {} $name]} { + array set interps [tkConInterps] + if {[string match {[Mm]ain} [lindex $name 0]]} { + set name [lrange $name 1 end] + } + if {[string match $path $name]} { + set name {} + set app $path + set type slave + } elseif {[info exists interps($name)]} { + if {[string match {} $name]} { set name Main; set app Main } + set type slave + } elseif {[interp exists $name]} { + set name [concat $TKCON(name) $name] + set type slave + } elseif {[interp exists [concat $TKCON(exec) $name]]} { + set name [concat $path $name] + set type slave + } elseif {[lsearch -exact [winfo interps] $name] > -1} { + if {[tkConEvalSlave info exists tk_library] \ + && [string match $name [tkConEvalSlave tk appname]]} { + set name {} + set app $path + set type slave + } elseif {[set i [lsearch -exact \ + [tkConMain set TKCON(interps)] $name]] != -1} { + set name [lindex [tkConMain set TKCON(slaves)] $i] + if {[string match {[Mm]ain} $name]} { set app Main } + set type slave + } else { + set type interp + } + } else { + return -code error "No known interpreter \"$name\"" + } } else { - return [list $tkCon(appname) $tkCon(apptype)] - } - } - set app - - set path [concat $tkCon(name) $tkCon(exec)] - if [string comp {} $an] { - array set interps [tkConInterps] - if [string match {[Mm]ain} [lindex $an 0]] { set an [lrange $an 1 end] } - if {[string match $path $an]} { - set an {} - set app $path - set type slave - } elseif {[info exists interps($an)]} { - if [string match {} $an] { set an Main; set app Main } - set type slave - } elseif {[interp exists $an]} { - set an [concat $tkCon(name) $an] - set type slave - } elseif {[interp exists [concat $tkCon(exec) $an]]} { - set an [concat $path $an] - set type slave - } elseif {[lsearch [winfo interps] $an] > -1} { - if {[tkConEvalSlave info exists tk_library] - && [string match $an [tkConEvalSlave tk appname]]} { - set an {} set app $path - set type slave - } elseif {[set i [lsearch [tkConMain set tkCon(interps)] $an]] > -1} { - set an [lindex [tkConMain set tkCon(slaves)] $i] - if [string match {[Mm]ain} $an] { set app Main } - set type slave - } else { - set type interp - } + } + if {![info exists app]} { set app $name } + array set TKCON [list app $app appname $name apptype $type deadapp 0] + + ## 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 {} $name]} { + 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 {} uplevel \#0 + } else { + interp alias {} tkConEvalAttached {} \ + tkConMain interp eval $TKCON(app) + } + } + interp { + if {$TKCON(nontcl)} { + interp alias {} tkConEvalAttached {} tkConEvalSlave + array set TKCON {A:version 0 A:namespace 0 A:itcl 0 namesp ::} + } else { + interp alias {} tkConEvalAttached {} tkConEvalSend + } + } + default { + return -code error "[lindex [info level 0] 0] did not specify\ + a valid type: must be slave or interp" + } + } + if {[string match slave $type] || \ + (!$TKCON(nontcl) && [string match interp $type])} { + set TKCON(A:version) [tkConEvalAttached {info tclversion}] + set TKCON(A:namespace) [string compare {} \ + [tkConEvalAttached {info commands namespace}]] + set TKCON(A:itcl) [string match *i \ + [tkConEvalAttached {info patchlevel}]] + set TKCON(namesp) :: + } + return +} + +## tkConAttach - called to attach tkCon to an interpreter +# ARGS: name - namespace name in which tkCon should eval commands +# Results: tkConEvalAttached will be modified +## +;proc tkConAttachNamespace { name } { + global TKCON + if {($TKCON(nontcl) && [string match interp $TKCON(apptype)]) \ + || $TKCON(deadapp)} { + return -code error "can't attach to namespace in bad environment" + } + if {[string compare {} $name] && \ + [lsearch [tkConNamespaces ::] $name] == -1} { + return -code error "No known namespace \"$name\"" + } + if {[regexp {^(|::)$} $name]} { + ## If name=={} || ::, we want the primary namespace + set alias [interp alias {} tkConEvalAttached] + if {[string match tkConEvalNamespace* $alias]} { + eval [list interp alias {} tkConEvalAttached {}] [lindex $alias 1] + } + set name :: } else { - return -code error "No known interpreter \"$an\"" - } - } else { - set app $path - } - if [string match - $app] { set app $an } - set tkCon(app) $app - set tkCon(appname) $an - set tkCon(apptype) $type - set tkCon(deadapp) 0 - - ## 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 eval - } elseif {[string match Main $tkCon(app)]} { - interp alias {} tkConEvalAttached {} tkConMain eval - } elseif {[string match $tkCon(name) $tkCon(app)]} { - interp alias {} tkConEvalAttached {} uplevel \#0 - } else { - interp alias {} tkConEvalAttached {} tkConMain interp eval $tkCon(app) - } - } - interp { - if $tkCon(nontcl) { - interp alias {} tkConEvalAttached {} tkConEvalSlave - } else { - interp alias {} tkConEvalAttached {} tkConEvalSend - } - } - default { - return -code error "[lindex [info level 0] 0] did not specify\ - a valid type: must be slave or interp" - } - } - return + interp alias {} tkConEvalAttached {} tkConEvalNamespace \ + [interp alias {} tkConEvalAttached] [list $name] + } + set TKCON(namesp) $name } ## tkConLoad - sources a file into the console +## The file is actually sourced in the currently attached's interp # ARGS: fn - (optional) filename to source in # Returns: selected filename ({} if nothing was selected) ## -proc tkConLoad {{fn {}}} { - global tkCon - if {[string match {} $fn] && - ([catch {tk_getOpenFile} fn] || [string match {} $fn])} return - tkConEvalAttached [list source $fn] +;proc tkConLoad { {fn ""} } { + global TKCON + set types { + {{Tcl Files} {.tcl .tk}} + {{Text Files} {.txt}} + {{All Files} *} + } + if { + [string match {} $fn] && + ([catch {tk_getOpenFile -filetypes $types \ + -title "Source File"} fn] || [string match {} $fn]) + } { return } + tkConEvalAttached [list source $fn] } ## tkConSave - saves the console buffer to a file @@ -1106,464 +1275,598 @@ proc tkConLoad {{fn {}}} { # ARGS: w - console text widget # fn - (optional) filename to save to ## -proc tkConSave {{fn {}}} { - global tkCon - if {[string match {} $fn] && - ([catch {tk_getSaveFile} fn] || [string match {} $fn])} return - if [catch {open $fn w} 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 +;proc tkConSave { {fn ""} {type ""} } { + global TKCON + if {![regexp -nocase {^(all|history|stdin|stdout|stderr)$} $type]} { + array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel } + ## Allow user to specify what kind of stuff to save + set type [tk_dialog $TKCON(base).savetype "Save Type" \ + "What part of the text do you want to save?" \ + questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)] + if {$type == 5 || $type == -1} return + set type $s($type) + } + if {[string match {} $fn]} { + set types { + {{Text Files} {.txt}} + {{Tcl Files} {.tcl .tk}} + {{All Files} *} + } + if {[catch {tk_getSaveFile -filetypes $types -title "Save $type"} fn] \ + || [string match {} $fn]} return + } + set type [string tolower $type] + switch $type { + stdin - stdout - stderr { + set data {} + foreach {first last} [$TKCON(console) tag ranges $type] { + lappend data [$TKCON(console) get $first $last] + } + set data [join $data \n] + } + history { set data [tkcon history] } + all - default { set data [$TKCON(console) get 1.0 end-1c] } + } + if {[catch {open $fn w} fid]} { + return -code error "Save Error: Unable to open '$fn' for writing\n$fid" + } + puts $fid $data + close $fid } ## 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. ## -proc tkConMainInit {} { - global tkCon - - if ![info exists tkCon(slaves)] { - array set tkCon [list slave 0 slaves Main name {} interps [tk appname]] - } - interp alias {} tkConMain {} tkConInterpEval Main - interp alias {} tkConSlave {} tkConInterpEval - - ## tkConNew - create new console window - ## Creates a slave interpreter and sources in this script. - ## All other interpreters also get a command to eval function in the - ## new interpreter. - ## - proc tkConNew {} { - global argv0 argc argv tkCon - set tmp [interp create Slave[incr tkCon(slave)]] - lappend tkCon(slaves) $tmp - load {} Tk $tmp - lappend tkCon(interps) [$tmp eval [list tk appname "[tk appname] $tmp"]] - $tmp eval set argc $argc \; set argv [list $argv] \; \ - set argv0 [list $argv0] - $tmp eval [list set tkCon(name) $tmp] - $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 tkConStateCleanup tkConStateCleanup - $tmp alias tkConStateCompare tkConStateCompare - $tmp alias tkConStateRevert tkConStateRevert - $tmp eval [list source $tkCon(SCRIPT)] - return $tmp - } - - ## tkConDestroy - destroy console window - ## This proc should only be called by the main interpreter. If it is - ## called from there, it will ask before exiting TkCon. All others - ## (slaves) will just have their slave interpreter deleted, closing them. - ## - proc tkConDestroy {{slave {}}} { - global tkCon - if [string match {} $slave] { - ## Main interpreter close request - if [tk_dialog $tkCon(base).destroyme {Quit TkCon?} \ - {Closing the Main console will quit TkCon} \ - warning 0 "Don't Quit" "Quit TkCon"] exit - } else { - ## Slave interpreter close request - set name [tkConInterpEval $slave] - set tkCon(interps) [lremove $tkCon(interps) [list $name]] - set tkCon(slaves) [lremove $tkCon(slaves) [list $slave]] - interp delete $slave - } - tkConStateCleanup $slave - } - - ## tkConInterpEval - passes evaluation to another named interpreter - ## If the interpreter is named, but no args are given, it returns the - ## [tk appname] of that interps master (not the associated eval slave). - ## - proc tkConInterpEval {{slave {}} args} { - if [string match {} $slave] { - global tkCon - return $tkCon(slaves) - } elseif {[string match {[Mm]ain} $slave]} { - set slave {} - } - if [string match {} $args] { - return [interp eval $slave tk appname] - } else { - uplevel \#0 [list interp eval $slave $args] - } - } - - proc tkConInterps {{ls {}} {interp {}}} { - if [string match {} $interp] { lappend ls {} [tk appname] } - foreach i [interp slaves $interp] { - if [string comp {} $interp] { set i "$interp $i" } - if [string comp {} [interp eval $i package provide Tk]] { - lappend ls $i [interp eval $i tk appname] - } else { - 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: - ## - proc tkConStateCheckpoint {app type} { - global tkCon - if {[info exists tkCon($type,$app,cmd)] && - [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 tkCon($type,$app,cmd) [tkConEvalOther $app $type info comm *] - set tkCon($type,$app,var) [tkConEvalOther $app $type info vars *] - return - } - - ## tkConStateCompare - compare two states and output difference - # ARGS: - ## - proc tkConStateCompare {app type {verbose 0}} { - global tkCon - if ![info exists tkCon($type,$app,cmd)] { - 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 *] \ - $tkCon($type,$app,cmd)] - set vars [lremove [tkConEvalOther $app $type info vars *] \ - $tkCon($type,$app,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 - } - - ## tkConStateRevert - reverts interpreter to previous state - # ARGS: - ## - proc tkConStateRevert {app type} { - global tkCon - if ![info exists tkCon($type,$app,cmd)] { - 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 *] \ - $tkCon($type,$app,cmd)] { - catch {tkConEvalOther $app $type rename $i {}} - } - foreach i [lremove [tkConEvalOther $app $type info vars *] \ - $tkCon($type,$app,var)] { - catch {tkConEvalOther $app $type unset $i} - } - } - } - - ## tkConStateCleanup - cleans up state information in master array - # - ## - proc tkConStateCleanup {args} { - global tkCon - if [string match {} $args] { - foreach state [array names tkCon slave,*] { - if ![interp exists [string range $state 6 end]] { unset tkCon($state) } - } +;proc tkConMainInit {} { + global TKCON + + if {![info exists TKCON(slaves)]} { + array set TKCON [list slave 0 slaves Main name {} \ + interps [list [tk appname]]] + } + interp alias {} tkConMain {} tkConInterpEval Main + interp alias {} tkConSlave {} tkConInterpEval + + ## tkConNew - create new console window + ## Creates a slave interpreter and sources in this script. + ## All other interpreters also get a command to eval function in the + ## new interpreter. + ## + ;proc tkConNew {} { + global argv0 argc argv TKCON + set tmp [interp create Slave[incr TKCON(slave)]] + lappend TKCON(slaves) $tmp + load {} Tk $tmp + lappend TKCON(interps) [$tmp eval [list tk appname \ + "[tk appname] $tmp"]] + $tmp eval set argc $argc \; set argv [list $argv] \; \ + set argv0 [list $argv0] + $tmp eval [list set TKCON(name) $tmp] + $tmp alias exit tkConExit $tmp + $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 tkConStateCleanup tkConStateCleanup + $tmp alias tkConStateCompare tkConStateCompare + $tmp alias tkConStateRevert tkConStateRevert + $tmp eval [list source $TKCON(SCRIPT)] + return $tmp + } + + ## tkConExit - full exit OR destroy slave console + ## This proc should only be called in the main interpreter from a slave. + ## The master determines whether we do a full exit or just kill the slave. + ## + ;proc tkConExit {slave} { + global TKCON + ## Slave interpreter exit request + if {[string match exit $TKCON(slaveexit)]} { + ## Only exit if it specifically is stated to do so + exit + } + ## Otherwise we will delete the slave interp and associated data + set name [tkConInterpEval $slave] + set TKCON(interps) [lremove $TKCON(interps) [list $name]] + set TKCON(slaves) [lremove $TKCON(slaves) [list $slave]] + interp delete $slave + tkConStateCleanup $slave + } + + ## tkConDestroy - destroy console window + ## This proc should only be called by the main interpreter. If it is + ## called from there, it will ask before exiting TkCon. All others + ## (slaves) will just have their slave interpreter deleted, closing them. + ## + ;proc tkConDestroy {{slave {}}} { + global TKCON + if {[string match {} $slave]} { + ## Main interpreter close request + if {[tk_dialog $TKCON(base).destroyme {Quit TkCon?} \ + {Closing the Main console will quit TkCon} \ + warning 0 "Don't Quit" "Quit TkCon"]} exit + } else { + ## Slave interpreter close request + set name [tkConInterpEval $slave] + set TKCON(interps) [lremove $TKCON(interps) [list $name]] + set TKCON(slaves) [lremove $TKCON(slaves) [list $slave]] + interp delete $slave + } + tkConStateCleanup $slave + } + + ## tkConInterpEval - passes evaluation to another named interpreter + ## If the interpreter is named, but no args are given, it returns the + ## [tk appname] of that interps master (not the associated eval slave). + ## + ;proc tkConInterpEval {{slave {}} args} { + if {[string match {} $slave]} { + global TKCON + return $TKCON(slaves) + } elseif {[string match {[Mm]ain} $slave]} { + set slave {} + } + if {[llength $args]} { + uplevel \#0 [list interp eval $slave $args] + } else { + return [interp eval $slave tk appname] + } + } + + ;proc tkConInterps {{ls {}} {interp {}}} { + if {[string match {} $interp]} { lappend ls {} [tk appname] } + foreach i [interp slaves $interp] { + if {[string compare {} $interp]} { set i "$interp $i" } + if {[string compare {} [interp eval $i package provide Tk]]} { + lappend ls $i [interp eval $i tk appname] + } else { + 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: + ## + ;proc tkConStateCheckpoint {app type} { + global TKCON + if {[info exists TKCON($type,$app,cmd)] && + [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 TKCON($type,$app,cmd) [tkConEvalOther $app $type info commands *] + set TKCON($type,$app,var) [tkConEvalOther $app $type info vars *] + return + } + + ## tkConStateCompare - compare two states and output difference + # ARGS: + ## + ;proc tkConStateCompare {app type {verbose 0}} { + global TKCON + if {![info exists TKCON($type,$app,cmd)]} { + 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 -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 compare {} \ + [tkConEvalOther $app $type info commands dump]] + if {$hasdump} { + $w.btn.expand config -state normal + } else { + $w.btn.expand config -state disabled + } + + set cmds [lremove [tkConEvalOther $app $type info commands *] \ + $TKCON($type,$app,cmd)] + set vars [lremove [tkConEvalOther $app $type info vars *] \ + $TKCON($type,$app,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 + } + + ## tkConStateRevert - reverts interpreter to previous state + # ARGS: + ## + ;proc tkConStateRevert {app type} { + global TKCON + if {![info exists TKCON($type,$app,cmd)]} { + 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 commands *] \ + $TKCON($type,$app,cmd)] { + catch {tkConEvalOther $app $type rename $i {}} + } + foreach i [lremove [tkConEvalOther $app $type info vars *] \ + $TKCON($type,$app,var)] { + catch {tkConEvalOther $app $type unset $i} + } + } + } + + ## tkConStateCleanup - cleans up state information in master array + # + ## + ;proc tkConStateCleanup {args} { + global TKCON + if {[string match {} $args]} { + foreach state [array names TKCON slave,*] { + if {![interp exists [string range $state 6 end]]} { + unset TKCON($state) + } + } + } else { + set app [lindex $args 0] + set type [lindex $args 1] + if {[regexp {^(|slave)$} $type]} { + foreach state [concat [array names TKCON slave,$app] \ + [array names TKCON "slave,$app *"]] { + if {![interp exists [string range $state 6 end]]} { + unset TKCON($state) + } + } + } else { + catch {unset TKCON($type,$app)} + } + } + } +} + +## tkConEvent - get history event, search if string != {} +## look forward (next) if $int>0, otherwise look back (prev) +# ARGS: W - console widget +## +;proc tkConEvent {int {str {}}} { + if {!$int} return + + global TKCON + set w $TKCON(console) + + set nextid [tkConEvalSlave history nextid] + if {[string compare {} $str]} { + ## String is not empty, do an event search + set event $TKCON(event) + if {$int < 0 && $event == $nextid} { set TKCON(cmdbuf) $str } + set len [string len $TKCON(cmdbuf)] + incr len -1 + if {$int > 0} { + ## Search history forward + while {$event < $nextid} { + if {[incr event] == $nextid} { + $w delete limit end + $w insert limit $TKCON(cmdbuf) + break + } elseif { + ![catch {tkConEvalSlave history event $event} res] && + ![string compare $TKCON(cmdbuf) [string range $res 0 $len]] + } { + $w delete limit end + $w insert limit $res + break + } + } + set TKCON(event) $event + } else { + ## Search history reverse + while {![catch {tkConEvalSlave \ + history event [incr event -1]} res]} { + if {![string compare $TKCON(cmdbuf) \ + [string range $res 0 $len]]} { + $w delete limit end + $w insert limit $res + set TKCON(event) $event + break + } + } + } } else { - set app [lindex $args 0] - set type [lindex $args 1] - if [regexp {^(|slave)$} $type] { - foreach state [concat [array names tkCon slave,$app] \ - [array names tkCon "slave,$app *"]] { - if ![interp exists [string range $state 6 end]] {unset tkCon($state)} + ## String is empty, just get next/prev event + if {$int > 0} { + ## Goto next command in history + if {$TKCON(event) < $nextid} { + $w delete limit end + if {[incr TKCON(event)] == $nextid} { + $w insert limit $TKCON(cmdbuf) + } else { + $w insert limit [tkConEvalSlave \ + history event $TKCON(event)] + } + } + } else { + ## Goto previous command in history + if {$TKCON(event) == $nextid} { + set TKCON(cmdbuf) [tkConCmdGet $w] + } + if {[catch {tkConEvalSlave \ + history event [incr TKCON(event) -1]} res]} { + incr TKCON(event) + } else { + $w delete limit end + $w insert limit $res + } } - } else { - catch {unset tkCon($type,$app)} - } } - } + $w mark set insert end + $w see end } ## tkcon - command that allows control over the console # ARGS: totally variable, see internal comments ## -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 - } - con* { - ## 'console' - passes the args to the text widget of the console. - eval $tkCon(console) $args - } - err* { - ## Outputs stack caused by last error. - 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] - 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 $info - $w.text config -state disabled - } - fi* { - ## 'find' string - tkConFind $tkCon(console) $args - } - 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] - } - } - get* { - ## 'gets' a replacement for [gets stdin varname] - ## This forces a complete command to be input though - set old [bind Console ] - bind Console { set tkCon(wait) 0 } - bind Console { 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 $old - bind Console $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) - } - 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) - } - 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 - ## tkcon set - ## tkcon set w - ## tkcon set u - ## tkcon set 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) - } - 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)] - } - } - 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 new tkCon[string toup [string index $cmd 0]][string range $cmd 1 end] - if [string comp {} [info command $new]] { - uplevel \#0 $new $args - } else { - 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]] {, }]" - } - } - } +;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 + } + con* { + ## 'console' - passes the args to the text widget of the console. + eval $TKCON(console) $args + } + err* { + ## Outputs stack caused by last error. + 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] + 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 -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 $info + $w.text config -state disabled + focus $w.text + } + fi* { + ## 'find' string + tkConFind $TKCON(console) $args + } + fo* { + ## 'font' ?fontname? - gets/sets the font of the console + if {[llength $args]} { + return [$TKCON(console) config -font $args] + } else { + return [$TKCON(console) config -font] + } + } + get* { + ## 'gets' a replacement for [gets stdin varname] + ## This forces a complete command to be input though + set old [bind TkConsole <>] + bind TkConsole <> { set TKCON(wait) 0 } + set w $TKCON(console) + vwait TKCON(wait) + set line [tkConCmdGet $w] + $w insert end \n + while {![info complete $line] || [regexp {[^\\]\\$} $line]} { + vwait TKCON(wait) + set line [tkConCmdGet $w] + $w insert end \n + $w see insert + } + bind TkConsole <> $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) + } + 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) + } + mas* - eval { + ## 'master' - evals contents in master interpreter + uplevel \#0 $args + } + set { + ## 'set' - set (or get, or unset) simple vars (not whole arrays) + ## from the master console interpreter + ## possible formats: + ## tkcon set + ## tkcon set + ## tkcon set w + ## tkcon set u + ## tkcon set r + if {[llength $args]==5} { + ## This is for use w/ 'tkcon upvar' and only works with slaves + foreach {var i var1 var2 op} $args break + if {[string compare {} $var2]} { append var1 "($var2)" } + switch $op { + u { uplevel \#0 [list unset $var] } + w { + return [uplevel \#0 [list set $var \ + [interp eval $i [list set $var1]]]] + } + r { + return [interp eval $i [list set $var1 \ + [uplevel \#0 [list set $var]]]] + } + } + } + return [uplevel \#0 set $args] + } + sh* - dei* { + ## 'show|deiconify' - deiconifies the console. + wm deiconify $TKCON(root) + raise $TKCON(root) + } + ti* { + ## 'title' ?title? - gets/sets the console's title + if {[string compare {} $args]} { + return [wm title $TKCON(root) $args] + } else { + return [wm title $TKCON(root)] + } + } + 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 new tkCon[string toupper \ + [string index $cmd 0]][string range $cmd 1 end] + if {[string compare {} [info command $new]]} { + uplevel \#0 $new $args + } else { + 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]] {, }]" + } + } + } } ## ## Some procedures to make up for lack of built-in shell commands ## -## puts +## tkcon_puts - ## This allows me to capture all stdout/stderr to the console window +## This will be renamed to 'puts' at the appropriate time during init +## # ARGS: same as usual # Outputs: the string with a color-coded text tag ## -if ![catch {rename puts tcl_puts}] { - proc puts args { +;proc tkcon_puts args { set len [llength $args] if {$len==1} { - eval tkcon console insert output $args stdout {\n} stdout - tkcon console see output + 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 + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if {[string compare $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 + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if {[string compare [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 { - global errorCode errorInfo - if [catch "tcl_puts $args" msg] { - regsub tcl_puts $msg puts msg - regsub -all tcl_puts $errorInfo puts errorInfo - error $msg - } - return $msg + global errorCode errorInfo + if {[catch "tcl_puts $args" msg]} { + regsub tcl_puts $msg puts msg + regsub -all tcl_puts $errorInfo puts errorInfo + return -code error $msg + } + return $msg } - if $len update - } + if {$len} update } ## echo @@ -1576,15 +1879,15 @@ proc echo args { puts [concat $args] } ## This is executed in the parent interpreter ## proc clear {{pcnt 100}} { - if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { - return -code 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" - } + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + return -code 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" + } } ## alias - akin to the csh alias command @@ -1594,24 +1897,24 @@ proc clear {{pcnt 100}} { # 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]] + 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 [list {} $newcmd {}] $args } - return [join $res \n] - } elseif {[string match {} $args]} { - interp alias {} $newcmd - } else { - eval interp alias [list {} $newcmd {}] $args - } } ## unalias - unaliases an alias'ed command # ARGS: cmd - command to unbind as an alias ## proc unalias {cmd} { - interp alias {} $cmd {} + interp alias {} $cmd {} } ## dump - outputs variables/procedure/widget info in source'able form. @@ -1628,141 +1931,166 @@ proc unalias {cmd} { # Returns: the values of the requested items in a 'source'able form ## proc dump {type args} { - set whine 1 - set code ok - while {[string match -* $args]} { - switch -glob -- [lindex $args 0] { - -n* { set whine 0; set args [lreplace $args 0 0] } - -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] } - -- { set args [lreplace $args 0 0]; break } - default { return -code error "unknown option \"[lindex $args 0]\"" } - } - } - if {$whine && [string match {} $args]} { - return -code error "wrong \# args: [lindex [info level 0] 0]\ - ?-nocomplain? ?-filter pattern? ?--? 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. - if ![info exists fltr] { set fltr * } - 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]} { - set nest {} - append res "array set $var \{\n" - foreach i [lsort [array names v $fltr]] { - upvar 0 v\($i\) __ary - if {[array exists __ary]} { - append nest "\#\# NESTED ARRAY ELEMENT: $i\n" - append nest "upvar 0 [list $var\($i\)] __ary;\ - [dump v -filter $fltr __ary]\n" - } else { - append res " [list $i]\t[list $v($i)]\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]]] || - ([auto_load $arg] && - [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" - 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" - } - if ![info exists fltr] { set fltr .* } - 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 - if {[regexp -nocase -- $fltr $c]} { - append res " \\\n\t[list [lindex $c 0] [lindex $c 4]]" - } + set whine 1 + set code ok + if {[string match {} $args]} { + ## If no args, assume they gave us something to dump and + ## we'll try anything + set args [list $type] + set type any + } + while {[string match -* $args]} { + switch -glob -- [lindex $args 0] { + -n* { set whine 0; set args [lreplace $args 0 0] } + -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] } + -- { set args [lreplace $args 0 0]; break } + default {return -code error "unknown option \"[lindex $args 0]\""} + } + } + if {$whine && [string match {} $args]} { + return -code error "wrong \# args: [lindex [info level 0] 0] type\ + ?-nocomplain? ?-filter pattern? ?--? 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 compare {} [set cmds [info commands $arg]]]} { + foreach cmd [lsort $cmds] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + append res "\#\# ALIAS: $cmd =>\ + [interp alias {} $cmd]\n" + } elseif {[string compare {} [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 } - 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\ - \"$type\":\ must be procedure, variable, widget" + v* { + # variable + # outputs variables value(s), whether array or simple. + if {![info exists fltr]} { set fltr * } + 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]} { + set nest {} + append res "array set $var \{\n" + foreach i [lsort [array names v $fltr]] { + upvar 0 v\($i\) __ary + if {[array exists __ary]} { + append nest "\#\# NESTED ARRAY ELEMENT: $i\n" + append nest "upvar 0 [list $var\($i\)] __ary;\ + [dump v -filter $fltr __ary]\n" + } else { + append res " [list $i]\t[list $v($i)]\n" + } + } + append res "\}\n$nest" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if {[string compare {} [set ps [info proc $arg]]] || \ + ([auto_load $arg] && \ + [string compare {} [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" + 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" + } + if {![info exists fltr]} { set fltr .* } + foreach arg $args { + if {[string compare {} [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 + if {[regexp -nocase -- $fltr $c]} { + 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 + } + } + } + a* { + ## any - try to dump as var, then command, then widget... + if { + [catch {uplevel dump v -- $args} res] && + [catch {uplevel dump c -- $args} res] && + [catch {uplevel dump w -- $args} res] + } { + set res "dump was unable to resolve type for \"$args\"" + set code error + } + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"$type\": must be variable, command, procedure,\ + or widget" + } } - } - return -code $code [string trimr $res \n] + return -code $code [string trimright $res \n] } ## idebug - interactive debugger @@ -1770,80 +2098,89 @@ proc dump {type args} { # ## 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 - tkcon master eval set tkCon(prompt2) \$tkCon(prompt1) - tkcon master eval set tkCon(prompt1) \$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 evalSlave set level $level - tkcon 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 + 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 compare {} $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 compare {} $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 compare {} [info command tkcon]] + if {$tkcon} { + tkcon show + tkcon master eval set TKCON(prompt2) \$TKCON(prompt1) + tkcon master eval set TKCON(prompt1) \$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 evalSlave set level $level + tkcon 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 @@ -1861,95 +2198,101 @@ proc idebug {opt args} { 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 master eval set tkCon(prompt1) \$tkCon(prompt2) - tkcon set tkCon(exec) $slave - tkcon set tkCon(event) $event - tkcon prompt - } - } - 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" + } + 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 compare {} $res]} { + puts $res + } + } + set IDEBUG(debugging) 0 + if {$tkcon} { + tkcon master interp delete debugger + tkcon master eval set TKCON(prompt1) \$TKCON(prompt2) + tkcon set TKCON(exec) $slave + tkcon set TKCON(event) $event + tkcon prompt + } } - 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 + bo* { + if {[regexp {^([\#-]?[0-9]+)} $args level]} { + return [uplevel $level {dump c -no [lindex [info level 0] 0]}] + } + } + t* { + if {[llength $args]<2} return + set min [set max [set lvl $level]] + set exp {^\#?([0-9]+)? ?\#?([0-9]+) ?\#?([0-9]+)? ?(VERBOSE)?} + if {![regexp $exp $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 compare 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 { - 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]] {, }]" - } - } + 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 @@ -1957,68 +2300,69 @@ proc idebug {opt args} { # name - name of variable or command ## proc observe {opt name args} { - global tcl_observe - switch -glob -- $opt { - co* { - if [regexp {^(catch|lreplace|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]] {, }]" - } - } + global tcl_observe + switch -glob -- $opt { + co* { + if {[regexp {^(catch|lreplace|set|puts|for|incr|info|uplevel)$} \ + $name]} { + return -code error "cannot observe \"$name\":\ + infinite eval loop will occur" + } + set old ${name}@ + while {[string compare {} [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 command cdelete cinfo variable vdelete vinfo]] {, }]" + } + } } ## observe_var - auxilary function for observing vars, called by trace @@ -2027,21 +2371,21 @@ proc observe {opt name args} { # 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 $name $name - if [info exists $name\($el\)] { - puts [dump v $name\($el\)] +;proc observe_var {name el op} { + if {[string match u $op]} { + if {[string compare {} $el]} { + puts "unset \"${name}($el)\"" + } else { + puts "unset \"$name\"" + } } else { - puts [dump v $name] + upvar $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 @@ -2049,158 +2393,29 @@ proc observe_var {name el op} { # Returns: where command is found (internal / external / unknown) ## proc which 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]]} { - return "$cmd:\tinternal proc" - } else { - return "$cmd:\tinternal command" - } - } elseif {[string comp {} [auto_execok $cmd]]} { - return [auto_execok $cmd] - } else { - return -code error "$cmd:\tunknown command" - } -} - -## auto_execpath - tells you where an external command is found -## Only a slight modification from core auto_execok proc -# ARGS: cmd - command name -# Returns: where command is found or {} if not found -## -if {[info tclversion]<7.6} { -if {[string match $tcl_platform(platform) windows]} { - -# auto_execok -- -# -# Returns string that indicates name of program to execute if -# name corresponds to a shell builtin or an executable in the -# Windows search path, or "" otherwise. Builds an associative -# array auto_execs that caches information about previous checks, -# for speed. -# -# Arguments: -# name - Name of a command. - -# Windows version. -# -# Note that info executable doesn't work under Windows, so we have to -# look for files with .exe, .com, or .bat extensions. Also, the path -# may be in the Path or PATH environment variables, and path -# components are separated with semicolons, not colons as under Unix. -# -proc auto_execok name { - global auto_execs env tcl_platform - - if [info exists auto_execs($name)] { - return $auto_execs($name) - } - set auto_execs($name) "" - - if {[lsearch -exact {cls copy date del erase dir echo mkdir md rename - ren rmdir rd time type ver vol} $name] != -1} { - if {[info exists env(COMSPEC)]} { - set comspec $env(COMSPEC) - } elseif {[info exists env(ComSpec)]} { - set comspec $env(ComSpec) - } elseif {$tcl_platform(os) == "Windows NT"} { - set comspec "cmd.exe" + if {[string compare {} [info commands $cmd]] || \ + ([auto_load $cmd] && [string compare {} [info commands $cmd]])} { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + set result "$cmd: aliased to [alias $cmd]" + } elseif {[string compare {} [info procs $cmd]]} { + set result "$cmd: procedure" } else { - set comspec "command.com" - } - return [set auto_execs($name) [list $comspec /c $name]] - } - - if {[llength [file split $name]] != 1} { - foreach ext {{} .com .exe .bat} { - set file ${name}${ext} - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) $file] - } + set result "$cmd: command" } - return "" - } - - set path "[file dirname [info nameof]];.;" - if {[info exists env(WINDIR)]} { - set windir $env(WINDIR) - } elseif {[info exists env(windir)]} { - set windir $env(windir) - } - if {[info exists windir]} { - if {$tcl_platform(os) == "Windows NT"} { - append path "$windir/system32;" - } - append path "$windir/system;$windir;" - } - - if {! [info exists env(PATH)]} { - if [info exists env(Path)] { - append path $env(Path) - } else { - return "" + global auto_index + if {[info exists auto_index($cmd)]} { + ## This tells you where the command MIGHT have come from - + ## not true if the command was redefined interactively or + ## existed before it had to be auto_loaded. This is just + ## provided as a hint at where it MAY have come from + append result " ($auto_index($cmd))" } + return $result + } elseif {[string compare {} [auto_execok $cmd]]} { + return [auto_execok $cmd] } else { - append path $env(PATH) - } - - foreach dir [split $path {;}] { - if {$dir == ""} { - set dir . - } - foreach ext {{} .com .exe .bat} { - set file [file join $dir ${name}${ext}] - if {[file exists $file] && ![file isdirectory $file]} { - return [set auto_execs($name) $file] - } - } - } - return "" -} - -} else { - -# auto_execok -- -# -# Returns string that indicates name of program to execute if -# name corresponds to an executable in the path. Builds an associative -# array auto_execs that caches information about previous checks, -# for speed. -# -# Arguments: -# name - Name of a command. - -# Unix version. -# -proc auto_execok name { - global auto_execs env - - if [info exists auto_execs($name)] { - return $auto_execs($name) + return -code error "$cmd: command not found" } - set auto_execs($name) "" - if {[llength [file split $name]] != 1} { - if {[file executable $name] && ![file isdirectory $name]} { - set auto_execs($name) $name - } - return $auto_execs($name) - } - foreach dir [split $env(PATH) :] { - if {$dir == ""} { - set dir . - } - set file [file join $dir $name] - if {[file executable $file] && ![file isdirectory $file]} { - set auto_execs($name) $file - return $file - } - } - return "" -} - -} } ## dir - directory list @@ -2211,103 +2426,103 @@ proc auto_execok name { # Returns: a directory listing ## 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 - } - 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 - default { - return -code error \ - "unknown option \"$str\", should be one of: -all, -full, -long" - } - } - } - set sep [string trim [file join . .] .] - if [string match {} $args] { set args . } - foreach arg $args { - if {[file isdir $arg]} { - set arg [string trimr $arg $sep]$sep - if $s(all) { - lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] - } else { - lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] - } - } else { - lappend out [list [file dirname $arg]$sep \ - [lsort [glob -nocomplain -- $arg]]] - } - } - if $s(long) { - set old [clock scan {1 year ago}] - set fmt "%s%9d %s %s\n" - foreach o $out { - set d [lindex $o 0] - append res $d:\n - foreach f [lindex $o 1] { - file lstat $f st - set f [file tail $f] - if $s(full) { - switch -glob $st(type) { - d* { append f $sep } - l* { append f "@ -> [file readlink $d$sep$f]" } - default { if [file exec $d$sep$f] { append f * } } - } - } - if [string match file $st(type)] { - set mode - + 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 + } + 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 + default { + return -code error "unknown option \"$str\",\ + should be one of: -all, -full, -long" + } + } + } + set sep [string trim [file join . .] .] + if {[string match {} $args]} { set args . } + foreach arg $args { + if {[file isdir $arg]} { + set arg [string trimr $arg $sep]$sep + if {$s(all)} { + lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] + } else { + lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] + } } else { - set mode [string index $st(type) 0] + lappend out [list [file dirname $arg]$sep \ + [lsort [glob -nocomplain -- $arg]]] } - foreach j [split [format %o [expr $st(mode)&0777]] {}] { - append mode $s($j) + } + if {$s(long)} { + set old [clock scan {1 year ago}] + set fmt "%s%9d %s %s\n" + foreach o $out { + set d [lindex $o 0] + append res $d:\n + foreach f [lindex $o 1] { + file lstat $f st + set f [file tail $f] + if {$s(full)} { + switch -glob $st(type) { + d* { append f $sep } + l* { append f "@ -> [file readlink $d$sep$f]" } + default { if {[file exec $d$sep$f]} { append f * } } + } + } + if {[string match file $st(type)]} { + set mode - + } else { + set mode [string index $st(type) 0] + } + foreach j [split [format %o [expr {$st(mode)&0777}]] {}] { + append mode $s($j) + } + if {$st(mtime)>$old} { + set cfmt {%b %d %H:%M} + } else { + set cfmt {%b %d %Y} + } + append res [format $fmt $mode $st(size) \ + [clock format $st(mtime) -format $cfmt] $f] + } + append res \n } - if {$st(mtime)>$old} { - set cfmt {%b %d %H:%M} - } else { - set cfmt {%b %d %Y} + } else { + foreach o $out { + set d [lindex $o 0] + append res $d:\n + set i 0 + foreach f [lindex $o 1] { + if {[string len [file tail $f]] > $i} { + set i [string len [file tail $f]] + } + } + set i [expr {$i+2+$s(full)}] + ## 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] + if {$s(full)} { + switch -glob [file type $d$sep$f] { + d* { append f $sep } + l* { append f @ } + default { if {[file exec $d$sep$f]} { append f * } } + } + } + append res [format "%-${i}s" $f] + if {[incr k]%$j == 0} {set res [string trimr $res]\n} + } + append res \n\n } - append res [format $fmt $mode $st(size) \ - [clock format $st(mtime) -format $cfmt] $f] - } - append res \n - } - } else { - foreach o $out { - set d [lindex $o 0] - append res $d:\n - set i 0 - foreach f [lindex $o 1] { - if {[string len [file tail $f]] > $i} { - set i [string len [file tail $f]] - } - } - set i [expr $i+2+$s(full)] - ## 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] - if $s(full) { - switch -glob [file type $d$sep$f] { - d* { append f $sep } - l* { append f @ } - default { if [file exec $d$sep$f] { append f * } } - } - } - append res [format "%-${i}s" $f] - if {[incr k]%$j == 0} {set res [string trimr $res]\n} - } - append res \n\n - } - } - return [string trimr $res] -} -interp alias {} ls {} dir + } + return [string trimr $res] +} +interp alias {} ls {} dir -full ## tclindex - creates the tclIndex file # OPTS: -ext - extensions to auto index (defaults to *.tcl) @@ -2317,35 +2532,35 @@ interp alias {} ls {} dir # Outputs: tclIndex/pkgIndex.tcl file to each directory ## proc tclindex args { - 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] } - -p* { set pkg [regexp -nocase $truth [lindex $args 1]] } - -i* { set idx [regexp -nocase $truth [lindex $args 1]] } - default { - return -code error "bad option \"$opt\": must be one of\ - [join [lsort [list -- -extension -package -index]] {, }]" - } - set args [lreplace $args 0 1] - } - } - if ![info exists ext] { - set ext {*.tcl} - if $pkg { lappend ext *[info sharedlibextension] } - } - if [string match {} $args] { - if $idx { eval auto_mkindex [list [pwd]] $ext } - if $pkg { eval pkg_mkIndex [list [pwd]] $ext } - } else { - foreach dir $args { - if [file isdir $dir] { - if $idx { eval auto_mkindex [list [pwd]] $ext } - if $pkg { eval pkg_mkIndex [list [pwd]] $ext } - } - } - } + set truth {^(1|yes|true|on)$}; set pkg 0; set idx 1; + while {[regexp -- {^-[^ ]+} $args opt] && [string compare {} $args]} { + switch -glob -- $opt { + -- { set args [lreplace $args 0 0]; break } + -e* { set ext [lindex $args 1] } + -p* { set pkg [regexp -nocase $truth [lindex $args 1]] } + -i* { set idx [regexp -nocase $truth [lindex $args 1]] } + default { + return -code error "bad option \"$opt\": must be one of\ + [join [lsort [list -- -extension -package -index]] {, }]" + } + set args [lreplace $args 0 1] + } + } + if {![info exists ext]} { + set ext {*.tcl} + if {$pkg} { lappend ext *[info sharedlibextension] } + } + if {[string match {} $args]} { + if {$idx} { eval auto_mkindex [list [pwd]] $ext } + if {$pkg} { eval pkg_mkIndex [list [pwd]] $ext } + } else { + foreach dir $args { + 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 @@ -2354,23 +2569,23 @@ proc tclindex args { # args 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 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 $ix $ix] + } + } } - } - return $l + return $l } ## Unknown changed to get output into tkCon window @@ -2400,7 +2615,8 @@ proc unknown args { set savedErrorCode $errorCode set savedErrorInfo $errorInfo - if {![info exists unknown_handler_order] || ![info exists unknown_handlers]} { + if {![info exists unknown_handler_order] || \ + ![info exists unknown_handlers]} { set unknown_handlers(tcl) tcl_unknown set unknown_handler_order tcl } @@ -2414,7 +2630,7 @@ proc unknown args { # from the "uplevel" command). # set new [split $errorInfo \n] - set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n] return -code $status -errorcode $errorCode \ -errorinfo $new $result @@ -2450,515 +2666,452 @@ proc unknown args { # command, including the command name. proc tcl_unknown args { - global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon - global errorCode errorInfo + 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. + # 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] { unset unknown_pending } - return -code error \ - "self-referential recursion in \"unknown\" for command \"$name\"" - } - ## FIX delete line - set unknown_pending(dummy) dummy - set unknown_pending($name) pending - set ret [catch {auto_load $name} msg] - ## FIX no catch - catch { unset unknown_pending($name) } - if $ret { - 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} { + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if {![info exists auto_noload]} { # - # Strip the last five lines off the error stack (they're - # from the "uplevel" command). + # Make sure we're not trying to load the same proc twice. # - - 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] { - set new [auto_execok $name] - if {$new != ""} { + if {[info exists unknown_pending($name)]} { + 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} { + 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]} { + set new [auto_execok $name] + if {$new != ""} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec [list $new] [lrange $args 1 end]] + #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]] + } + } set errorCode $savedErrorCode set errorInfo $savedErrorInfo - return [uplevel exec [list $new] [lrange $args 1 end]] - #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]] - } + ## + ## History substitution moved into tkConEvalCmd + ## + if {[string compare $name "::"] == 0} { + set name "" + } + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg" + } + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds]} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } } - set errorCode $savedErrorCode - set errorInfo $savedErrorInfo - ## - ## History substitution moved into tkConEvalCmd + return -code continue +} + +;proc tkConBindings {} { + global TKCON tcl_platform tk_version + + #----------------------------------------------------------------------- + # 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 } + } + + ## Get all Text bindings into TkConsole + foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] } + ## We really didn't want the newline insertion + bind TkConsole {} + + ## Now make all our virtual event bindings + foreach {ev key} [subst -nocommand -noback { + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> <$TKCON(meta)-i> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + }] { + event add $ev $key + ## Make sure the specific key won't be defined + bind TkConsole $key {} + } + + ## Make the ROOT bindings + bind $TKCON(root) <> exit + bind $TKCON(root) <> { tkConNew } + bind $TKCON(root) <> { tkConDestroy } + bind $TKCON(root) <> { tkConAbout } + bind $TKCON(root) <> { tkConHelp } + bind $TKCON(root) <> { tkConFindBox $TKCON(console) } + bind $TKCON(root) <> { + tkConAttach {} + tkConPrompt "\n" [tkConCmdGet $TKCON(console)] + } + bind $TKCON(root) <> { + if {[string compare {} $TKCON(name)]} { + tkConAttach $TKCON(name) + } else { + tkConAttach Main + } + tkConPrompt "\n" [tkConCmdGet $TKCON(console)] + } + bind $TKCON(root) <> { + tkConAttach Main + tkConPrompt "\n" [tkConCmdGet $TKCON(console)] + } + + ## Menu items need null PostCon bindings to avoid the TagProc ## - set cmds [info commands $name*] - if {[llength $cmds] == 1} { - return [uplevel [lreplace $args 0 0 $cmds]] + foreach ev [bind $TKCON(root)] { + bind PostCon $ev { + # empty + } } - if {[llength $cmds]} { - if {$name == ""} { - return -code error "empty command name \"\"" - } else { - return -code error \ - "ambiguous command name \"$name\": [lsort $cmds]" - } - } - } - return -code continue -} - -proc tkConBindings {} { - global tkCon tcl_platform tk_version - - #----------------------------------------------------------------------- - # 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 } - } - - ## <> - bind $tkCon(root) exit - ## <> - bind $tkCon(root) { tkConNew } - ## <> - bind $tkCon(root) { tkConDestroy } - ## <> - bind $tkCon(root) { tkConAbout } - ## <> - bind $tkCon(root) { tkConHelp } - ## <> - bind $tkCon(root) { tkConFindBox $tkCon(console) } - ## <> - bind $tkCon(root) { - tkConAttach {} - tkConPrompt "\n" [tkConCmdGet $tkCon(console)] - } - ## <> - bind $tkCon(root) { - if [string comp {} $tkCon(name)] { - tkConAttach $tkCon(name) - } else { - tkConAttach Main - } - tkConPrompt "\n" [tkConCmdGet $tkCon(console)] - } - ## <> - bind $tkCon(root) { - tkConAttach Main - tkConPrompt "\n" [tkConCmdGet $tkCon(console)] - } - - ## 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 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] { \ - \ - }] { - bind Console $ev [bind Text $ev] - } - - ## Redefine for Console what we need - ## - if [string compare {} [info command event]] { + + # 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 TkConsole <$copy> {tkConCopy %W} + bind TkConsole <$cut> {tkConCut %W} + bind TkConsole <$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] + } + } + } + ## Try and get the default selection, then try and get the selection + ## type TEXT, then try and get the clipboard if nothing else is available + ;proc tkConPaste w { + if { + ![catch {selection get -displayof $w} tmp] || + ![catch {selection get -displayof $w -type TEXT} tmp] || + ![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 } + } + } + + ## Redefine for TkConsole what we need + ## event delete <> tkConClipboardKeysyms - } else { - tkConClipboardKeysyms F16 F20 F18 - tkConClipboardKeysyms Control-c Control-x Control-v - } - bind Console {catch {tkConInsert %W [selection get -displayof %W]}} + bind TkConsole { + catch { tkConInsert %W [selection get -displayof %W] } + } - bind Console {+ - catch { - eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] - %W mark set insert sel.first + bind TkConsole {+ + catch { + eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] + %W mark set insert sel.first + } } - } - ## binding editor needed - ## binding for .tkconrc + ## binding editor needed + ## binding for .tkconrc - ## <> - bind Console { - if [%W compare {insert linestart} != {limit linestart}] { - tkTextSetCursor %W [tkTextUpDownLine %W -1] - } else { - 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 TkConsole <> { + if {[%W compare insert > limit]} {tkConExpand %W path} + break } - } - ## <> - bind Console { - if [%W compare {insert linestart} != {end-1c linestart}] { - tkTextSetCursor %W [tkTextUpDownLine %W 1] - } else { - if {$tkCon(event) < [tkConEvalSlave history nextid]} { + bind TkConsole <> { + if {[%W compare insert > limit]} {tkConExpand %W proc} + } + bind TkConsole <> { + if {[%W compare insert > limit]} {tkConExpand %W var} + } + bind TkConsole <> { + if {[%W compare insert > limit]} {tkConExpand %W} + } + bind TkConsole <> { + if {[%W compare insert >= limit]} { + tkConInsert %W \t + } + } + bind TkConsole <> { + tkConEval %W + } + bind TkConsole { + if {[string compare {} [%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 TkConsole { + if {[string compare {} [%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 TkConsole [bind TkConsole ] + + bind TkConsole { + tkConInsert %W %A + } + + bind TkConsole { + if {[%W compare {limit linestart} == {insert linestart}]} { + tkTextSetCursor %W limit + } else { + tkTextSetCursor %W {insert linestart} + } + } + bind TkConsole { + if {[%W compare insert < limit]} break + %W delete insert + } + bind TkConsole { + if {[%W compare insert < limit]} break + if {[%W compare insert == {insert lineend}]} { + %W delete insert + } else { + %W delete insert {insert lineend} + } + } + bind TkConsole <> { + ## Clear console buffer, without losing current command line input + set TKCON(tmp) [tkConCmdGet %W] + clear + tkConPrompt {} $TKCON(tmp) + } + bind TkConsole <> { + if {[%W compare {insert linestart} != {limit linestart}]} { + tkTextSetCursor %W [tkTextUpDownLine %W -1] + } else { + tkConEvent -1 + } + } + bind TkConsole <> { + if {[%W compare {insert linestart} != {end-1c linestart}]} { + tkTextSetCursor %W [tkTextUpDownLine %W 1] + } else { + tkConEvent 1 + } + } + bind TkConsole <> { tkConEvent 1 } + bind TkConsole <> { tkConEvent -1 } + bind TkConsole <> { tkConEvent -1 [tkConCmdGet %W] } + bind TkConsole <> { tkConEvent 1 [tkConCmdGet %W] } + bind TkConsole <> { + ## Transpose current and previous chars + if {[%W compare insert > "limit+1c"]} { tkTextTranspose %W } + } + bind TkConsole <> { + ## Clear command line (Unix shell staple) %W delete limit end - if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} { - %W insert limit $tkCon(cmdbuf) + } + bind TkConsole <> { + ## 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 limit [tkConEvalSlave history event $tkCon(event)] + %W delete limit end-1c } + tkConInsert %W $TKCON(tmp) %W see end - } - } - } - ## <> - bind Console { - if [%W compare insert > limit] {tkConExpand %W path} - break - } - ## <> - bind Console { - if [%W compare insert > limit] {tkConExpand %W proc} - } - ## <> - bind Console { - if [%W compare insert > limit] {tkConExpand %W var} - } - ## <> - bind Console { - if [%W compare insert >= limit] { - tkConInsert %W \t - } - } - ## <> - no mod - bind Console { - tkConEval %W - } - bind Console [bind Console ] - bind Console { - 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 { - 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 [bind Console ] - - bind Console { - tkConInsert %W %A - } - - bind Console { - if [%W compare {limit linestart} == {insert linestart}] { - tkTextSetCursor %W limit - } else { - tkTextSetCursor %W {insert linestart} - } - } - bind Console { - if [%W compare insert < limit] break - %W delete insert - } - bind Console { - if [%W compare insert < limit] break - if [%W compare insert == {insert lineend}] { - %W delete insert - } else { - %W delete insert {insert lineend} - } - } - ## <> - bind Console { - ## Clear console buffer, without losing current command line input - set tkCon(tmp) [tkConCmdGet %W] - clear - tkConPrompt {} $tkCon(tmp) - } - ## <> - bind Console { - ## 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) - } else { - %W insert limit [tkConEvalSlave history event $tkCon(event)] - } - %W see end - } - } - ## <> - bind Console { - ## 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 - } - } - ## <> - bind Console { - ## 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 - } - ## <> - bind Console { - ## 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 { - ## Transpose current and previous chars - if [%W compare insert > limit] { tkTextTranspose %W } - } - ## <> - bind Console { - ## Clear command line (Unix shell staple) - %W delete limit end - } - ## <> - bind Console { - ## 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 delete limit end-1c - } - tkConInsert %W $tkCon(tmp) - %W see end - } - catch {bind Console { tkTextScrollPages %W -1 }} - catch {bind Console { tkTextScrollPages %W -1 }} - catch {bind Console { tkTextScrollPages %W 1 }} - catch {bind Console { 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 { - 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 Console bindings - ## - - ## - ## Bindings for doing special things based on certain keys - ## - bind PostCon { - if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && - [string comp \\ [%W get insert-2c]]} { - tkConMatchPair %W \( \) limit - } - } - bind PostCon { - if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && - [string comp \\ [%W get insert-2c]]} { - tkConMatchPair %W \[ \] limit - } - } - bind PostCon { - if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && - [string comp \\ [%W get insert-2c]]} { - tkConMatchPair %W \{ \} limit - } - } - bind PostCon { - if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && - [string comp \\ [%W get insert-2c]]} { - tkConMatchQuote %W limit - } - } - - bind PostCon { - if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W } - } + } + catch {bind TkConsole { tkTextScrollPages %W -1 }} + catch {bind TkConsole { tkTextScrollPages %W -1 }} + catch {bind TkConsole { tkTextScrollPages %W 1 }} + catch {bind TkConsole { tkTextScrollPages %W 1 }} + bind TkConsole <$TKCON(meta)-d> { + if {[%W compare insert >= limit]} { + %W delete insert {insert wordend} + } + } + bind TkConsole <$TKCON(meta)-BackSpace> { + if {[%W compare {insert -1c wordstart} >= limit]} { + %W delete {insert -1c wordstart} insert + } + } + bind TkConsole <$TKCON(meta)-Delete> { + if {[%W compare insert >= limit]} { + %W delete insert {insert wordend} + } + } + bind TkConsole { + if { + (!$tkPriv(mouseMoved) || $tk_strictMotif) && + (![catch {selection get -displayof %W} TKCON(tmp)] || + ![catch {selection get -displayof %W -type TEXT} TKCON(tmp)] || + ![catch {selection get -displayof %W \ + -selection CLIPBOARD} 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 TkConsole bindings + ## + + ## + ## Bindings for doing special things based on certain keys + ## + bind PostCon { + if {$TKCON(lightbrace) && $TKCON(blinktime)>99 && \ + [string compare \\ [%W get insert-2c]]} { + tkConMatchPair %W \( \) limit + } + } + bind PostCon { + if {$TKCON(lightbrace) && $TKCON(blinktime)>99 && \ + [string compare \\ [%W get insert-2c]]} { + tkConMatchPair %W \[ \] limit + } + } + bind PostCon { + if {$TKCON(lightbrace) && $TKCON(blinktime)>99 && \ + [string compare \\ [%W get insert-2c]]} { + tkConMatchPair %W \{ \} limit + } + } + bind PostCon { + if {$TKCON(lightbrace) && $TKCON(blinktime)>99 && \ + [string compare \\ [%W get insert-2c]]} { + tkConMatchQuote %W limit + } + } + + bind PostCon { + if {$TKCON(lightcmd) && [string compare {} %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. +## too much CPU time... ## -proc tkConTagProc w { - set i [$w index "insert-1c wordstart"] - set j [$w index "insert-1c wordend"] - if {[string comp {} \ - [tkConEvalAttached info command [list [$w get $i $j]]]]} { - $w tag add proc $i $j - } else { - $w tag remove proc $i $j - } +;proc tkConTagProc w { + set i [$w index "insert-1c wordstart"] + set j [$w index "insert-1c wordend"] + if {[string compare {} \ + [tkConEvalAttached [list info commands [$w get $i $j]]]]} { + $w tag add proc $i $j + } else { + $w tag remove proc $i $j + } } ## tkConMatchPair - blinks a matching pair of characters @@ -2973,29 +3126,37 @@ proc tkConTagProc w { # c2 - second char of pair # Calls: tkConBlink ## -proc tkConMatchPair {w c1 c2 {lim 1.0}} { - if [string comp {} [set ix [$w search -back $c1 insert $lim]]] { - while {[string match {\\} [$w get $ix-1c]] && - [string comp {} [set ix [$w search -back $c1 $ix-1c $lim]]]} {} - 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 $lim]]]} { - if {[string match {\\} [$w get $ix-1c]]} continue - incr j -1 - } +;proc tkConMatchPair {w c1 c2 {lim 1.0}} { + if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { + while { + [string match {\\} [$w get $ix-1c]] && + [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]] + } {} + set i1 insert-1c + while {[string compare {} $ix]} { + set i0 $ix + set j 0 + while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} { + append i0 +1c + if {[string match {\\} [$w get $i0-2c]]} continue + incr j + } + if {!$j} break + set i1 $ix + while {$j && [string compare {} \ + [set ix [$w search -back $c1 $ix $lim]]]} { + if {[string match {\\} [$w get $ix-1c]]} continue + incr j -1 + } + } + if {[string match {} $ix]} { set ix [$w index $lim] } + } else { set ix [$w index $lim] } + global TKCON + if {$TKCON(blinkrange)} { + tkConBlink $w $ix [$w index insert] + } else { + tkConBlink $w $ix $ix+1c [$w index insert-1c] [$w index insert] } - if [string match {} $ix] { set ix [$w index $lim] } - } else { set ix [$w index $lim] } - tkConBlink $w $ix [$w index insert] } ## tkConMatchQuote - blinks between matching quotes. @@ -3004,33 +3165,38 @@ proc tkConMatchPair {w c1 c2 {lim 1.0}} { # ARGS: w - console text widget # Calls: tkConBlink ## -proc tkConMatchQuote {w {lim 1.0}} { - set i insert-1c - set j 0 - while {[string comp {} [set i [$w search -back \" $i $lim]]]} { - 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. +;proc tkConMatchQuote {w {lim 1.0}} { + set i insert-1c + set j 0 + while {[string compare [set i [$w search -back \" $i $lim]] {}]} { + if {[string match {\\} [$w get $i-1c]]} continue + if {!$j} {set i0 $i} + incr j + } + if {[expr {$j&1}]} { + global TKCON + if {$TKCON(blinkrange)} { + tkConBlink $w $i0 [$w index insert] + } else { + tkConBlink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] + } + } else { + tkConBlink $w [$w index insert-1c] [$w index insert] + } +} + +## tkConBlink - blinks between n index pairs 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 +;proc tkConBlink {w args} { + global TKCON + eval $w tag add blink $args + after $TKCON(blinktime) eval $w tag remove blink $args + return } @@ -3042,20 +3208,20 @@ proc tkConBlink {w i1 i2} { # 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 +;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 } - } - $w insert insert $s - $w see insert + 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 - @@ -3063,35 +3229,41 @@ proc tkConInsert {w s} { # 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 +# 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 { - pa* { set res [tkConExpandPathname $str] } - 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 comp [lindex $res 0] $str]} { - puts stdout [lreplace $res 0 0] - } - } - } else bell - return [incr len -1] +;proc tkConExpand {w {type ""}} { + global TKCON + 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 { + pa* { set res [tkConExpandPathname $str] } + pr* { set res [tkConExpandProcname $str] } + v* { set res [tkConExpandVariable $str] } + default { + set res {} + foreach t $TKCON(expandorder) { + if {[string compare {} [set res [tkConExpand$t $str]]]} break + } + } + } + set len [llength $res] + if {$len} { + $w delete $tmp insert + $w insert $tmp [lindex $res 0] + if {$len > 1} { + if {$TKCON(showmultiple) && \ + ![string compare [lindex $res 0] $str]} { + puts stdout [lreplace $res 0 0] + } + } + } else { bell } + return [incr len -1] } ## tkConExpandPathname - expand a file pathname based on $str @@ -3101,39 +3273,50 @@ proc tkConExpand {w type} { # Returns: list containing longest unique match followed by all the # possible further matches ## -proc tkConExpandPathname str { - set pwd [tkConEvalAttached pwd] - if [catch {tkConEvalAttached [list cd [file dirname $str]]} err] { - return -code error $err - } - if [catch {lsort [tkConEvalAttached glob [file tail $str]*]} m] { - set match {} - } else { - if {[llength $m] > 1} { - set tmp [tkConExpandBestMatch $m [file tail $str]] - if [string match ?*/* $str] { - set tmp [file dirname $str]/$tmp - } elseif {[string match /* $str]} { - set tmp /$tmp - } - regsub -all { } $tmp {\\ } tmp - set match [linsert $m 0 $tmp] +;proc tkConExpandPathname str { + set pwd [tkConEvalAttached pwd] + if {[catch {tkConEvalAttached [list cd [file dirname $str]]} err]} { + return -code error $err + } + set dir [file tail $str] + ## Check to see if it was known to be a directory and keep the trailing + ## slash if so (file tail cuts it off) + if {[string match */ $str]} { append dir / } + if {[catch {lsort [tkConEvalAttached [list glob $dir*]]} m]} { + set match {} } else { - ## This may look goofy, but it handles spaces in path names - eval append match $m - if [file isdir $match] {append match /} - if [string match ?*/* $str] { - set match [file dirname $str]/$match - } elseif {[string match /* $str]} { - set match /$match - } - regsub -all { } $match {\\ } match - ## Why is this one needed and the ones below aren't!! - set match [list $match] - } - } - tkConEvalAttached [list cd $pwd] - return $match + if {[llength $m] > 1} { + global tcl_platform + if {[string match windows $tcl_platform(platform)]} { + ## Windows is screwy because it's case insensitive + set tmp [tkConExpandBestMatch [string tolower $m] \ + [string tolow [file tail $str]]] + } else { + set tmp [tkConExpandBestMatch $m [file tail $str]] + } + if {[string match ?*/* $str]} { + set tmp [file dirname $str]/$tmp + } elseif {[string match /* $str]} { + set tmp /$tmp + } + regsub -all { } $tmp {\\ } tmp + set match [linsert $m 0 $tmp] + } else { + ## This may look goofy, but it handles spaces in path names + eval append match $m + if {[file isdir $match]} {append match /} + if {[string match ?*/* $str]} { + set match [file dirname $str]/$match + } elseif {[string match /* $str]} { + set match /$match + } + regsub -all { } $match {\\ } match + ## Why is this one needed and the ones below aren't!! + set match [list $match] + } + } + tkConEvalAttached [list cd $pwd] + return $match } ## tkConExpandProcname - expand a tcl proc name based on $str @@ -3141,16 +3324,35 @@ proc tkConExpandPathname str { # Calls: tkConExpandBestMatch # Returns: list containing longest unique match followed by all the # possible further matches -## -proc tkConExpandProcname str { - set match [tkConEvalAttached 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 +## +;proc tkConExpandProcname str { + global TKCON + set match [tkConEvalAttached [list info commands $str*]] + if {[llength $match] == 0 && $TKCON(A:namespace)} { + if {$TKCON(A:itcl)} { + ## They are [incr Tcl] namespaces + set ns [tkConEvalAttached [list info namespace all $str*]] + } else { + ## They are Tk8 namespaces + set ns [tkConEvalAttached [list namespace children {} $str*]] + } + ## Tk8 could use [info commands ::*] + if {[llength $ns]==1} { + foreach p [tkConEvalAttached \ + [list namespace $ns { ::info procs }]] { + lappend match ${ns}::$p + } + } else { + set match $ns + } + } + 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 @@ -3159,26 +3361,26 @@ proc tkConExpandProcname str { # Returns: list containing longest unique match followed by all the # possible further matches ## -proc tkConExpandVariable str { - if [regexp {([^\(]*)\((.*)} $str junk ary str] { - ## Looks like they're trying to expand an array. - set match [tkConEvalAttached 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\)} - ## Space transformation avoided for array names. - } else { - set match [tkConEvalAttached info vars $str*] - if {[llength $match] > 1} { - regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str - set match [linsert $match 0 $str] +;proc tkConExpandVariable str { + if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { + ## Looks like they're trying to expand an array. + set match [tkConEvalAttached [list 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\)} + ## Space transformation avoided for array names. } else { - regsub -all { } $match {\\ } match + set match [tkConEvalAttached [list 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 + return $match } ## tkConExpandBestMatch2 - finds the best unique match in a list of names @@ -3187,17 +3389,17 @@ proc tkConExpandVariable str { # ARGS: l - list to find best unique match in # Returns: longest unique match in the list ## -proc tkConExpandBestMatch2 {l {e {}}} { - set s [lindex $l 0] - if {[llength $l]>1} { - set i [expr [string length $s]-1] - foreach l $l { - while {$i>=0 && [string first $s $l]} { - set s [string range $s 0 [incr i -1]] - } +;proc tkConExpandBestMatch2 {l {e {}}} { + set s [lindex $l 0] + if {[llength $l]>1} { + set i [expr {[string length $s]-1}] + foreach l $l { + while {$i>=0 && [string first $s $l]} { + set s [string range $s 0 [incr i -1]] + } + } } - } - return $s + return $s } ## tkConExpandBestMatch - finds the best unique match in a list of names @@ -3207,18 +3409,18 @@ proc tkConExpandBestMatch2 {l {e {}}} { # 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]] - } +;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 + return $ec } # Here is a group of functions that is only used when Tkcon is @@ -3247,253 +3449,255 @@ proc tkConExpandBestMatch {l {e {}}} { ## These functions courtesy Jan Nijtmans (nijtmans@nici.kun.nl) ## if {[string compare [info command tk] tk]} { - proc tk {option args} { - if {![string match app* $option]} { - error "wrong option \"$option\": should be appname" + ;proc tk {option args} { + if {![string match app* $option]} { + error "wrong option \"$option\": should be appname" + } + return "tkcon.tcl" } - return "tkcon.tcl" - } } - + if {[string compare [info command toplevel] toplevel]} { - proc toplevel {name args} { - eval frame $name $args - pack $name - } + ;proc toplevel {name args} { + eval frame $name $args + pack $name + } } -proc tkConSafeSource {i f} { - set fd [open $f r] - set r [read $fd] - close $fd - if {[catch {interp eval $i $r} msg]} { - error $msg - } +;proc tkConSafeSource {i f} { + set fd [open $f r] + set r [read $fd] + close $fd + if {[catch {interp eval $i $r} msg]} { + error $msg + } } -proc tkConSafeOpen {i f {m r}} { +;proc tkConSafeOpen {i f {m r}} { set fd [open $f $m] interp transfer {} $fd $i return $fd } -proc tkConSafeLoad {i f p} { - global tk_version tk_patchLevel tk_library - if [string compare $p Tk] { - load $f $p $i - } else { - foreach command {button canvas checkbutton entry frame label - listbox message radiobutton scale scrollbar text toplevel} { - $i alias $command tkConSafeItem $i $command - } - $i alias image tkConSafeImage $i - foreach command {pack place grid destroy winfo} { - $i alias $command tkConSafeManage $i $command - } - if [string comp {} [info command event]] { - $i alias event tkConSafeManage $i $command - } - frame .${i}_dot -width 300 -height 300 -relief raised - pack .${i}_dot -side left - $i alias tk tk - $i alias bind tkConSafeBind $i - $i alias bindtags tkConSafeBindtags $i - $i alias . tkConSafeWindow $i {} - foreach var {tk_version tk_patchLevel tk_library} { - $i eval set $var [set $var] - } - $i eval { - package provide Tk $tk_version - if {[lsearch -exact $auto_path $tk_library] < 0} { - lappend auto_path $tk_library - } - } - return "" - } -} - -proc tkConSafeSubst {i a} { - set arg1 "" - foreach {arg value} $a { - if {![string compare $arg -textvariable] || - ![string compare $arg -variable]} { - set newvalue "[list $i] $value" - global $newvalue - if [interp eval $i info exists $value] { - set $newvalue [interp eval $i set $value] - } else { - catch {unset $newvalue} - } - $i eval trace variable $value rwu \{[list tkcon set $newvalue $i]\} - set value $newvalue - } elseif {![string compare $arg -command]} { - set value [list $i eval $value] - } - lappend arg1 $arg $value - } - return $arg1 -} - -proc tkConSafeItem {i command w args} { - set args [tkConSafeSubst $i $args] - set code [catch "$command [list .${i}_dot$w] $args" msg] - $i alias $w tkConSafeWindow $i $w - regsub -all .${i}_dot $msg {} msg - return -code $code $msg -} - -proc tkConSafeManage {i command args} { - set args1 "" - foreach arg $args { - if [string match . $arg] { - set arg .${i}_dot - } elseif [string match .* $arg] { - set arg ".${i}_dot$arg" - } - lappend args1 $arg - } - set code [catch "$command $args1" msg] - regsub -all .${i}_dot $msg {} msg - return -code $code $msg +;proc tkConSafeLoad {i f p} { + global tk_version tk_patchLevel tk_library + if {[string compare $p Tk]} { + load $f $p $i + } else { + foreach command {button canvas checkbutton entry frame label + listbox message radiobutton scale scrollbar text toplevel} { + $i alias $command tkConSafeItem $i $command + } + $i alias image tkConSafeImage $i + foreach command {pack place grid destroy winfo} { + $i alias $command tkConSafeManage $i $command + } + if {[string compare {} [info command event]]} { + $i alias event tkConSafeManage $i $command + } + frame .${i}_dot -width 300 -height 300 -relief raised + pack .${i}_dot -side left + $i alias tk tk + $i alias bind tkConSafeBind $i + $i alias bindtags tkConSafeBindtags $i + $i alias . tkConSafeWindow $i {} + foreach var {tk_version tk_patchLevel tk_library} { + $i eval set $var [set $var] + } + $i eval { + package provide Tk $tk_version + if {[lsearch -exact $auto_path $tk_library] < 0} { + lappend auto_path $tk_library + } + } + return "" + } } -# -# FIX: this funcion doesn't work yet if the binding starts with "+". -# -proc tkConSafeBind {i w args} { - if [string match . $w] { - set w .${i}_dot - } elseif [string match .* $w] { - set w ".${i}_dot$w" - } - if {[llength $args] > 1} { - set args [list [lindex $args 0] "[list $i] eval [list [lindex $args 1]]"] - } - set code [catch "bind $w $args" msg] - if {[llength $args] <2 && code == 0} { - set msg [lindex $msg 3] - } - return -code $code $msg -} - -proc tkConSafeImage {i option args} { - set code [catch "image $option $args" msg] - if {[string match cr* $option]} { - $i alias $msg $msg - } - return -code $code $msg -} - -proc tkConSafeBindtags {i w {tags {}}} { - if [string match . $w] { - set w .${i}_dot - } elseif [string match .* $w] { - set w ".${i}_dot$w" - } - set newtags {} - foreach tag $tags { - if [string match . $tag] { - lappend newtags .${i}_dot - } elseif [string match .* $tag] { - lappend newtags ".${i}_dot$tag" - } else { - lappend newtags $tag +;proc tkConSafeSubst {i a} { + set arg1 "" + foreach {arg value} $a { + if {![string compare $arg -textvariable] || + ![string compare $arg -variable]} { + set newvalue "[list $i] $value" + global $newvalue + if {[interp eval $i info exists $value]} { + set $newvalue [interp eval $i set $value] + } else { + catch {unset $newvalue} + } + $i eval trace variable $value rwu \{[list tkcon set $newvalue $i]\} + set value $newvalue + } elseif {![string compare $arg -command]} { + set value [list $i eval $value] + } + lappend arg1 $arg $value } - } - if [string match $tags {}] { - set code [catch {bindtags $w} msg] - regsub -all \\.${i}_dot $msg {} msg - } else { - set code [catch {bindtags $w $newtags} msg] - } - return -code $code $msg + return $arg1 } -proc tkConSafeWindow {i w option args} { - if {[string match conf* $option] && [llength $args] > 1} { +;proc tkConSafeItem {i command w args} { set args [tkConSafeSubst $i $args] - } elseif {[string match itemco* $option] && [llength $args] > 2} { - set args "[list [lindex $args 0]] [tkConSafeSubst $i [lrange $args 1 end]]" - } elseif {[string match cr* $option]} { - if {[llength $args]%2} { - set args "[list [lindex $args 0]] [tkConSafeSubst $i [lrange $args 1 end]]" - } else { - set args [tkConSafeSubst $i $args] + set code [catch "$command [list .${i}_dot$w] $args" msg] + $i alias $w tkConSafeWindow $i $w + regsub -all .${i}_dot $msg {} msg + return -code $code $msg +} + +;proc tkConSafeManage {i command args} { + set args1 "" + foreach arg $args { + if {[string match . $arg]} { + set arg .${i}_dot + } elseif {[string match .* $arg]} { + set arg ".${i}_dot$arg" + } + lappend args1 $arg } - } elseif {[string match bi* $option] && [llength $args] > 2} { - set args [list [lindex $args 0] [lindex $args 1] "[list $i] eval [list [lindex $args 2]]"] - } - set code [catch ".${i}_dot$w $option $args" msg] - if {$code} { + set code [catch "$command $args1" msg] regsub -all .${i}_dot $msg {} msg - } elseif {[string match conf* $option] || [string match itemco* $option]} { - if {[llength $args] == 1} { - switch -- $args { - -textvariable - -variable { - set msg "[lrange $msg 0 3] [list [lrange [lindex $msg 4] 1 end]]" - } - -command - updatecommand { - set msg "[lrange $msg 0 3] [list [lindex [lindex $msg 4] 2]]" - } - } - } elseif {[llength $args] == 0} { - set args1 "" - foreach el $msg { - switch -- [lindex $el 0] { - -textvariable - -variable { - set el "[lrange $el 0 3] [list [lrange [lindex $el 4] 1 end]]" - } - -command - updatecommand { - set el "[lrange $el 0 3] [list [lindex [lindex $el 4] 2]]" - } - } - lappend args1 $el - } - set msg $args1 + return -code $code $msg +} + +# +# FIX: this function doesn't work yet if the binding starts with "+". +# +;proc tkConSafeBind {i w args} { + if {[string match . $w]} { + set w .${i}_dot + } elseif {[string match .* $w]} { + set w ".${i}_dot$w" + } + if {[llength $args] > 1} { + set args [list [lindex $args 0] \ + "[list $i] eval [list [lindex $args 1]]"] + } + set code [catch "bind $w $args" msg] + if {[llength $args] <2 && code == 0} { + set msg [lindex $msg 3] + } + return -code $code $msg +} + +;proc tkConSafeImage {i option args} { + set code [catch "image $option $args" msg] + if {[string match cr* $option]} { + $i alias $msg $msg + } + return -code $code $msg +} + +;proc tkConSafeBindtags {i w {tags {}}} { + if {[string match . $w]} { + set w .${i}_dot + } elseif {[string match .* $w]} { + set w ".${i}_dot$w" + } + set newtags {} + foreach tag $tags { + if {[string match . $tag]} { + lappend newtags .${i}_dot + } elseif {[string match .* $tag]} { + lappend newtags ".${i}_dot$tag" + } else { + lappend newtags $tag + } } - } elseif {[string match cg* $option] || [string match itemcg* $option]} { - switch -- $args { - -textvariable - -variable { - set msg [lrange $msg 1 end] - } - -command - updatecommand { - set msg [lindex $msg 2] - } + if {[string match $tags {}]} { + set code [catch {bindtags $w} msg] + regsub -all \\.${i}_dot $msg {} msg + } else { + set code [catch {bindtags $w $newtags} msg] } - } elseif [string match bi* $option] { - if {[llength $args] == 2 && $code == 0} { - set msg [lindex $msg 2] + return -code $code $msg +} + +;proc tkConSafeWindow {i w option args} { + if {[string match conf* $option] && [llength $args] > 1} { + set args [tkConSafeSubst $i $args] + } elseif {[string match itemco* $option] && [llength $args] > 2} { + set args "[list [lindex $args 0]] [tkConSafeSubst $i [lrange $args 1 end]]" + } elseif {[string match cr* $option]} { + if {[llength $args]%2} { + set args "[list [lindex $args 0]] [tkConSafeSubst $i [lrange $args 1 end]]" + } else { + set args [tkConSafeSubst $i $args] + } + } elseif {[string match bi* $option] && [llength $args] > 2} { + set args [list [lindex $args 0] [lindex $args 1] "[list $i] eval [list [lindex $args 2]]"] + } + set code [catch ".${i}_dot$w $option $args" msg] + if {$code} { + regsub -all .${i}_dot $msg {} msg + } elseif {[string match conf* $option] || [string match itemco* $option]} { + if {[llength $args] == 1} { + switch -- $args { + -textvariable - -variable { + set msg "[lrange $msg 0 3] [list [lrange [lindex $msg 4] 1 end]]" + } + -command - updatecommand { + set msg "[lrange $msg 0 3] [list [lindex [lindex $msg 4] 2]]" + } + } + } elseif {[llength $args] == 0} { + set args1 "" + foreach el $msg { + switch -- [lindex $el 0] { + -textvariable - -variable { + set el "[lrange $el 0 3] [list [lrange [lindex $el 4] 1 end]]" + } + -command - updatecommand { + set el "[lrange $el 0 3] [list [lindex [lindex $el 4] 2]]" + } + } + lappend args1 $el + } + set msg $args1 + } + } elseif {[string match cg* $option] || [string match itemcg* $option]} { + switch -- $args { + -textvariable - -variable { + set msg [lrange $msg 1 end] + } + -command - updatecommand { + set msg [lindex $msg 2] + } + } + } elseif {[string match bi* $option]} { + if {[llength $args] == 2 && $code == 0} { + set msg [lindex $msg 2] + } } - } - return -code $code $msg + return -code $code $msg } ## 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] -if !$tkCon(WWW) { - 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 +set TKCON(SCRIPT) [info script] +if {!$TKCON(WWW)} { + 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 + } + } + catch {unset link} + if {[string match relative [file pathtype $TKCON(SCRIPT)]]} { + set TKCON(SCRIPT) [file join [pwd] $TKCON(SCRIPT)] } - } - catch {unset 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) + +;proc tkConResource {} { + global TKCON + uplevel \#0 [list source $TKCON(SCRIPT)] + tkConBindings + tkConInitSlave $TKCON(exec) } ## Initialize only if we haven't yet ## -if [catch {winfo exists $tkCon(root)}] tkConInit +if {[catch {winfo exists $TKCON(root)}]} tkConInit -- 2.23.0