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