From 7788220c5d036354c81bce7384c4078dadf97a42 Mon Sep 17 00:00:00 2001 From: Jeff Hobbs Date: Tue, 19 Sep 2000 18:24:43 +0000 Subject: [PATCH] Initial revision --- README.txt | 42 + docs/bindings.html | 130 +++ docs/changes.txt | 811 ++++++++++++++++ docs/demopic.gif | Bin 0 -> 18619 bytes docs/dump.html | 77 ++ docs/idebug.html | 99 ++ docs/index.html | 53 + docs/license.terms | 40 + docs/limits.html | 55 ++ docs/nontcl.html | 54 ++ docs/observe.html | 80 ++ docs/perl.txt | 109 +++ docs/plugin.html | 66 ++ docs/procs.html | 143 +++ docs/purpose.html | 63 ++ docs/start.html | 313 ++++++ docs/tkcon.html | 142 +++ docs/todo.html | 76 ++ extra/console1_1.tcl | 2209 ++++++++++++++++++++++++++++++++++++++++++ extra/stripped.tcl | 1083 +++++++++++++++++++++ tkcon.tcl | 2141 ++++++++++++++++++++++++++++++++++++++++ 21 files changed, 7786 insertions(+) create mode 100644 README.txt create mode 100755 docs/bindings.html create mode 100755 docs/changes.txt create mode 100755 docs/demopic.gif create mode 100755 docs/dump.html create mode 100755 docs/idebug.html create mode 100755 docs/index.html create mode 100755 docs/license.terms create mode 100755 docs/limits.html create mode 100755 docs/nontcl.html create mode 100755 docs/observe.html create mode 100755 docs/perl.txt create mode 100755 docs/plugin.html create mode 100755 docs/procs.html create mode 100755 docs/purpose.html create mode 100755 docs/start.html create mode 100755 docs/tkcon.html create mode 100755 docs/todo.html create mode 100644 extra/console1_1.tcl create mode 100755 extra/stripped.tcl create mode 100755 tkcon.tcl diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..7f076ee --- /dev/null +++ b/README.txt @@ -0,0 +1,42 @@ +WHAT: Enhanced Tk Console for all Tk platforms + +WHERE: http://www.purl.org/net/hobbs/tcl/script/tkcon/ + http://www.hobbs.wservice.com/tcl/script/tkcon/ + http://www.neosoft.com/tcl/ (somewhere in the devel area) + +REQUIREMENTS: Tcl 7.6 / Tk 4.2 (as least the stable versions) + Tested through Tcl/Tk8.4. + TkCon is all Tcl/Tk code, no compiling required + +TkCon is a replacement for the standard console that comes with Tk (on +Windows/Mac, but also works on Unix). TkCon provides many more features +than the standard console and works on all platforms where Tcl/Tk is +available. It is meant primarily to aid one when working with the little +details inside tcl and tk and to give Unix users the GUI console provided +by default in the Mac and Windows Tk. + +FEATURES: + Command history + Path (Unix style) / Proc / Variable name expansion + Multiple consoles, each with its own state (via multiple interpreters) + Captures stdout and stderr to console window (puts overridden) + Hot errors (click on error result to see stack trace) + Electric character matching (a la emacs) + Electric proc highlighting + Enhanced history searching + Configurable + Cut / Copy / Paste between windows (interoperates with native platform) + Communication between consoles and other Tk interpreters + (including non-tcl ones) + Works on all Tk platforms + +CONTACT: Jeffrey Hobbs, jeff.hobbs at acm.org + +GETTING STARTED: + +TkCon is a single drop-in file. On Windows, I place this on the desktop +and double-click on it instead of wish/tclsh. On Unix, I place it in a +known bin directory and run this instead of wish. I don't have a Mac... + +Documentation can be reading by starting with index.html in the docs/ +subdirectory. Happying Tcl'ing! diff --git a/docs/bindings.html b/docs/bindings.html new file mode 100755 index 0000000..9f168b0 --- /dev/null +++ b/docs/bindings.html @@ -0,0 +1,130 @@ + + +TkCon: Special Bindings + + + +

TkCon: Special Bindings

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ + + + + + + + + + + + + +

Getting Started	Special Bindings	Procedures
`dump`	`tkcon`	`idebug`	`observe`

+ +

+Most of the bindings are the same as for the Text widget. Some have been +modified to make sure that the integrity of the console is maintained. +Others have been added to enhance the usefulness of the console. Only +the modified or new bindings are listed here. +

+ +

Control-x or Cut (on Sparc5 keyboards) +: Cut +
Control-c or Copy (on Sparc5 keyboards) +: Copy +
Control-v or Paste (on Sparc5 keyboards) +: Paste +
Insert +: Insert (duh). +
+
Up +: Goes up one level in the commands line history when cursor is on the +prompt line, otherwise it moves through the buffer +
Down +: Goes down one level in the commands line history when cursor is on the +last line of the buffer, otherwise it moves through the buffer +
Control-p +: Goes up one level in the commands line history +
Control-n +: Goes down one level in the commands line history +
+
Tab +: Tries to expand file path names, then variable names, then proc names. +
Escape +: Tries to expand file path names. +
Control-P +: Tries to expand procedure names. The procedure names will be those +that are actually in the attached interpreter (unless nontcl is specified, +in which case it always does the lookup in the default slave interpreter). +
Control-V +: Tries to expand variable names (those returned by [info vars]). +It's search behavior is like that for procedure names. +
+
Return or Enter +: Evaluates the current command line if it is a complete command, +otherwise it just goes to a new line +
Control-a +: Go to the beginning of the current command line +
Control-l +: Clear the entire console buffer +
Control-r +: Searches backwards in the history for a command starting with the +current command line. Repeatable to search farther back. +
Control-s +: As above, but searches forward (only useful if you searched too far back). +
Control-t +: Transposes characters +
Control-u +: Clear the current command line +
Control-z +: Saves current command line in a buffer that can be retrieved with +another Control-z. If the current command line is empty, then any +saved command is retrieved without being overwritten, otherwise the +current contents get swapped with what's in the saved command buffer. +
+
Control-Key-1 +: Attaches console to the console's slave interpreter +
Control-Key-2 +: Attaches console to the console's master interpreter +
Control-Key-3 +: Attaches console to main TkCon interpreter +
Control-A +: Pops up the "About" dialog +
Control-N +: Creates a new console. Each console has separate state, including +it's own widget hierarchy (it's a slave interpreter). +
Control-q +: Close the current console OR Quit the program (depends on the value +of TKCON(slaveexit)). +
Control-w +: Closes the current console. Closing the main console will exit the +program (something has to control all the slaves...) +

+ +TkCon also has electric bracing (similar to that in emacs). It will +highlight matching pairs of {}'s, []'s, ()'s and ""'s. For the first three, +if there is no matching left element for the right, then it blinks the +entire current command line. For the double quote, if there is no proper +match then it just blinks the current double quote character. It does +properly recognize most escaping (except escaped escapes), but does not look +for commenting (why would you interactively put comments in?). + +

+ + + diff --git a/docs/changes.txt b/docs/changes.txt new file mode 100755 index 0000000..d1f96ab --- /dev/null +++ b/docs/changes.txt @@ -0,0 +1,811 @@ +ENHANCED TK CONSOLE changes +------------------------------------------------------------------------- +Changes file begun Tue May 7 19:09:51 PDT 1996 +Newest changes at top of file. Release dates between '----'s. +Changes for a particular version are BELOW the release date line. + +Attribution for code is specified after change, a preceding slash +indicates an idea/bug report attribution fixed by myself. Where +no attribution is made, assume (Hobbs). +------------------------------------------------------------------------- + +---- March 31 1999 v1.6 ---- + +Changed tkConInsert to not use catch (avoids any error generation). + +Changed if check on auto_load in tcl_unknown to an llength on the +args (from [info tclversion]) as 8.0p0 also used just one arg. + +Added -exec command line arg, so that users could do the -exec "" +trick (causes tkcon to skip multi-interpreter model) and makes it +easier to drop tkcon as a console on extended wish executables. + +Changed handling of fixed font for all tkcon text widgets, adding +new -font option, TKCON(font) var, and redoing 'tkcon font'. + +Added color,(disabled|cursor|bg) variables as per Becker's +recommendations, allowing for old defaults. + +Changed multiple instances of string comparisons with llength, +where appropriate. + +Changed dump proc to not try and auto_load a proc arg and improved +recognition of procs in namespaces. + +Added new 'what' proc to environment that tells you what a string +is recognized as. Now used in various other procs. + +Improved hot errors to not pop up edit dialog when the mouse moved. + +---- March 5 1999 v1.5 ---- + +Expanded tkConSave to support use in 'edit'. + +Added tkConGarbageCollect proc for periodic cleanup tasks +(currently, cleaning up error tags in the console widget), +with new gc-delay TKCON var. + +Revised error handling (errors are now hot in the console). + +Changed tkConExpandPathname to recognise that NT for 8.1+ is +case-sensitive, and to not change case for other Windows configs +when no further expansion was made. + +Made changes to tkConEvalOther and the aliasing of tkConEvalAttached +for "Main" for more accurate evaluation. + +Changed the conditional 'update' in tkcon_puts (that overrides the +core puts) to 'update idletasks'. This prevents problems with +using puts in fileevent triggers and such. + +Added check to prevent lower-casing during pathname expansion when +no further expansion can be made on a string. + +New auto-buffer (default 512 lines, set in TKCON(buffer)) for the +console widget. Set this ridiculously high if you liked the +text widget holding all that data. New tkcon buffer method to +go with it. + +Rewrote edit command. Previous version was mostly bogus when used +outside the original slave. + +Change tkcon error to use updated 'edit' command. + +Massaged tkConEvalOther & tkConInterpEval. + +Fixed problem with Show Last Error where a TkCon generated error +was always appearing (from Package Submenu) and moved it above +the packages submenu. + +Removed auto_execok from the slaveprocs list. + +Removed slaveappalias as it didn't work correctly. Made 'edit' +a slavealias, with tkConAttach used to determine where it was +called from + +Changed some regexps around to pass tclCheck's mistaken warnings +(tclCheck's bad matching, not bad regexps). + +Changed dump to not try widgets before commands, as otherwise +it won't automatically complain. + +Fixed pathname completion to only beep when trying to expand on a +non-existent subdirectory (instead of throwing no-directory error). + +Fixed a few notes that TclPro's checker picked up (only one actual +bug in the all switch of 'edit', otherwise it was mostly blowing +wind...). (lvirden) + +---- February 17 1999 v1.4 ---- + +Changed "changes" file to "changes.txt". + +Added edit/more/less proc that allows for the viewing/editing +and returning back to the slave of vars/procs or files. + +Modified history to not got below 0. + +lremove extended with -pattern arg. + +Added code in tcl_unknown to ask about loading Tk when someone tries +a Tk command without Tk being loaded. + +Had to change regexps because \E in Tcl8.1a2 was removed in 8.1b1 (arg!). + +Added "Make Xauth Secure" button for Unix. (heiko.federhenn@stest.ch) + +Fixed tkConInitInterp (used by "Send TkCon Commands") to reattach to +the named namespace when appropriate. + +Fixed bug in popup-menu for Tk8 (bound to wrong toplevel). + +Fixed bug in tcl_unknown confusing auto_load between 8.0 and 7.x. + +Made Interp->Package menu more dynamic, so it recognizes changes in +auto_path and updates itself when Interp is torn-off. + +Removed list from $new in exec redirect for tcl_unknown. (found by Imai) + +Changed package menu to handle multiple package versions. + +Added bogus package require statement to master and slaves to ensure +that pkgIndex.tcl files were properly loaded into interps. + +If "Main" is passed to tkConAttachNamespace, it is interpreted as "::". + +Changed "Attach Namespace" menu to provide a listbox popup when +more than $TKCON(maxmenu) namespaces are present. + +---- June 1998 v1.3 ---- + +fixed long-standing expr bug (missing '$') in tkConSafeBind - found +by TclPro! + +took out the use of tkcon_gets because it only worked for global vars. + +---- March 1998 v1.2 unreleased ---- + +updated regexps in some places to support 8.1 regexps. + +dump now outputs only non-default options for widgets. (ridgway) + +Sorted output list for multiple tab matched items. + +Several minor changes for the plugin (user should see no difference). + +Known problems with dump command understanding namespaces have been +fixed, but only for the 8.0 only version. + +Changed tkConTagProc to recognize ';' as not part of a proc name. + +Changed tkConNew to reuse slave numbers. + +Fixed problem with TKCON(exec) == {} (needed uplevel #0 instead of eval). + +On Mac, tries to source itself using -rsrc (8.0). (nijtmans) + +Changed to use 8.0 menu scheme if possible. (nijtmans) + +Changed tkConInitSlave and tkConNew to only set argv0 in new slave if it +exists (it won't in the plugin). (demailly) + +Changed tkConInit to only checkpoint state once if the slave interp +and main interp are the same (TKCON(exec) == {}). + +---- 08 October 1997 v1.1 ---- + +For Tk8, made TkCon use a fixed font {Courier, size 10} if the current +font is not of fixed type. + +Startup errors should now be found in the TkCon last error function. + +Changed the Triple-1 binding to not include last newline. + +Added fix to make sure that double-evaluation of the command line +didn't occur (might occur for commands that used vwait or something). + +TKCON(errorInfo) is now set with all the errors that occur during start-up, +so that you don't lose stack trace information. + +---- July 03 1997 v1.03 ---- + +Updated namespace eval stuff for Tk8.0b2. + +rewrote tkConSepCmd. + +ls is now "dir -full" by default. + +changed the puts renaming from tcl_puts to tkcon_tcl_puts (so that it +specifies what renamed it). + +added variable highlighting to command highlighting as a background (so +that a command and var can be seen for the same word). + +increased default history size to 48. + +Fixed problem where aliased exit couldn't take extra args. + +replaced old [tkcon gets] with a new UI version to be used with the new +tkcon_gets that, like tkcon_puts, replaces the Tcl gets with a version that +doesn't rely on stdin being present. [tkcon gets] now accepts no args. + **** POTENTIAL INCOMPATIBILITY **** + +---- June 10 1997 v1.02 ---- + +Changed calculator mode commands to be put in the history (but the +output still looks like an error). + +Fixed bug where "source" was assumed to work for primary interp, +causing failure to load in Tk plugin. + +Fixed problem with the id'ing of the primary TkCon interpreter that would +affect attaching to like named interps. + +---- June 8 1997 v1.01 ---- + +minor streamlining in tkConEvalCmd. + +added file menu and separated some items from console menu. + +added support for connecting directly to a namespace (itcl or Tcl8). + +Fixed several potential problems where args to tkConEvalAttached where +not properly protected from eval. + +added slaveexit variable to allow for exit in slaves to be non-destructive, +which is the new default. + +enhanced Tab binding, made Escape the default pathname-only expansion. + +enhanced dump and which commands. + +Removed auto_execok redefinition for Tcl7.5-. TkCon is now intended to +only run in Tcl7.6+ interpreters (though attaching to 7.5- is still OK). + +Added Load/Save menus and expanded Save functionality. + +---- June 1 1997 v1.00 ---- + +TkCon now use virtual events for bindings (REQUIRES TK4.2+) and changed +Console to TkConsole (to not conflict with new Console megawidget). + +Updated tcl_unknown to match Tcl8's unknown. + +Changed handling of preferences directory for macintosh. + **** POTENTIAL INCOMPATIBILITY **** + +Changed tkCon global var to TKCON. + **** POTENTIAL INCOMPATIBILITY **** + +Changed colors to use absolute #RRGGBB format for color-name disadvantaged +systems. + +Removed use of tkCon(font) variable. + **** POTENTIAL INCOMPATIBILITY **** + +Fixed procname expansion to work on/in namespaces. + +Fixed pathname expansion to expand on a directory. + +Fixed all if's to use {}s (better for Tcl8). + +Fixed potential paste problems, it now tries to get the general selection +first, then the CLIPBOARD selection. + +Fixed problem with 'puts' being renamed too early. + +Added calcmode variable to allow typing expr commands write at the tkCon +command line without always saying expr (handled in tkConEvalCmd). + +---- no official release v0.72 ---- + +Changed tkConAbout to use text widget so info could be selected. + +Fixed problem with pathname expansion on windows due to case insensitivity. +(how can anyone work with such an insensitive OS?) + +Fixed off-by-one error in history substitution reported by +. + +Fixed error in the handling of packages with a space in the name. + +Removed general return of output from rcfile, now only errors are returned. + +New tkConEvent proc to handle event movement, fixed search event problem +where cached event would become incorrect. + +new blinkrange variable to change electric bracing style. + +---- December 20th 1996 v0.71 ---- + +changed to not use upvar for nested arrays (bad for Tcl8). + +catch package require statement for detecting loadable libraries. + +---- November 15th 1996 v0.70 ---- + +Fixed problem with virtual event C/C/P bindings. (reported by +robin@jessikat.demon.co.uk) + +---- November 15th 1996 v0.69 ---- + +Added auto_execok to tkCon(slaveprocs), fixes "unknown" command bug. + +Fix for 'event' to work with plugin. (nijtmans) + +Added '--' and '-filter' options to 'dump'. + +---- November 13th 1996 v0.68 ---- + +Added $tk_library to auto_path for safe slaves loading Tk. (nijtmans) + +Made "r" the default mode for tkConSafeOpen. (nijtmans) + +Changed global delcarations in tkConInit to avoid conflicts with +Nijtmans' plus patch. + +---- November 11th 1996 v0.67 ---- + +Fixed weird backslashing in tkConSafeWindow + +---- November 8th 1996 v0.66 ---- + +Further changes for Tk plugin compatibility. (nijtmans) + +---- November 7th 1996 v0.65 ---- + +Started to add to plugin compatible code. (nijtmans) + +Reworked tkConFind* to accept optional args. + +Added History menu which display last ten commands in history. + +Removed 'auto_execpath' and changed for new version of 'auto_execok' (in +'which' and 'unknown'), which will be redefined when TkCon is run in Tcl7.5. + +The attached environment is now checkpointed at startup (by default +this is the slave). + +Fixed 'dump var' to use list when printing out nested array elements + +Added 'update' to puts, as well as better error reporting for tcl_puts. +(nijtmans) + +Improved bracing around elseif statements. + +Removed 'warn' alias from distribution. Seemed superfluous. + +Added support for requiring Tk in Tcl8+. + +Made TkCon use tkCon(cols) and tkCon(rows) for startup text size. + +---- September 30th 1996 v0.64 ---- + +Changed the way 'idebug' integrates with TkCon. + +Changed to require Tk of version [expr $tcl_version-3.4]. + +Fixed bug in observe_var (upvar shouldn't have had the \#0). + +Made Interp->Inspect menu disappear if TkConInspect package was not present. + +Made package handling only enabled for Tcl7.5+ interps and reworked +how packages were recognized. + +! Removed virtual events from Console bindings so that they don't screw +! up the Console bindings (temporary fix). + +Changed how initially loaded packages were detected. (nijtmans) + +Made all globals visible in tkConInit. (/nijtmans) + +---- September 23rd 1996 v0.63 ---- + +Changed 'tkConFindBox' to not screw up search string. + +---- September 20th 1996 v0.62 ---- + +Added option for automagically ignoring dead interpreter problems. (wart) + +Fixed bug for reattaching to default slave via menu. (wart) + +Changed how 'observe' spit out trace info for commands. + +Modified 'idebug' internals. + +Made 'idebug' create its own tkCon(exec) slave for maintaining history. + +Fixed long-standing bug in 'lremove' for -all switch. + +Made tkCon(SCRIPT) follow links to the true source script. + +Added 'idebug puts' and 'idebug echo' methods. + +Fixed 'idebug break' to not work at level 0. + +Removed line that could improperly set $name and placed a 'catch' +around the 'interp alias' for 'ls' in tkConInitInterp. + +tkConInit(Slave|Interp) now just 'catch'es the renaming of puts. + +Added 'tkcon set' and 'tkcon upvar' methods. (nijtmans) + +---- September 17th 1996 v0.61 ---- + +Added 'idebug' interactive debugging proc based off Stephen Uhler's all-Tcl +debugger (Oct'95 _Linux_Journal_). Should work w/ or w/o TkCon. + +Added back accidental removal of 'ls' alias in slaves. + +---- September 15th 1996 v0.60 ---- + +Added 'tkcon find str' method and find box to TkCon. + +Added 'observe{_var}' command for simple tracing of vars/cmds with +output in the TkCon console window. + +Reworked tkConFillAppsMenu to be more efficient and correct. + +Added 'echo' as an internal proc and included it in tkCon(slaveprocs). + +Removed tkCon(prompt2). + +Changed tkCon(lightcmd) default to 1 from 0. + +Improved 'tkcon error' to allow it to check the errorInfo of other apps. + +'dump var' now outputs nested array values. (loverso) + +Changed tkCon(Load|Save) to use the new Tk4.2 dialogs if available. + +Fixed tkConPrompt problem where marks were set incorrectly sometimes +when it was called by an event (such as ). + +Added bgerror to slaves and 'tkcon bgerror' method. (nijtmans) + +Added tcl_unknown along with other minor mods to get TkCon to work better +with IncrTcl. (nijtmans) + +Made binding not include the prompt. + +Add null Console bindings for the tkCon(root) bindings to avoid them +getting generated spuriously. (Hobbs / Wart) + +Added -argv/-- command line option. This has very limited use, but is very +good for wrapping TkCon around an existing application which has it's own +command line args. It resets $argv in the main interpreter to what remains +on the command line and TkCon ignores argv. This carries over to any "New +Consoles". + +Reintroduced state procedures, placed them in Interp menu. These should +only be used if you really understand what they do. + +Added 'dump command' method. Usefulness over 'dump proc' is minimal. + +Tightened up the command line args, dropped several optional switches. + +Placed all the Console bindings into tkConBindings, which is called +in tkConInitUI. + +Added 'tkConInitInterp' which places the tkCon shell commands (already +available in any tkCon slave) in the interpreter. It also rewires +puts to send the result back to tkCon. + +Fixed dead attachment problem where attaching to another interp after +being connected to a dead interp would munge the new interp's name. (H / Wart) + +Added 'tkConEvalOther' which evals in the named interpreter. + +Removed 'tkConCheckPackages'. Package handling is now separated into the +autoloading part in tkConInit and into tkConInterpMenu which determines +available static libraries and packages for an interpreter. Menus redesigned. + +Changed 'tkcon eval' to 'tkcon master' since eval gave the wrong connotation. + +Made '-nontcl' option take a TCL_BOOLEAN argument. + +Made 'which' return unknown commands as an error. + +Added button into the help window to send the help URL to netscape. + +Made history substitution spit out a correctly translated command if +evaluation doesn't return an error. + +Changed history search to use the same event id as regular command line +history. + +Added tkCon(meta) variable which varies the Meta definition based on the +platform (Unix == Meta; Win == Alt; Mac == Command) + +Added 'dump widget' method. Spits out current widget state as returned +by '.widget configure'. + +Changed 'dump proc' and 'which' to try and auto_load an unknown procedure. + +Added 'tkcon history' command to return a source'able history stack. + +Fixed off-by-one error in tkConExpand (caused expansion to not work unless +you were expanding the last thing on the line and also not if a special +char was the first on the line). + +Fixed TkCon package handling to work properly for IncrTcl. (nijtmans) + +---- July 31 1996 v0.52 ---- + +Reversed changes file to have newest at top. + +Added 'tkcon version' command. + +Fixed scoping problem when attaching to the master interpreter of a +particular console. + +Rewrote the expansion routines to handle spaces in names better (no longer +requires the user to use grouping as it puts in '\ ' for spaces). + +Fixed off-by-one bug in tkConExpandBestMatch(2). + +Rewired attachments so that when 'send' is used to attach to an app and an +error occurs, TkCon determines whether the app still exists to prevent +multiple errors from arising due to a dead attachment. If this occurs, it +prompts the user on whether to return to the primary slave or to check +periodically for the attached interpreter to come back. tkConEvalSend was +added to facilitate this. + +Command highlighting is now only attempted when a non-empty character is +inserted into the command line (%A != {}). + +Added Ctrl-2 accelerator to get attach to master interpreter of a console +and Ctrl-3 to get to attach to the Main interpreter. + +Made the attachment to Main set the tkCon(app) to Main (to get around the +menu -value {} bug) and also set tkConEvalAttached alias to 'tkConMain eval'. + +Rewrote tkConPrompt to accept "pre" and "post" args to place before and +after the prompt is printed. pre is tagged stdout, post is tagged stdin. + +Rewrote 'dump var' to recognize nested arrays, but not output them +(it's too complicated to do that in source'able form), as well as +recognize empty arrays. + +Rewrote tkConEvalCmd to keep track of errorInfo when errors occur. + +Added 'tkcon error' to display the last errorInfo. + +Changed dumpproc and dumpvar to dump (proc|var) ... + +Added -root argument to set the tkCon(root) variable explicitly. + +Changed the -(slave)eval args to append to rather than set their vars +so that they can be specified multiple times on the command line. + +Added a limit argument to tkConMatch{Quote,Pair}. + +Rewrote dumpvar to recognize a single array value name (ie: a(b)). + +Renamed default non-Unix resource filename from from tkcon.bat to tkcon.cfg. + +No longer 'catch' the renaming of puts in a slave, because we'd want to +know if that threw an error, although it never should... + +---- July 14 1996 v0.51 ---- + +Removed tkConUsage since it was never called. + +Changed tkCon(Load|Save) to use tkFileSelect, if it exists. + +Added -load and -pkg equivalents for -package. + +Added Ctrl-Key-1 binding to reattach to primary slave. + +TkCon now will create itself in a different toplevel if there are already +children of . when tkConInit is called. + +Changed tkConInitSlave not to overwrite tcl_puts in a slave if it exists. + +Created tkCon(slaveprocs) to identify what procs get dumped into a +slave each time and tkCon(slavealias) to identify what will be +aliased back into the main interpreter. + +---- July 4 1996 v0.50 ---- + +Number of history events to keep now set by tkCon(history). + +'unknown' reworked (yet again) to properly handle itself in either the slave +or another interpreter. History substition was moved into tkConEvalCmd and +made an option (via tkCon(subhistory)). + +Inlined _dir into dir/ls. It doesn't save any cycles, but it removes +the need to manage _dir. + +Fixed 'dir/ls -f' to denote executable files with a *. + +Fixed dir/ls to not die on 'dir -f '. (Thanks to steven@indra.com) + +Changed tkConExpand to stop at $ as well. + +Changed tkConTagProc binding from Console to PostCon . +It seems to miss a lot less now. + +---- July 3 1996 v0.49 ---- + +Slight mod to . + +Fixed binding to not allow deletions of pre-Prompt text when a +selection is made. + +Fixed tkConEvalCmd to properly send commands to foreign interpreters even +if $tkCon(nontcl) was set. + +Made tkConEvalAttached be some type of alias at all times. + +Changed 'slavescript' to 'slaveeval' and added an 'eval' option. + +---- June 25 1996 v0.48 ---- + +Fixed 'alias' problem with multiple args. + +Updated binding system to automatically set Console bindings to equivalent +Text bindings, then redefine what we want. + +Updated tkConTagProc to eval in attached slaves. This can make it +really slow when attached to foreign interpreters. + +---- June 25 1996 v0.47 ---- + +Fixed tkConExpandBest* to be more accurate ([string first] is only valid +for us when it returns 0). + +Updated tkConExpandPathname to work better for attached interpreters. + +Renamed tkExpand* to tkConExpand* (they'd become too TkCon oriented). + +Changed tkConEvalCmd to 'list' instead of 'concat' command for attached +interpreters, and to ignore the whole thing if [string match {} $cmd]. + +Removed many bindings that were exactly duplicated by "Text" binding. + +Added tkCon(blinktime) option to allow user to specify blink duration. +Value must be at least 100 (millisecs). + +Removed tkConUpDownLine. It never varied from tkTextUpDownLine. + +Improved package loading to handle bad pkgIndex.tcl entries. + +---- June 21 1996 v0.46 ---- + +Improved package loading to be correct. + +Made 'dir' more Mac/Windows friendly (I hope). + +---- June 21 1996 v0.45 (skipped v0.44) ---- + +Added "Non-Tcl Attachments" preference to disallow sends to interpreters +which may not understand Tcl (ie - SchemeTk, PerlTk). + +Rewrote tkConCheckPackages to allow calling it without a widget reference. + +Updated tkConEvalCmd. + +Added tkConEvalAttached to evaluate more things in the right place. + +Rewrote tkConAttach to allow for attaching directly to slave interpreters +(no send required). "Attach Console" menu now lists all slave interpreters +by slave path (with Tk interp name in ()s), separate from foreign interps. + +Add tkConInitSlave to create a TkCon slave. + +Renamed tkExpand* to tclExpand*. + +Updated 'dir' for better output. + +Added command line argument support, rearranged tkConInit to support it. + +---- June 18 1996 v0.43 ---- + +Fixed 'unknown' to work in both slave and master interpreter. + +Modified 'dir' to be dumpproc'ed into slave. + +Rewrote 'clear' to be dumpproc'ed as well. + +Fixed 'puts' bug for slaves. + +---- June 17 1996 v0.42 ---- + +Added extra loop to tkConCheckPackages to account for packages that may +auto-load Tk itself (like Tix or Tksteal). + +---- June 15 1996 v0.41 ---- + +Added 'warn' as an alias back into the main interpreter. + +Fixed documentation leftovers (and updated upgrade.html) to include the +move of the 'main' and 'slave' commands into 'tkcon'. + +Fixed problem in 'clear' command + +---- June 14 1996 v0.40 Released ---- + +OK, I need to add some MAJOR changes here... + +Added package handling. + +Moved to two-level interpreter model (master control/slave execution). + +---- June 13 1996 v0.38 ---- + +Fixed auto_execpath to work on windows + +---- June 11 1996 v0.37 ---- + +Improved 'tkConResource' to get the right script name on all platforms +under all manner of circumstances + +Improved sourcing of tkCon resource file to not throw bogus errors + +---- Jun 10 1996 v0.36 ---- + +Fixed bug (incr $tkCon(event) --> incr tkCon(event)) + +---- June 8 1996 v0.35 ---- + +Removed "Resource" from 'Edit' menu + +Rewrote 'clear' to accept percentage level + +Fixed forward history search bug + +---- June 6 1996 v0.34 ---- + +Added 'clean' alias to revert a slave to its "pristine" state + +Added tkConState* procs to monitor state and be able to revert it + +Enhanced 'which' and added an 'auto_execpath' proc. + +Removed all known global uses of 'tmp*' variables. + +Fixed problem in tkExpandPathname that munged pathnames with spaces. + +Fixed problem in many places where spaces in directories and command names +might get things confused. + +Fixed problem with non-interactive slaves. + +Commented out binding that recreates a deleted console window. + +Add tclindex command. + +Added support for -full to ls/dir. + +Added command buffer save and command buffer search bindings. + +Added Prefs menu. + +Changed File menu name to Console. + +Removed 'Load/Save File' command from File menu (to easy to source) and +added 'save' command. + +Changed dumpvar to use "array set ..." when outputting array values. + +Changed tkCon to use tkcon.rc on non-unix machines. + +Revamped tkConInit and source file to make sure nothing specific to tkCon +was set until an Init proc was called. + +---- May 10 1996 Made 0.27 Available to the public ---- + +---- May 8 1996 Released 0.26 Third semi-public release ---- + +tkConNew now returns the name of the newly created interpreter. + +Added 'main' and 'slave' inter-console communication commands. Also, +all slave interpreters become commands in all slave consoles (make sure +not to name procs "slave#") when created. tkConOtherInterp proc added +to handle the communication. + +Moved tkConDestroy and tkConNew into new proc tkConMainInit to prevent +resourcing problems with slave interpreters + +Fixed 'puts' bug by removing all 'uplevel subst ...' and placing an +'eval ...' at the beginning. + +---- May 7 1996 Released 0.25 Second semi-public release ---- + +Discovered bug in puts/output sequence - still searching + +Added unalias command, fixed alias command to not unalias commands if +not enough args were passed + +Updated 'unknown' to mirror current tcl7.5 'unknown' + +Changed var names inside some procs + +Added comments to most procs + +Fixed off-by-one bug in tkExpandPathname + +---- May 4 1996 Released 0.24 First semi-public release ---- + +Changes file begun Tue May 7 19:09:51 PDT 1996 diff --git a/docs/demopic.gif b/docs/demopic.gif new file mode 100755 index 0000000000000000000000000000000000000000..83a9e3a4e33dcca2da1c992d12eddbf38d986b33 GIT binary patch literal 18619 zcmV)KK)Sz2Nk%v~VO9e30rUU>|Ns90007z9*=A;DurOf%{{V;1`u_j`?Ck7#NNZh!;eHW0Ehtpz|a5y00000000000000000000000000000000000 z000000000000000EC2ui09FF?0RRR5U?7fUX`X1Ru59bRa4gSsZQpp#7AhYM1D$Y4 z^u3J69dXHQI-k&}bV{wxk|rO}$`xW;g>ZLFE}L7xw0g~MyWjA*d`>^xS6`Agc<=lF zfPsK?goTEOh--p=c_Vv^kdcy;lxPD0n3*h{(q0^Q!<;Njxq&#eA!XOBErqN){QWZ9=>iHINKoK9dH$Bb`_b;pG9)}8wyG5dVl6!t zk7-1faoRkM9jPG^nIaj*Srz_$jErb;qAZfCPKp@`bDm6>3Hbpm$g`(UbO+nzEYc%h z!z}cUMfCV_l`6O}(yb~xE>nw9u{D!^8DrI&GBMq3ZsTg+d~WV#FLveS zjhc4vV$!e}UmQF+t>M5>M}Iu+dac%yNddE#o%{2t%-~3n6T#V=Z~?@_CGY9kH;#p( zdt((lO)PAhGo6K;j56d|6tt<6jmdX9)kd-tXRrCU>}}_efEy3cZFz9|#gh}aKmTWQ z_%0+O;D7`cm`HhD$^L{ENmt?27iotzcG!A~WpNXLl*or1e*JB@A%Ac2C)|D`42K_x z-Ta5)3I?|5;)?}Bl8;?0)~KO~C+3(RhaH|^VtqV*qhgIHZ1c;JNG7S|F9=;WBa!ah z7^HqWat0!mRgQCPRAohf+BXre1z(>8r3h+T;xj0ir2{G~$Enimo09`~YbimwY_r_TDpa!Db}Q~%b1ik@gVbhat$L|cD3zcNI#wRLN>$sJ zc-^r?SZ&ntb*oO2_B7|X({Mq?%4Md${7!f6cL<_p@q6x-hOJrS z?Q30ilx52vYZ(I=F2S%q>uJDi#wjqV=sZkN#LP|1U3>Qwrp$NOGwlSGyK}V;p`=~BCsmB@@a}Fd zH%As(rXFdcm+t)YyO@c3>cy>&;j#;7Jur%M(vEZ0plUxjPuB0FL_MHYF+KI;&b2=K zag`4r_B3x@d!lT5FF5$a>QBDkudv0xXz)JxHOqaiGoYp9=N$RqZhWzW-Qhlzzwg-q#Le6giT@a36%D7t?$wWdO*H<| z7USZpMvYM&Q5@6=pU9|z9WaepBm$v$fR7=<`muc?^kK{j#YbYD5l4#?mEsOn$e~PekbRq#A+@1J7P_#JngrGADKrxicfKW^radl z$xAQ-@|QOVCgMV+LHlGKGu}^8USp+@t~oVoR+EtI#3lht$-mjz(~hWQ zCc(r>ELd97oag-KkIa$FgzWO2R*a`Sv*^x#lJlGRT%{gc8A&JBlaDX7<^Dh_smZVP zbDh#`l^_u+u7WN!QVnh6*uo~!h++_+Ks=ow%ScXH-mIe;tsgi+`YlKul%#Mm=}DC} zQlR!S2s*5jJ}DZ~K&I5F-4g0hou;szLbYs2O&|)I8POj~HAR-$8Rm{Y7d{t9qJ_m(R&K>n`JCqOb5W%^rfvg4Z@fiGTYg* z(w3K>9fkwt`cTtm5SlJb9AxVXInJ3UU-t42ywY_q@^lJ3f+-7f{()yN7WuWdxvMC4 zf%4Y*9d@q%Jf(P9ddoP~G=#!v8(5AeIotToU&6yfb2rvrk+ntzx2-K_x64x`?)Ibg zEawDeX3LtM_f^eNuhFoRJh!3kUAC#)+a~-u#8^VG{JoTRGwj*!Ht@TrE#?HdIm7*t zIECX~DpqxaH1?iG86?x(do)Jj=rZM60lF@SqnT9U z@TAkbHe2Y;(lE1T_sd}*-$Ku-MYCJeYd%^nqP5n2svE`rd@L~MQOUslNow0l+@`+F z$8dqPIfl!_HNybWGJ?V!IlV*-uNB2LOS3ayn9MKtRERoe^y4gT)hvFLOpFEz2M z4NtObuG2N61cFHsdlbN9rZwv@E$i$myVflDR4NU8&p~dY(LD~cVvYI0P17=+8U+@L z{M?pUH=Db&%8O~LY)JZjyODu@A|?=kfJ~s#(Zn1r1p^G;GY3wt;@vEnPiXFQ6BK|B zxi4%+xh?I9ua>GN*u3ezfQt7Qk&YCtXfv+QI-=N(GQ9Vz@dW5T`z_(vdhRG0FzRaW zyWc;Yc*PeWa+crPcJ_-mTg!`VN_Kb)3<&xNg3kT`5fHuTMi+Y0ksbh|2f5$||2b>j z>$Btivgj=jG)@8BZE;~@=Gdm{D+LTofUi2ZHdUC^nO=0ZH+|?OXgl29UT$Vb9o<2| zvQwIjAW(lM=+aKI3`fho#69inG!Hw*OFZmc#1+z{HtLXYtne*k(dM=nzOS1-7pE^>`JDH@_nUrs=VSQTckdFG z*WLR#mYlA9{xKk#4p+gV8rR$(IJCKZd;S}4U)Ik;f8J$(8<$vSSA6=ne?*mi>Gyw( zMsDU8W-y0#u9tucD0cmad##s$&sKjDm^~WDfg^W;w#I-_7k~T(ft3(=-sW=;C|P>- zWNcwH>^1}MmsTjaU7aL=wWn?RW`I4XgD`ks4+aG=wkhWm6=&l?s0V-!C}uloP&fBc zVk3f+^J1JLUxp@OL|6mZCxIDwaZPwtLqd1rM}C?&bmg~#V|aT(afE22Tu>G{6*67c zVq7(WE)lW-i(Cij6^iA47{b#(VAO ziQBLazW9s47>vR=jKo-s#(0d#n2f<_Tau!T&iIVb7>&bNR&n=sn`e!OsEVp62{$N& zA%%sLb6j?IiB%^wmIYr@h68{IJ?z+yoG^%B=8p3C3-H)erPzGesEGOKd5$QEm@*o4 z12;nxkX`{goOm|Whl}dijbuoOJJu!nc#4a7dE*y>pjc@mxL4Gb75LJJ3ZgE=^ImeZ zU}x2jA}ESbXn~%@iVfI-B*=dk8G6}vf-0#?EJ>3t`H~A5i2mr1CYO_Cc9RCDf>^|m zP?dw&MU<0Zln4lvI?0s&K!ue0Rg+R^k{S4q%k>No!8?4{Gv`=@b^w(mC6!GXi6Ui{ z{r4vd$qW?nm0g%{?6-^RBa|uVlk(@3X%bdCwU-fxTT!%@@|8JO))fePZiIdxvi627xsmJ^qTA&FB~dR>s1iYbO@d6ZP?5C1iGq(xKjhJU5i zmquhZ;L(=q(k``#hbZS@mC<5y`2?UDn)S$-Ls^>raGI@#cK(x0!{j3qh+eFPn}fMF z4z`)n88-=e2EExuvJ-@sGHGLnktj)g*-1vv)SZ+RZc53G&nH&Z)^#CQL5%}Xz66+6 z7M);eb?8Vfm1F*$D5-Oi)+`66ojmrPkLQ{JR(Rnlb^ZlnF|?kB2ZR~tIN_#duo)o* z*@aT3khf8t&*^syIfco&QUnSyglBAgi5%DloUcS$0aq$j6cn8`mVjnxmr%QE~c3r@9DY`B!#@ znRO8ji=m;uI#b&dsAhVmTX%n4G;UAILd&EXkms!AIj4V`s!lke_UVYHzPn9y(plm%UqVWEX)uk!?a!N+0hI+Ilup=8yog7B;G zx1+Hk5eve5+rbKU7&*IWi@~$7a%h`dxi1DwLjSs-4=J1gGn%dVEhMR#*HNJ|CYPHi zT{mX0nYeo-kga`6T7k- z2X-^Nwi_dKdb$MKx~X=p301n#cDurRyR|#K#!CnZ%CB9Onhv*`Fyx-;q^ZKzcq{h0 zGq8hJVS_HI7tPU%r-}-5@cxNYYy!2cCzxI2- z_?y2YMWcpiK{$FUR9L1M6;$k?zXq%{UvR(*yub|HzzckS3wo!A3U6%`c@G+^kL4c) z?7$q1ym8k&^BBS+Ji;Vg!X|7w3fiRot4CWGaJSl0k0vo7e8MzbI_b3sHJrmbyu&=) z!%C8+0W85>>Vim`VvP5~FclO&yu?WIC`k~ub{oYkBV<90JJ6@6EzC{ei>Iz8#gSzS zPmHc!JjP1|#RwG?WE`M;Va93P#(l!Z)r7`w%z9H7#+N(Ccnm*q9J2$E$1AjZ!hJ{-$rfQ7QNFfzQ87E z;Vf*xc1apXqUme ze9#>COkMY;yu78Zde3}v%?gywvQ}gxhNH#&&-g@w&oLbLq zdaHDe%m7S7>de$!O}@lt)h#{E%Jk($cKuk}B+mAnQ&F93mhIX}jn$~8*!V=xtjS1~awDEf(Wh0!&+5`(I@{07)_)Ar zcWlZMt(eM;4i2=;Ml8gkdQPA%&m{!OQQR;^4Te=J{+>upJ>a<+%6*_WHQ%q&uhbge z=dfG3T;ARG!b+WUeahb2T;I~1$hh6z-i_a37~A0h&`&+u=e^P+y;@%E-lUw*5B}i+ zLE-vl#TsSU)T_nj{6>te$;H*mApYW0?BR8};;Y=^4gRh$p5w)V(Z__~g3QV{uH!-; zD?AQAK#j*hzLP_~{6BKs7=X~Dgy3pr<9_WHT=!8z^c+OM< zQ0R(2xwAs!Xa49tap*t2=6>AheZ1(Hp6QzYzUhQ6=`5q?oUZ7DsEh(&>0=h^sGjPo zzUt8E={gDotPbdtk^l}+>$dIyw0`Tg&JCu%4v_xqgj}Zs)wH4ML%DwI0C4QcUg~v> z+hYdo(4G!J+|wdh?6a=x4!{k{zU$21Ai?bGmhu4N?h_9H4&zSl0U_??{uU5`4iNC} z(JtP(4WUGa(~NUu`NYMcB<7%K?7Hql*v{*G5XR5`6YG8s2Tu?Q?+puI5DhO54<8Qa z&hGIZ;%n5x7bL(1jm0W8U=m)B)}A8&ZYLv8=0sKS46pF%u<#KN@h)%h2#*fy-tq#` z?iDZZMh#pWKfqiCz|@Ukl%9e9ZtMQkRPqBq<(HlS-$3)@pzaf|?&dD>GH>os-wjo7 z^%E}uS8w&^!1N41^W*UDHZK6}F81Ca_VC^fX1_@#CM++f-ekPibM5giSK^-y*g)^- zk2v()E+ort@1XROON;m5B7)O_={f-PA~IJKlWsA^J8!MWPkR< zVI0cg`E&yMf-LtXP1{Iz*Mo=m8m^dp-%x))@XikIUQZ5%|MH1X`;o8php+p*PxZBr z`@0YEvv2vC&-vd_{8}RVN!CJ$JnfkD+N>S@0UXyWz4|fP`dmWv%nlXbuJpk#5WjEu z;t%}0@A$k=^9j%Nkl*xJZ~hL%Z~U8o{P3TrsG|IxKgd)}?~&)&DTeQpt?wWph$C5= zXPG3!fVwXn%QIaI03arggQI*;zzPHkL?TO|B0X%P=2HNbGELLhbqdu+yWG+B^mT1t z5Ykzc7Od5yw&^$u%I!TduC|u9~llUY;Rc<{ctrvhuQE&awa^ za*gz}A7e{(wzg!C^G^_FX252GHehTby7@YLyL(@Aw(+6xyUewHJ|DMt<>i1lBrQ1U zLj_4)!GsDIDvHPO{-G0m5GUSnmSE5eZ~z06qv-J?$dKk7iWDiaq&`UiRIqI6@?XGl z1IwYTY4aw|Km#!5e0Z{_Ic`9P615~`qqvR=6rf-Vl-*LNexkOMnvH4ZqAo*0` z&k;+fat%2ag-RT1*RqAlai)l}Gvt1?A(gHGyd?B~7zeD`DhStu>G(Sdbv7d{JM~zTcLX+v)yt(7% zj@rAoZro!XFLo^a?r^Ha_Zkl_HaT?5r%(7so_ce1=YNg=PJQ+`cJ9~1Cl=qm{CDE! zor>3vbu{Vzc42*6Hvb%}a2U<;Ywr(UI)Li6CqiT~$i@O~nRKMvbN~jJ*j^Ai_+V=j zvc{Tz5>Ce+gcwq{n1*^?DB*YxT6H0ZE|hqp3@4^&A&Dw(s9}g5CI(-8>-;oggEKPM zV}w2i8Do!J@hBZ@1;TJ3QVLe)p?53}=^=$pH8-V@)LlvBk$9B|;$|Jv2jp^6B1t2d zXae~mkrs|QVQ?=FIVXx#;h3W~JKDJ6mRT0pXOV4^xhIliD)|DF32O3Wjcmf`XMJJ% zi6L&1Rw-nqkj@F`njliysfk!#YQmSBHYMt#Y5G_etDe#b-#qk`K+PQWI6*5rdY;xL zji3IiX=IvI@=76BhsHLUleT4PCZ$yxxf`j1Ity*Ey^;tVs1HJ!6}F>p%cYtzew$&N znl&rxx!!im)M(MzTFAR7;5tpb=IDCnuH}x3DzN-kODv&I8M_Fwiz=%ebmuW=-F>BM zS?QZ`no8<$5;wf*au46vFtr$W=c08A0!9 zS92#aH}jmc975}iw%W(A&Gyb~%U$#e*vKe$4Og3x^;^p31NPlt<2`snIL_;K+x|Ys z?e^R`uWk0*jVEK;#Dt%qcM1gyxP-OOEp~#z6k~ z+0Rf;wdF8iP6FSx5tKXd!K2jf>a5G{`s}mUI_uf6)7^;hd+a_!@5%lyQt1$Z9(`yn zqCS^a#MgX+^T;<}`|`9$o_O(q+)hLG`mq=PBc4yMgXS`Ee%Ue(cOG%H`WK(?%|#pG z+X-xR7PNPj?|j369j$;ShvW6EeeSCpAqZ$Ds6gg5k~xajDl?Vtg{yNFTFn3rs6rCl ziFLViH@Ml0mWR`#4w7sb9{xFFBvC{nh zlQgJ7aeh2>;u8JyL?x!@KgHpp7p>Sr7xuwuRHIK8^TWg~s^?GWA(^>8HZ>bo&tTU( zm9zfksD8N#ROzyord%|s5(epy`_k9BhD9zz`if2|Ql!%Mcts9LWsGFp13q44MNUmJ zfZth`zq}@_fDy=p2Ew5TAErq_a&lVT(o_%8w4z^yQd)mnWuW{RF_3*yhw|&Cw+I=k zeC=wNqFj|#EO|*AWO6(BY9*!kL(E~uGFzDXS9MB>zYm7PdNh$_9#Iv*XO7a3j$);+ zkeEwol5(9*`=Kl?HBMZnN<`=)RD`_LPNgYxnKWo-r06-%RkgGJL9IHbJAp(;RPGO( zh%6x_%L7qc&T>uatY_fpX|9P*6PJn{XgDKfO?3{dkpLs6Q~K%8dth**uskU_L8&i< zVw6G)1!3Rr*s>@FsAQ_#>Bg9*A~{A4cNRn0$d39%jq%inSxnh;jLOC#W=c6zOCuVa zXjQ0Qk*P;Rj!IX$q`I+)rwsDt(Ja=*Bc`>eP`p@Bje65=+VPuJ5i4E^7uLLD4TF4j z%{EVoQ{UN@gMU3NX7-9$9r$&zRx{<27^>6yosNEv{Urcza=Mx*cCj$jVP@a4Sx3yZ zNp-y}YE!EdnyGdXjlFDXL)cL5S+=W?sO>M!fm^%m_J97Wd8!FIi`dVKHMTh|tYJ@B zK+M{+a^v(`W|RwD)D+}1pF5%9ig!5f5qG7=%|romc-Iy=!7rP{qcGEJ%@{&=y^7I? zb<2xg1lDZ3l3QkX{aIQg6rjJGF@8m6*h;iq61G)n}O&*5H{X&~YYq9MPhe-(`N+o9RVSN9B2`=AMb9ww;umo;zcj zN(;u%1XqmJJIElTSEd=QoQJZ@xaB!d#jka2i%+{=1AkPEiJL``idM@Zw`8-3AYIIQ7?6Rl}4bx_o z6x8cdH6sfu$#J1~gXvO$l3yT=33B(zi{`GTVPT0Ouw-e6hf49Qi5pQ={;C<<7 zZ+XhkPKLt+{w9L=C*cPNcRoaZ@k}Q}gysPy5&V9we&2r0~T? ze2-AS>D70v>g)@zK8Rmd_l*et>;Jla?jPj)mlfanZBTxBVVYi*#$@{Wx_K+PY@i3$m-={M z+SDKKLhS$MHq@pWJH{hZkG0WMVF$NgWu@R|s&&bi$n{h3?s0N_8FAYP%Mc*Pyh z@m}v8pA5i(45Ahd!oUEE!~H2>>-1m-GLE}Ep$0af-8^7mMb==s*eA4L(m|c+#efnn zA^2V32O?ks-W$G6VHVCy2SQL4{-6Uw83Z277fM<0aa}7s-ybHP5l-F_qJb>{0~+F0 z6TXfEZJ;oi&-v8h1BL#e;z%M(-Qln0A;Ih+o_zxD>D}#pUfccZSLNwyZG%{V;L2A-;h&vOzbB z)i;_$OoXE%jAM=vU-Jbb^zmam&ffI704~H}FT|rfs^Qe(V|?hNGO(aQ_TM}@873+m zFYb*50%SToq(-7ZMCzL^dRIke4kvcn1a72BK0`+ak3y2h{+*;tLP9gRgiOvPP1dAM z-Xu=uq)zUnPX110>xCrmTqJqDBvCqnAn+toCZ$p?B~$j~7UE$SM&L+_7o-)XRT2gZ zWTjSaC0BN(SAHc}hNW1JC0UjwSgKY_s@heqbo4SV3Oo)=B93vmTUT=QmmQx zcxHKl4aK1bY2r<92~Tn=*9f^04UuMY7UwqfCMW(PfXUDbEoN1MMr$1>o_OczaLsL< zQ(hK?{>^Dnb_yqWf@j#UCuz8+;E2|E>R6vC#CaOqRGC$Roza1L%7|^1kewNNz*T^4 z)fD|35wXmEE{#-4=R$DNxJiwK$&9xZsIc7@!hli5ENHZ38-ohxI-F;tbkdGRRZJZc ziNZ)Ey_=8qOE0yWdwGVKnA(f(Q=m~qt5ub(T@*;IQ+9fkNSPEcUB`+-gb*@{K_MD7 zt=hHqD3LBH|L}`6ov4R7XhQ56f$kH8N)&uXS1}b4m5yj+mS})xkd5l7ISo>gK7@!S zX`tDftfgr%t*MtPDUc=_eVPTS*(jcZNsdj#m^ss(E~$Bm>6j`)j-Du(J?W^KCw1Qb zX0VCrN7)#WIVqPyDIdUSm5 zCr)T~tktqfQ55-*iDbvpAdSg3+HacOLxW-58sr;IkIcAl&WX-~s(=XB%8Q}ybKKCIaCXM+;!sdy;Y9x8SoD6Q(Mqp1;6O>Ngkg2)neo1~f(4VC4prv9>K`a9 zx{QgY>g=2O{ZT^kGE<4qlwU93f z87?asZRAETxGFCnO4{_Qulddh#9*(_IxmWb)ctC1a*ZhcR#~;QZ{V7&s@yL+?Qg3h zF!HJ_{c4N$>d{7_uV}(=U`Fe;ZU@-943zL{hGr|ctwvUDl7TkSS&40XbnC6g>#rQd24u>#hk?>kon6Xh=4>#KnS8E~^?9L*r6R#x` z5A73Au~kN~#C9wdXR-QOFm7tG7ayz@-!RF5EZ1Ohh4Gdd2ka#+tGi8X8gDKc+d~+K z??|z%9qZPW-Z337Zqm+dNs#OJwpR-IG5#vT9RF<6-Yg%B{wE<1ZhCHKBZCAW>v19f zF(o^)A#<@(OqB+Y*n!!T+v4ry$`Dblt<{=sf98|aM$#x3(19)}RYeEWQ0#by*d#TZ z7TInnvvR72(T0t!F0V47wZnaKYT(iu;-+rzHgJUmu<=&v7b$ZkBa|UcS%*$D4N2;b z{s=T3^YONFl$O)*CNuE*?{wDYCPFHbjQ-{`MDyL0F^igyZd_X10&-ZS_zbTeDj zC2KS`<1s)_syIn7L60bv-PSF{i*?d(kpLRskG6y zB5_wAn?b)agidJ>n`lCB#d<_24Lch!p)!G;wLPbGDRc6*p|B6*wGu1CA%C&>q857Q z&Ksk|U=wyfFVB!hF5#%v-N_9DAyAeZO=HuiQZvSh}#^dj;juk>x#Y;Jq4keM-K zH1{QY^h=f;u6EM4ZE#vbQ`?2U zw1Eq#ECEVnO89>hu4-@Z<0AE{PB?%Ew2;1Ye)DC6htz`?lE#)ZO#d!QhcAXB*j&yy zjn}x1-#Ctwp;+xRNh9lQ+4O+wYKPCexy@dt0|D zJJN(Q2nYxEa8hV>Lrb4*^#^M?5H~|xoH?4Oxtgyzo42`}zd4-8xtz~AnnTZ+d+Ter zmQ33=Wtusi|2d!sx}Xm_q0{+Cmj33RLu_WIBvG#9RZ916>F!A~`b#=`6>G9$A}po5 zq@@?-_J!Tkk)lJ!-(hX~Np?C>G9*Us0nYgxF*;#unYu}$dURuYLlI%9kDl&z0?Xkd zGa}^JAz$2yLdykvHp;@NW8R^MW;v3AC;;Nv38LLa-Q&g1Bfg@XnV1dQLP5F#L3aBu za3e}0q_DRFF)m*!yaMMX`|9~*Y&N^&rDMF$`#<*MG0KY_3{4*7JHPKc3Y?-lzGE5y zygR^0xvTr!5j(=G9K)X+x}!TN{2{y71+BXzynkY~`(wS+`_I9;zw0|R^n1upqCf^b zJPN!U=mU)c z%AdT+4}3wiQ1XHL%g4O(A;b$7qs_y7%VXcNgC@@pqtBzG7@8wC;`_%Ny}yq<$ZzA) zb9>4Yd^?Ph!-t(8em(Qyyz-g*!?U~#Rs2b+dLTL<^|p+}%t3+_!w?`(eY|z2^6!-g~~zucmP4#I`%Z<6EG? zt)}g7Wb^kquv7p3=WAxx9RML50Qj4L_ly7dKScN|#Q7(KtZ!uXYvi3V097VJ`NzQg zGerHfgZG#J{WnDRt7iK@BnSY2AS5G+rl=_lLjcE&TPEs_=l7xS{SOT4c*0_lM-(KD zLYIgMjY_A~s+E~Y(5~FB_X}n|OQ#>p6_e4jq=OrUd@JAXxE!9UtLn?$eNLnoNC&5< z1ej;&qsZ4rSlG7+xul3_cxUKT7RK4>`5Bb81xi|K8aBoPboP=KFf&k-m)KToJBzo6 zdzh0Hn2W?4964y~JM^o27|h!obljXQ42-9FdX1f3BpR#j{SBVFsl)2}x@MDmEA3lJ zyc?;m{>%P6Jh_hFJAb+CSP29zAhmUJtbsd-5EQqB3>$(G7it6=bLe(O!voFPyLm%= z80*)MUA~MSr+us^Mc~Jk&T1KS2s0)YE!||=yx9ZdDv7OJRg{;J5zvws^|7Qk4du~% zI8-Jz+46@|kwuTa#EBK>!mM0z>NLaCT!5c^>^PEV36P*h{-Q!kRLst>L2}Qg^;66e zAvyn~B6@qTEnN~mu~$))1uC`>sssl=K)lWI&ZEM!@pOLMV| z1GDMXRyebMZ3T3W$37#cgN?gK-yWK>`2Gz%xbWe`iyJ?VJh}4a%$pBiK{K~>DY9|U zPX6g8125KUcw92Z(t+^7aXq3I8&?pW$dP*#gn09w5vdRuyY^0usDyn~9 zVwhjG)?SNkw%TrMpA#+g^lF{8#_FW4EBZOEpbe@EM54el3apHq7RxEK#)em~rTH$4 zBec?&+B-2Z@&{|5N+RCe? z%%#(#dOH!FlErG`ixxY$?w(vTi0-aExchFfWCu;Dv5;~)Y1-qZfoX;QY-cJr3?@s> z8q|2RtnjyDm3Z?MfyY#(jmcJd_ui%Ht+GA-t{LO|8OM2N zk5?V8%TzCWMB@Z`UC{NFI6pgQKnDU3g5Eoy)6_GYfb|G_ z+tXh65;(yS{;q-`d|vn<7(4|^ka#Lo;Rr?O!W4e*FzJijZP@vu!~<`97ljGzl!7(Em!P=qpEVd&Ol9Sv@RgB>Km2b=gpCsOf=GqhqA zr#Qkh!Vrxpl;IlFxR@GR?S?+gVG^wXL?a4uk97=!9`(n+I|h;q?L%M#%SXi~nsAJa zgyZr=fB*!fM?_jAQUbcjJ=?iLf@Q2CBF(7C29lA5ZT@EFB%`cfbAp zua2`6WC3fbKUv}ukVV9w4g)y99S$*=>>J=8i8w_6`4E=FOy(}>$Hd-=vW$o17HaWgcO4FQ;ROK~MN&d=swox&yOrGhI*++cxvX?B$&Mvy*t+W;Yi=NpNoP zl9>FWMZxGvltPc4@R$WW(74u>piot$8?BmFnUe64SOuw8yK%j)cJPCT zJSSC4$k7w3wWXY$=Sw*o$C@JVtyjC{LkH{B{+^yTpQ=r*UE?ZLTDI1qNfl^cX$#Sz zHmwvElpYDN>X=GG2R=9HEe?$PI<{iPtwySoFyqI}W+pV4u>_`d->1-7-jcf6#V#&? zs!Qoscc;6|t3r8MOQ7-;Gph5#Jbf#L*_nX2)>P*y-rEEGLP5V=VeU^FY6Jj(LBK*F z@HGsq%oOa_6V-%oe1%Jy1_MFDQlM~G{JTB}duG8JzRB!5Y#IzJ55$?_Fo|LE;S+aG zwCWqNiWOtx7b6D3GR};MO&7DQRiSb@?plpi5aS zrvGX_(&WPrOd_h;~D(jiF zixya8&gr$Ue+}$l z3me$ggDjzIFiw@x+7zx<=}JGD-&rdc#hY%fWGJ2MDkO%{qVBf0zdgwsY*m~kE$2p~ zm_{e2d$C|mq)MeKRW*|GrJD7ItxHY4Y+HKQ$JVzgE}d+1M-`)^6zc-1I#!mZwUldI zD_R|naM@M+C)oCP6t>-Oi|hV++|UU)vI1t zah?-=>pGw5yWePVuoryi%icJKAg5(~p9{(2tR_jk!2kF6Dji zKG*tMRqk#x0{*1#M6B3@Zuqm?Gynylc+wfKHMi&9K$5?c?sKnn;8Q;MQ4cY{XWscP zT$;YHVR_D};C#;?zW&A6zWur;zo+3Ved%o1{_eRye9VhV?#b_jeB%>J3*)5hcsKfl zt%~Z2!%8(;s}<(2&wICbKl|RV{NuxqC&jlo$47PLr)_uUA?gP`(YJu^=Ltx+c=?xq z#MggH=6jDPeqKX?!uK!aXMkXEXdh^P@<$r<2Qk72d>Pn%mp6eGD1Im?fS%!jBB*=_ zNP|a5g4Gv+v$8c=1A|S{ctQAo*vEo>0(a6vfDH(LR=|M8gGdVKBO!Q$(kFX}XM4yu zg+efcU+08O=zs|ahI=E0S;z$tSb$_0T$_h$^~P?bw@y!pS=JPW7Ij%LWqfsqhBa4( z)Tel7n1_!w{%A8-cQO^N6a5iaFSax)=(q z=y!Zac(e#|hLwn27(QBej57FnnC6RVxQCPYa%8xLswa%aIERS1JGE$yAlHOgR(HlB za2mypUO0&5_-tjzerYC&X*Z2oSdI0ij4#xFN(gbMmv!}(NS3vZlW}!kHIDB0jmJe+ z1Q`U)){4y7j%!AV&qxly=#bEOYg~nM-AF;9h>>(ykipnlaY&C-R8?eji;2dI6B&^Y zsfK?37?J-NdK@`+q9_*6mrbVhdh_UpWJiuOwvc<)kS7^ZHSvyl$dcPbS<^I%q&JJp z$VtjblW%yFFgbKzcnzuOlN^$gRVk4@33@~skhYkNBbk#MRftPzlcHFN{TP2c$!R7T zh68zSU*MLcz=)h!i{}%MSot~OC|O+Tk~5Tvpk<70d5y;Slw~=VB&n8($ChHLltzG- zLJ*g&27CF)n05(~cv)6PmXR@)nl7W5J!wv1H;?}L z*p#kVa0h{qF`1C5r<;MOk`B3i`f&|X`C?SLPBpoS<%pAhIgEy=4cV!V6Qq=P*_)q- ze)>q8RS=oJWuC$rM(xRoh-jL_2!;3cb6zQrriYTdX^K8MhS{*6{8^IFsi4gkmY#T> zgqWTT0iQBCaLPrWSoxrs`IF9hg;7&)2&$C9DV@^!n4r*l8)=a4nU@UuozFO;BwB1H zI)AKLkPQ}}EV_4XxSSlCl*#yP^Ld#hnxi@@ZmP+UL3x8yH*8gErB{ljSt=ZvNuf>( zjXYX{8Mlb1ICbD=re_*yHL96jY6cT3r8F3#RoSFE+Mo4#m2CQ?Yl^2Cl>V3}>ZEb% zpt-oGJBoHu%9|^>q?nm%#PO$YdZ^%;sCHV4T%~GU2z}a#j-Z632T7jEMQwfBqYdhd zfO?XbmIIVUqx&^&i-e@k7onL74s|M`kvgk-d8(R(dY_r3^mvTu_K{*lq%5><9x0MV zDsiA1rlP8gq>8AviUVI%lY{qu$q9y@1(l`wk}bt`jcImZs)ILLiOdSA&UypT+M>p_ zsfp-@>Y94mIG7YS!0V_T~+OF)GLZo@FAghUJ^s*1QX(s!vGy0(( z$*btdi0sCzDGQ;o*l@&YmOts8>DaJ83qHgsvUK@0I}0LRS+%*DjeqHE{z{0mDROXY zdYuY_OY5frdX2;Bl=pa+UN@cximBDAw(%HiPz$#)G_{O`kcTCQY5S@N5uWbRsL0y1 zc&n}TsGb2kh^?2ZFbcTwnNnP%0rmV$D6t;y1b98lj^&^kJY}TD~Bm7n_oM6X4$|)TEB34r1&ei3);2$n~6Ayt!9Ok zb*WZRskWhohX+ikv-g~DDuVR6unf$$3!Apg$*PvMloCve3Vgt_+FoQztGF}4CpM={ z%8MeP!XMZ&MEs~>K)}m$#6?W8lq+dT{KNv|#GIOKO)SNDDq;$j#q`?4fm*^QoTr7# zFk~{XJZ#3`x~w!2CL>iGlPf0blg4l?CTBdwZA|{D!y$SN%W^hbzn&Ov8o~`>vWT@| z$B@Vk40Fg{JQ0zFub3OLWZStpJIP5qfGAwZMzY94NfU~!#*Ewwj%=}%Ih#nioDXb= zBMYp+8@0HI$%S0S$(P74v&rGw$(qbnkG!z}yn3tKh)-x(sJpTkcFUP;$e+x~RTIlb ze9NNDvy=&Rd+WcR35y`vx0URV#ca%;49DE8#m#(dIQClt_pjuba_5`MBd0q>3%;;1 z%iHYDGRvJ)P@t+R6A%l{*j%IW?4`5p%xBBL08Fg|JkO*FzX0>fi`X<)>#&v#nLo^6 z{hO*R_s)hCyA{S(#kr~wjnJVS&UAzV%KmoBrTexboX$~IdZ)R>1q{!xvWCMui=PRb zb{N6A%F$O~n^{ZA&)XAFMZk-MjZUjL{`}FpT)d!Iq@RVc@|%ux%TlfEhzYGag~iV3 zJI#s3!NW|!@2h|mUCcf`(oZX}2gvAvv@A3c;*9e&D=8uWOGteQNLQ)^SaHxGdC%b&&=Ay|!z- zynD45{JZ-6r2L$IhfU2Ms>+{BzHz76$SkRa{MN61uvBf%61~eAyVPKZ5ZddtOEy$}a##V`V{*nzDf|!vU?6uI{%X`h&_iNf-t<1h1x`7GEy(+%G zj5le`+O@je2P@eHK-mrW+rb>WsQhrj3f11wz$#kV&?wp#sk_t~og7KDP3h25huq1n zo0$yTvE9XJ+}m^Q)aCP*(|m41d%b6!*o}PP-Q3c&tdhoEet=!eh#cSozRwq)-a?$+ z9sY;n4dTTn;v>%1B|hFK{^1}F+3>u~bI0K?p3EL?;$U3f3SHqI?&5oj;?VKNblTS2 zT;o-D<3b+e;`rd8ZN>S#u92K`yIsBUD%I+<<5T+8KMu+mPHvnTnvPxN8SU4m9ne>f z<^{XrNltT1{>>CVQWc5*po6`7+i>5;o<1 zOXk0r>Bns0EN+FgyYSlxlxT{W+F)iqAUg&5D=WIIUH@E0@?&!GP zi6ni^7KGKLU5__wcEm0MTB_~a&h6d)8!8Uw+*r??inD5tn+1K`a<1rNj^COXz`}Y~ zmcHlg>OiLs+;|P;5BBOVji&wX@7ogMvVMqU{*@c;sqyVNO}>}E`Q+~n;j&imq%L%P zj&~Jm(`8Aum_F!QzUgrO+T{vftcD4~X5F|JR=7vKkH2nY>TXGEtr*lTI!A8IZVq$D zUhVH%&C(3s{9C#V=eO+m=_~NMV`>vHpT5}M@hklCw9Cr?x`4_{?P-4U?A%{5E*(a1 zV=|w~G_P?s&*1B9*-roT<}1Ot>+thC?kp|vVm#wWUhJ~l>7|bA+-s=>9mqG2@3;<* zL7(DnKl5)7k4vAk*GX#yKcJ=Q-6cQ25l+l3pW>k{;#_ZWUeDh^>euKCuQsgSLmI=1 z)#}5(_9pE2TMzhCNcoC`^%@`UeXsSfT>6}z;7R`)TFns2F5|85<6G|WagX{M4)m*k z`}=

hdQ9&1RFu;^6!fKlTV*>qvE+S0Cjg2{4&-L`B# zqtohj3Oozwcq160Zm*L^!s=dWr5Z8y0ZI`SJ{bnuAhI<&lDOeW-o*6)I$;VfVP0+i zefn`Gem<72>>wa`LB_nnjmeqH&eGPpM84*U(B0YT76lHC9v*rM>s2N3T|$j2huTKB zwN6&&#{LQ}E)6ClXL@TYXZjH*YD=4uB zW(FB~ni8y@JY3dr-~)${R5wv3u9W-Mj8P|sYt*q@P{LtEk0wu|y9bNaK0N*W1+-Yv zo1teL0VXSS6QwkV4{em(#OE2poC`%|#OZ9=H=bK|g#1Dc-b$xduQpQoi`TwiePYJ! zs1P7HqhM!ZE#>nk)n6L_{TW6M?!dXlbSjz)>}XmRP(@08cdaks!Y#C7-m{I3 zaVol0t~sTU4X0VlHYn!K@&EuvK@t{>(xy+NPOW-1>(;Jc!;UR`Hf_~&rbbkJ$L$S^ z{=$M4yGRA;zl`0Qb@XgT^Ut7@ltb@1^;(ze)~{pFu6;ZA?%uzH4=;W^_k8biC)gf+ zJxb;eIkS%+ZM0kY_EX}nx~sgrhxhxsXAOM+5y%F8FBO=eBZw*3AUy$AGoXVL9yXnX z6k^B%gBf!82!xYd*kOkUiddqC`PFBlinmP1R$BSJ>G!09OIqomlUb?=p#e2~`68EBT3F?n32u4j zh&$d8W&my?sit9A%6VU!byDahm|~>(mP9QiHx6HTj#Or!ghqEKqGSp-iIi^s4ra+$ zO|1~h4N9LN*43R3g0wvW+=i4 zD8~kQ%G5^XlzQg7CPX>qx0325=uQ{6Oo&-F4dPpGppMFrItWBHa=iW}!<25v5{(M8 z#^JO~(PT}n%QJrGag9aNT_gN4BJE}wvRg(%H0#dW6qoVWI;HC|Ozb8^_dFoACI-QE}Y^VCpjJY#&V)F zo$6fYE57N@cfymJ+KeYX>uFDLvNNCh+$TT#>Cb-xG@t@a9UPbVih&|Dp$c6nLmTSQ zhe9->5}oKk3wi?{9+RRP-6%&9YEg84bP^#=;T6Z&QH6%|jUP?vI9Y1SlA5#{F+FKO SS&C8A(KM$z-D&DV002A2`|yhZ literal 0 HcmV?d00001 diff --git a/docs/dump.html b/docs/dump.html new file mode 100755 index 0000000..696a0f1 --- /dev/null +++ b/docs/dump.html @@ -0,0 +1,77 @@ + + +TkCon: dump procedure + + + +

TkCon: `dump` procedure

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ + + + + + + + + + + + + +

Getting Started	Special Bindings	Procedures
`dump`	`tkcon`	`idebug`	`observe`

+ +

+The dump command provides a way for the user to spit out +state information about the interpreter in a Tcl readable (and human +readable) form. It takes the general form: + +

+dump method ?-nocomplain? ?-filter pattern? ?--? +pattern ?pattern ...? +

+ +The patterns represent glob-style patterns (as in

string match pattern
+$str

). -nocomplain will prevent dump from +throwing an error if no items matched the pattern. -filter is +interpreted as appropriate for the method. The various methods are: + +

dump command args +: Outputs one or more commands. + +
dump procedure args +: Outputs one or more procs in sourceable form. + +
dump variable args +: Outputs the values of variables in sourceable form. Recognizes nested +arrays. The -filter pattern is used as to filter array element +names and is interepreted as a glob pattern (defaults to {*}). +It is passed down for nested arrays. + +
dump widget args +: Outputs one or more widgets by giving their configuration options. +The -filter pattern is used as to filter the config options and +is interpreted as a case insensitive regexp pattern (defaults to {.*}) + +

+ +

+ + + diff --git a/docs/idebug.html b/docs/idebug.html new file mode 100755 index 0000000..e557910 --- /dev/null +++ b/docs/idebug.html @@ -0,0 +1,99 @@ + + +TkCon: idebug procedure + + + +

TkCon: `idebug` procedure

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ + + + + + + + + + + + + +

Getting Started	Special Bindings	Procedures
`dump`	`tkcon`	`idebug`	`observe`

+ +

+The idebug command provides an interactive debugging environment for +procedures via TkCon. You can place idebug break commands +into your procedure to create breakpoints. It will pop up the TkCon +console and put you into a "debugging" mode. The body, show & +trace methods are intended for internal use only. +

+ +This procedure is experimental (to say the least). Comments are encouraged. + +

idebug body ?level? +: Prints out the body of the command (if it is a procedure) at the +specified level. level defaults to the current level. + +
idebug break ?id? +: Creates a breakpoint within a procedure. This will only trigger if +idebug is on and the id matches the pattern. If so, TkCon will pop to the +front with the prompt changed to an idebug prompt. You are given the basic +ability to observe the call stack an query/set variables or execute Tcl +commands at any level. A separate history is maintained in debugging mode. + +
idebug {echo ?id?} ?args? +: Behaves just like echo, but only triggers when idebug is +on. You can specify an optional id to further restrict triggering. If no +id is specified, it defaults to the name of the command in which the call +was made. + +
idebug id ?id? +: Query or set the idebug id. This id is used by other idebug methods +to determine if they should trigger or not. The idebug id can be a glob +pattern and defaults to *. + +
idebug off +: Turns idebug off. + +
idebug on ?id? +: Turns idebug on. If id is specified, it sets the id to it. + +
idebug {puts ?id?} args +: Behaves just like puts, but only triggers when idebug is +on. You can specify an optional id to further restrict triggering. If no +id is specified, it defaults to the name of the command in which the call +was made. + +
idebug show type ?level? ?VERBOSE? +: type must be one of vars, locals or globals. This method +will output the variables/locals/globals present in a particular level. +If VERBOSE is added, then it actually 'dump's out the values as well. +level defaults to the level in which this method was called. + +
idebug trace ?level? +: Prints out the stack trace from the specified level up to the top +level. level defaults to the current level. + +

+ +

+ + + diff --git a/docs/index.html b/docs/index.html new file mode 100755 index 0000000..9c9fca8 --- /dev/null +++ b/docs/index.html @@ -0,0 +1,53 @@ + + +TkCon: Documentation + + + + +

TkCon: Documentation (March 1999)

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ +

newest tkcon release (tar,gzip'ed)

+ +

Screenshot (tar,gzip'ed)

+ +Please read the following pages carefully to fully understand the +features AND limitations of TkCon. I'm always open to suggestions for +improvement. Send them to my +suggestion box. +

+ + + + + + + + + + + + + +
Getting Started:
+TkCon resource file and command line options Special Bindings New Procedures in TkCon
dump procedure tkcon procedure idebug procedure observe procedure
+ +

+ + + diff --git a/docs/license.terms b/docs/license.terms new file mode 100755 index 0000000..6928ccb --- /dev/null +++ b/docs/license.terms @@ -0,0 +1,40 @@ + * COPYRIGHT AND LICENSE TERMS * + +(This file blatantly stolen from Tcl/Tk license and adapted - thus assume +it falls under similar license terms). + +This software is copyrighted by Jeffrey Hobbs . The +following terms apply to all files associated with the software unless +explicitly disclaimed in individual files. + +The authors hereby grant permission to use, copy, modify, distribute, and +license this software and its documentation for any purpose, provided that +existing copyright notices are retained in all copies and that this notice +is included verbatim in any distributions. No written agreement, license, +or royalty fee is required for any of the authorized uses. + +IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY FOR +DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT +OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY DERIVATIVES THEREOF, +EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE IS +PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE NO +OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR +MODIFICATIONS. + +RESTRICTED RIGHTS: Use, duplication or disclosure by the U.S. government +is subject to the restrictions as set forth in subparagraph (c) (1) (ii) +of the Rights in Technical Data and Computer Software Clause as DFARS +252.227-7013 and FAR 52.227-19. + +SPECIAL NOTES: + +This software is also falls under the bourbon_ware clause: + + Should you find this software useful in your daily work, you should feel + obliged to take the author out for a drink if the opportunity presents + itself. The user may feel exempt from this clause if they are below + drinking age or think the author has already partaken of too many drinks. diff --git a/docs/limits.html b/docs/limits.html new file mode 100755 index 0000000..8c53468 --- /dev/null +++ b/docs/limits.html @@ -0,0 +1,55 @@ + + +TkCon: Limitations + + + +

TkCon: Limitations

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ +

Limitations:

+ +TkCon requires Tk4.2+. Since TkCon is meant to behave like the original Tk +console, it does not separate itself from the environment (it does not use +send to function, except when attached to foreign Tk interpreters). This +means that it can be can be altered or destroyed by any sourced +applications, and it will respond to an application's 'exit' call by +exiting (by default, slave consoles will only close themselves instead of +exiting the entire TkCon environment). However, the widget tree of TkCon +is hidden from the user environment. +

+ +Since TkCon is built for cross-platform capability, in +Unix/Windows environments it does not have tty/shell behavior. This +means programs like vi and less (those that rely +on tty/shell settings) will not function appropriately (currently they may +hang TkCon). Programs like ls and more will just +spit output to the TkCon screen without any special control or formatting +(note that ls has been rewritten for TkCon). You also do not +get any job (process) control outside of what tcl normally can provide. +Currently there is no way to handle stdin input. +

+ +When connecting to non-Tcl Tk interpreters (ie - PerlTk, SchemeTk, ...), +you must use the syntax of the target environment. See my +notes on using other Tk-embedded languages for +more info. + +

+ + + diff --git a/docs/nontcl.html b/docs/nontcl.html new file mode 100755 index 0000000..47b3e11 --- /dev/null +++ b/docs/nontcl.html @@ -0,0 +1,54 @@ + + +TkCon for Non-Tcl Users + + + +

TkCon for Non-Tcl Users

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ +This document is for those users who are trying to use TkCon with a +non-Tcl based Tk language (ie - SchemeTk, PerlTk, PythonTk...). +

+ +TkCon requires Tcl 7.6 / Tk 4.2 to +run (better with 8.0+). However, it can attach to any language with Tk4+ +embedded into it with the use of the Tk 'send' command. I have been able +to succesfully talk to SchemeTk-3.0 and Perl/Tk. When using TkCon attached +to these interpreters, you must remember to talk to the connected +interpreter in its language. +

+I welcome further comments from users of Tk-embedded languages on their +experiences or ideas. Of course, you can always try to port TkCon in full +to your language. I'd like to see the results from any such efforts. +

+ +

Special Language Notes:

+ +

Perl Tk

+ +Read the man page on Perl/Tk's send command. You have to define Tk::Receive +before it will work. +Stephen Lidie +(lusol@Turkey.CC.Lehigh.EDU) contributed +a companion Perl/Tk program that does the trick with +some extras. + +

+ + + diff --git a/docs/observe.html b/docs/observe.html new file mode 100755 index 0000000..09defbc --- /dev/null +++ b/docs/observe.html @@ -0,0 +1,80 @@ + + +TkCon: observe procedure + + + +

TkCon: `observe` procedure

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ + + + + + + + + + + + + +

Getting Started	Special Bindings	Procedures
`dump`	`tkcon`	`idebug`	`observe`

+ +

+This command provides runtime debugging output for variables and commands +without the need to edit your code. For variables, the underlying mechanism +uses trace and dump var. For commands, it renames +the observed procedure and uses a special wrapper procedure. WARNING: using this procedure after checkpointing +state will result in major problems if you clean state because the renamed +(true) commands will be lost. +

+ +This procedure is experimental. Comments are encouraged. + +

observe command cmdname ?maxlevel? +: This will create a wrapper command which prints out (using +dump) the call stack to the console. maxlevel +represents the maximum number of levels of the call stack which will be +printed (defaults to 4). + +
observe cdelete cmdname +: Removes the wrapper around an observed command. + +
observe cinfo cmdname +: Prints out useless info. + +
observe variable varname operation ?args? +: Currently a wrapper around trace that uses dump to +print out the value of the named variable whenever the specified operation +on that variable occurs (must be read, write or unset). + +
observe vdelete varname operation +: Deletes the trace wrapper around the named variable. + +
observe vinfo varname +: Prints out trace info about the named variable. + +

+ +

+ + + diff --git a/docs/perl.txt b/docs/perl.txt new file mode 100755 index 0000000..37463b5 --- /dev/null +++ b/docs/perl.txt @@ -0,0 +1,109 @@ +#!/usr/local/bin/perl -w + +# tkcon.pl - a Perl/Tk "shell" companion for tkcon.tcl. +# +# Variable $MW is an object reference to the main window, from which you can +# create and manipulate child widgets. Variable names beginning with an +# underscore are reserved for this application. +# +# Stephen O. Lidie, 96/08/25 + +require 5.002; +use English; +use Tk; +use Tk::Pretty qw(Pretty); +use Tk::Dialog; +use strict; +use subs qw(doit tkcon); +my($MW, $_TKCON, $_VERSION, $_HELP, $_SHELL, $_TAB, $_PARA, @_ERRORS, $_MES); + +tkcon; # main + +sub doit { + + # Eval some code without use strict constraints. + + my($code) = @ARG; + + { + no strict; + if ($_MES) { + $_MES->packForget; + $_MES->destroy; + $_MES = 0; + } + @_ERRORS = (); + $SIG{'__WARN__'} = sub {push @_ERRORS, @ARG}; + my $_res = eval $code; + push @_ERRORS, $EVAL_ERROR if $EVAL_ERROR; + push @_ERRORS, $_res; + } + +} # end doit + +sub tkcon { + + # Nothing fancy here, just create the main window and the help dialog + # object, and display a pointer to the help. + + $_TKCON = 'tkcon.pl'; + $_VERSION = '0.2'; + $_SHELL = '/bin/sh'; + $_SHELL = $ENV{'SHELL'} if $ENV{'SHELL'}; + $_TAB = 0; + $_PARA = ''; + + $MW = MainWindow->new; + $MW->title($_TKCON); + $MW->iconname($_TKCON); + $_HELP = $MW->Dialog( + -title => "$_TKCON Help", + -font => 'fixed', + -wraplength => '6i', + -justify => 'left', + -text => + "? - this text.\n" . + "| - pass arguments to your shell (default /bin/sh).\n" . + "p - use Tk::Pretty to \"pretty-print\" arguments.\n" . + "+ - a tab starts/stops multiline input mode.\n" . + "exit - quit $_TKCON.\n" . + "\nOther input is assumed to be a Perl/Tk command.\n" . + "\n\$MW is the MainWindow.\n", + ); + $_HELP->configure(-foreground => 'blue'); + $_MES = $MW->Label(-text => "\nEnter ? for help.\n")->pack; + MainLoop; + +} # end tkcon + +sub Tk::Receive { + + shift(); + $ARG = shift(); + if (/^\?(.*)/) { # help + $_HELP->Show; + } elsif (/^\|(.*)/) { # bang + @_ERRORS = (); + push @_ERRORS, `$_SHELL -c $1 2>&1`; + } elsif (/^\+$/) { + $_TAB++; + if ($_TAB % 2) { + @_ERRORS = (); + $_PARA = ''; + push @_ERRORS, '+'; + } else { + doit $_PARA; + } + } else { # Perl/Tk command + $ARG = "Pretty($1)" if (/^p\s(.*)$/); + if ($_TAB % 2) { + $_PARA .= $ARG; + push @_ERRORS, '+'; + } else { + doit $ARG; + } + } # ifend + + return @_ERRORS; + +} # end Tk::Receive diff --git a/docs/plugin.html b/docs/plugin.html new file mode 100755 index 0000000..253a66e --- /dev/null +++ b/docs/plugin.html @@ -0,0 +1,66 @@ + + +Tcl Plugin Stripped TkCon Demo + + + +

Tcl Plugin Stripped TkCon Demo

+ +Full TkCon Distribution +

+ +This is the full TkCon script when run inside the plugin. It feels like a +stripped down version of TkCon, but the only limitations are those +established by the plugin. You can test the basic console features and get +a feel for the mutli-color output. Below the demo are some ideas to try +out. v2 of the plugin is distributed with a megawidget version of TkCon for +debugging tclets. + +

+ +

+ +Have a look at some of the features: (culled from the +full TkCon documentation) +

Variable / Path / Procedure Name Expansion. Type in +set tc at the prompt. Hit <Control-Shift-V>. +set tcl_ should now be visible. +Hit <Control-Shift-V> again. You should see the rest of +the completions printed out for you. Works the same for procedures +and files paths (file access restricted from plugin). Works properly +when spaces or other funny characters are including in the name. + +
Command Highlighting. Note that set should be in +green, denoting it is a recognized command in that interpreter. + +
Electric Character Matching. Watch while you type the +following: proc foo { a b } { puts [list $a $b] }. Did you +notice the blink matching of the braces? Yes, it's smart. + +
Command History. Use the Up/Down arrows or +<Control-p>/<Control-n> to peruse the command +history. <Control-r>/<Control-s> Actually +does command history matching (like tcsh or other advanced Unix shells). + +
Useful Colorization. Having defined foo above, type +in foo hey. Note that the error comes back in red. Go up one +in the command history and add you and see that regular +stdout output comes through in blue (the colors are configurable). + +
Cut/Copy/Paste. You should be able to do that between outside +windows and TkCon. The default keys are +<Control-x>/<Control-c>/<Control-v>. + +

+ +

+Contact jeff.hobbs@acm.org +with questions or updated info. +

+ + + diff --git a/docs/procs.html b/docs/procs.html new file mode 100755 index 0000000..2a85eb1 --- /dev/null +++ b/docs/procs.html @@ -0,0 +1,143 @@ + + +TkCon: Procedures + + + +

TkCon: Procedures

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ + + + + + + + + + + + + +

Getting Started	Special Bindings	Procedures
`dump`	`tkcon`	`idebug`	`observe`

+ +

+There are several new procedures introduced in TkCon to improve +productivity and/or account for lost functionality in the Tcl environment +that users are used to in native environments. There are also some +redefined procedures. Here is a non-comprehensive list: + +

alias ?sourceCmd targetCmd ?arg arg ...?? +: Simple alias mechanism. It will overwrite existing commands. +When called without args, it returns current aliases. Note that TkCon +makes some aliases for you (in slaves). +Don't delete those. + +
clear ?percentage? +: Clears the text widget. Same as the <Control-l> binding, except +this will accept a percentage of the buffer to clear (1-100, 100 default). + +
dir ?-all? ?-full? ?-long? ?pattern pattern ...? +: Cheap way to get directory listings. Uses glob style pattern matching. + +
dump type ?-nocomplain? ?-filter pattern? ?--? +pattern ?pattern ...? +: The dump command provides a way for the user to spit out +state information about the interpreter in a Tcl readable (and human +readable) form. +See further dump docs for details. + +
echo ?arg arg ...? +: Concatenates the args and spits the result to the console (stdout). + +
edit ?-type type? ?-find str? ?-attach interp? arg +NEW in v1.4, still under construction +: Opens an editor with the data from arg. The optional type +argument can be one of: proc, var or file. For +proc or var, the arg may be a pattern. + +
idebug command ?args? +: Interactive debugging command. +See further idebug docs for details. + +
lremove ?-all? ?-regexp -glob? list items +: Removes one or more items from a list and returns the new list. If +-all is specified, it removes all instances of each item in the +list. If -regexp or -glob is specified, it interprets each +item in the items list as a regexp or glob pattern to match against. + +
less +: Aliased to edit. + +
ls +: Aliased to dir -full. + +
more +: Aliased to edit. + +
observe type ?args? +: This command provides passive runtime debugging output for variables +and commands. +See further observe docs for details. + +
puts (same options as always) +: Redefined to put the output into TkCon + +
tkcon method ?args? +: Multi-purpose command. +See further tkcon docs for details. + +
tclindex ?-extensions patternlist? ?-index TCL_BOOLEAN? +?-package TCL_BOOLEAN? ?dir1 dir2 ...? +: Convenience proc to update the tclIndex (controlled by -index switch) +and/or pkgIndex.tcl (controlled by -package switch) file in the named +directories based on the given pattern for files. It defaults to creating +the tclIndex but not the pkgIndex.tcl file, with the directory defaulting +to [pwd]. The extension defaults to *.tcl, with *.[info sharelibextension] +added when -package is true. + +
unalias cmd +: unaliases command + +
what string +: The what command will identify the word given in +string in the Tcl environment and return a list of types that +it was recognized as. Possible types are: alias, procedure, command, +variable, directory, file, widget, and executable. Used by procedures +dump and which. + +
which command +: Like the 'which' command of Unix shells, this will tell you if a +particular command is known, and if so, whether it is internal or external +to the interpreter. If it is an internal command and there is a slot in +auto_index for it, it tells you the file that auto_index would load. This +does not necessarily mean that that is where the file came from, but if it +were not in the interpreter previously, then that is where the command was +found. + +

+ +There are several procedures that I use as helpers that some may find +helpful in there coding (ie - expanding pathnames). Feel free to lift +them from the code (but do assign proper attribution). + +

+ + + diff --git a/docs/purpose.html b/docs/purpose.html new file mode 100755 index 0000000..a2b0c6c --- /dev/null +++ b/docs/purpose.html @@ -0,0 +1,63 @@ + + +TkCon: Purpose & Features + + + +

TkCon: Purpose & Features

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ +

Purpose:

+ +TkCon is a replacement for the standard console that comes with Tk (on +Windows/Mac, but also works on Unix). The console itself provides +many more features than the standard console. TkCon works on all +platforms where Tcl/Tk is available. It is meant primarily to aid one when +working with the little details inside tcl and tk, giving Unix users the GUI +console provided by default in the Mac and Windows Tk. It's also not a bad +replacement for the default MS-DOS shell (although it needs lots of fine +tuning). +

+See Limitations for a good idea of what +TkCon can't do for you. + +

Features:

+ +Just in case you don't run across them while playing, here are some of the +extras in TkCon: +

Command history +
Path (Unix style) / Proc / Variable name expansion +
Multiple consoles, each with its own state (via multiple interpreters) +
Captures stdout and stderr to console window +
Electric character matching (a la emacs) +
Electric proc highlighting +
Enhanced history searching +
Configurable +
Cut / Copy / Paste between windows +
Communication between consoles and other Tk interpreters (including +non-tcl ones) +
Works on all Tk platforms +

+ +Read the documentation for how to take advantage +of these features. + +

+ + + diff --git a/docs/start.html b/docs/start.html new file mode 100755 index 0000000..957a85e --- /dev/null +++ b/docs/start.html @@ -0,0 +1,313 @@ + + +TkCon: Getting Started + + + +

TkCon: Getting Started

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ + + + + + + + + + + + + +

Getting Started	Special Bindings	Procedures
`dump`	`tkcon`	`idebug`	`observe`

+ +

Resource File:

+ +TkCon will search for a resource file in "$env(HOME)/.tkconrc" +(Unix), "$env(HOME)/tkcon.cfg" (Windows) or +"$env(PREF_FOLDER)/tkcon.cfg" (Macintosh). On DOS machines, +"$env(HOME)" usually refers to "C:\". TkCon +never sources the "~/.wishrc" file. The resource file is +sourced by each new instance of the console. An example resource file is +provided below. + +

Command Line Arguments

+ +Except for -rcfile, command line arguments are handled after +the TkCon resource file is sourced, but before the slave interpreter or the +TkCon user interface is initialized. -rcfile is handled right +before it would be sourced, allowing you to specify any alternate file. +Command line arguments are passed to each new console and will be evaluated +by each. To prevent this from happening, you have to say +tkcon main set argv {}; tkcon main set argc 0. +

+For these options, any unique substring is allowed. + +

-argv (also --) +: Causes TkCon to stop evaluating arguments and set the remaining args to +be argv/argc (with -- prepended). This carries over for any +further consoles. This is meant only for wrapping TkCon around programs +that require their own arguments. + +
-color,* color +: Sets the requested color type to the specified color for tkcon. +See the Variables section for the various color,* types. + +
-eval (also -main or -e) +: A tcl script to eval in each main interpreter. This is evaluated +after the resource file is loaded and the slave interpreter is created. +Multiple -eval switches will be recognized (in order). + +
-exec slavename +: Sets the named slave that tkcon operates in. In general, this is only +useful to set to "" (empty), indicating to tkcon to avoid the +multi-interpreter model and operate in the main environment. When this is +empty, any further arguments will be only used in the first tkcon console +and not passed onto further new consoles. This is useful when using tkcon +as a console for extended wish executables that don't load there commands +into slave interpreters. + +
-font font +: Sets the font that tkcon uses for its text windows. If this isn't +a fixed width font, tkcon will override it. + +
-nontcl TCL_BOOLEAN +: Sets TKCON(nontcl) to TCL_BOOLEAN. Needed when +attaching to non-Tcl interpreters. + +
-package package_name (also -load) +: Packages to automatically load into the slave interpreters (ie - "Tk"). + +
-rcfile filename +: Specify an alternate tkcon resource file name. + +
-root widgetname +: Makes the named widget the root name of all consoles (ie - .tkcon). + +
-slave tcl_script +: A tcl script to eval in each slave interpreter. This will append +the one specified in the tkcon resource file, if any. + +

+ +Some examples of tkcon command line startup situations: +

megawish tkcon.tcl -exec "" -root .tkcon mainfile.tcl +: Use tkcon as a console for your megawish application. You can avoid +starting the line with megawish if that is the default wish +that tkcon would use. The -root ensures that tkcon will not +conflict with the + +
tkcon.tcl -font "Courier 12" -load Tk +: Use the courier font for tkcon and always load Tk in slave +interpreters at startup. + +
tkcon.tcl -rcfile ~/.wishrc -color,bg white +: Use the ~/.wishrc file as the resource file, and +a white background for tkcon's text widgets. + +

+ +

Variables:

+ +Certain variables in TkCon can be modified to suit your needs. It's easiest +to do this in the resource file, but you can do it when time the program is +running (and some can be changed via the Prefs menu). All these are part of +the master interpreter's global array variable TKCON. You can +'tkcon set TKCON' when the program is running to check its +state. Here is an explanation of certain variables you might change or use: + +

color,bg +

The background color for tkcon text widgets. +Defaults to the operating system default (determined at startup). + +

color,blink +

The background color of the electric brace highlighting, if on. +Defaults to yellow. + +

color,cursor +

The background color for the insertion cursor in tkcon. +Defaults to black. + +

color,disabled +

The foreground color for disabled menu items. +Defaults to dark grey. + +

color,proc +

The foreground color of a recognized proc, if command highlighting is on. +Defaults to dark green. + +

color,var +

The background color of a recognized var, if command highlighting is on. +Defaults to pink. + +

color,prompt +

The foreground color of the prompt as output in the console. +Defaults to brown. + +

color,stdin +

The foreground color of the stdin for the console. +Defaults to black. + +

color,stdout +

The foreground color of the stdout as output in the console. +Defaults to blue. + +

color,stderr +

The foreground color of stderr as output in the console. +Defaults to red. +

+ +

autoload +

Packages to automatically load into the slave interpreter (ie - 'Tk'). +This is a list. Defaults to {} (none). + +

blinktime +

The amount of time (in millisecs) that braced sections should +blink for. Defaults to 500 (.5 secs), must be at least 100. + +

blinkrange +

Whether to blink the entire range for electric brace matching or to +just blink the actual matching braces (respectively 1 or 0, defaults to 1). + +

buffer +

The size of the console scroll buffer (in lines). +Defaults to 512. + +

calcmode +

Whether to allow expr commands to be run at the command +line without prefixing them with expr (just a convenience). + +

cols +

Number of columns for the console to start out with. Defaults to 80. + +

dead +

What to do with dead connected interpreters. If dead +is leave, TkCon automatically exits the dead interpreter. If +dead is ignore then it remains attached waiting for +the interpreter to reappear. Otherwise TkCon will prompt you. + +

font +

Font to use for tkcon text widgets (also specified with -font). +Defaults to the system default, or a fixed width equivalent. + +

history +

The size of the history list to keep. Defaults to 48. + +

hoterrors +

Whether hot errors are enabled or not. When enabled, errors that +are returned to the console are marked with a link to the error info +that will pop up in an minimal editor. This requires more memory because +each error that occurs will maintain bindings for this feature, as long +as the error is in the text widget. Defaults to on. + +

library +

The path to any tcl library directories (these are appended to the +auto_path when the after the resource file is loaded in). + +

lightbrace +

Whether to use the brace highlighting feature or not +(respectively 1 or 0, defaults to 1). + +

lightcmd +

Whether to use the command highlighting feature or not +(respectively 1 or 0, defaults to 1). + +

maineval +

A tcl script to execute in the main interpreter after the slave +interpreter is created and the user interface is initialized. + +

nontcl +

For those who might be using non-Tcl based Tk attachments, set this +to 1. It prevents TkCon from trying to evaluate its own Tcl code in an +attached interpreter. Also see my notes for non-Tcl +based Tk interpreters. + +

prompt1 +

Like tcl_prompt1, except it doesn't require you use 'puts'. +No equivalent for tcl_prompt2 is available (it's unnecessary IMHO). +
Defaults to {([file tail [pwd]]) [history nextid] % }. + +

rcfile +

Name of the resource file. $env(HOME) is prepended to +this. Defaults to .tkconrc on Unix and tkcon.cfg +otherwise. + +

rows +

Number of rows for the console to start out with. Defaults to 20. + +

scollypos +

Y scrollbar position. Valid values are left or +right. Defaults to left. + +

showmenu +

Show the menubar on startup (1 or 0, defaults to 1). + +

showmultiple +

Show multiple matches for path/proc/var name expansion +(1 or 0, defaults to 1). + +

slaveeval +

A tcl script to execute in each slave interpreter right after it's +created. This allows the user to have user defined info always available +in a slave. Example: +

	set TKCON(slaveeval) {
+		proc foo args { puts $args }
+		lappend auto_path .
+	}

+ +

slaveexit +

Allows the prevention of exit in slaves from exitting +the entire application. If it is equal to exit, exit will +exit as usual, otherwise it will just close down that interpreter (and +any children). Defaults to close. + +

subhistory +

Allow history substitution to occur (0 or 1, defaults to 1). The +history list is maintained in a single interpreter per TkCon console +instance. Thus you have history which can range over a series of attached +interpreters. +

+ +

+ +An example TkCon resource file might look like: + +

######################################################
+## My TkCon Resource File
+ 
+# Use 'fixed' as my default font (only valid on unix)
+set TKCON(maineval) {
+    set tkcon font fixed
+}
+# Keep 50 commands in history
+set TKCON(history) 50
+# Use a pink prompt
+set TKCON(color,prompt) pink
+######################################################

+ +

+ + + diff --git a/docs/tkcon.html b/docs/tkcon.html new file mode 100755 index 0000000..1da4e8c --- /dev/null +++ b/docs/tkcon.html @@ -0,0 +1,142 @@ + + +TkCon: tkcon procedure + + + +

TkCon: `tkcon` procedure

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ + + + + + + + + + + + + +

Getting Started	Special Bindings	Procedures
`dump`	`tkcon`	`idebug`	`observe`

+ +

+This provides lots of useful control over a console: + +

tkcon attach interpreter +: Attaches TkCon to the named interpreter. The name must be that +returned by [tk appname] or a valid path to a slave +interpreter. It's best to use this via the Console->Attach +Console menu. + +
tkcon buffer ?size? +: Sets or queries the allowed size of the console text widget in lines. +The text widget will automatically delete leading lines once this number +has been exceeded (read: this is the scroll buffer size). + +
tkcon bgerror ?msg errorInfo? +: Does bgerror stuff in the TkCon master interpreter. + +
tkcon close or tkcon destroy +: Destroys this TkCon widget. + +
tkcon console args +: Passes the args to the TkCon text widget (the console). + +
tkcon error +: Pops up a dialog that gives the user a full trace of the last error +received in the TkCon console. + +
tkcon find string ?-case TCL_BOOLEAN +-regexp TCL_BOOLEAN? +: Highlights all instances of string in the console. If the string +is empty, it clears any previous highlighting. + +
tkcon font ?fontname? +: Sets or returns the font used by tkcon text widgets. + +
tkcon gets ?varname? +: Behaves like the traditional Tcl gets, but uses the +TkCon console instead of stdin. + +
tkcon hide +: Withdraw the TkCon display from the screen (make sure you have +a way to get it back). + +
tkcon history ?-newline? +: Displays the TkCon history in sourceable form. If -newline is +specified, it separates each command by an extra newline. + +
tkcon iconify +: Iconifies the TkCon display. + +
tkcon load filename +: Sources named file into the slave interpreter. If no filename is +given, it will attempt to call tk_getOpenFile to pop up the +file select box. + +
tkcon main ?arg arg ...? +: Passes the args to the main TkCon interpreter to be evaluated and +returns the result. + +
tkcon master args +: Passes the args to the master interpreter to be evaluated and +returns the result. + +
tkcon new +: Creates a new TkCon widget. + +
tkcon save ?filename ?type?? +: Saves the console buffer to the given filename. If no filename is +given, it will attempt to call tk_getSaveFile to pop up the +file select box. If no type is given, a dialog will ask you to specify +what portion of the text you want to save. + +
tkcon set var ?value? +: Queries or sets a master interpreter variable. + +
tkcon append var ?value? +: Like set, but uses append on the variable. + +
tkcon lappend var ?value? +: Like set, but uses lappend on the variable. + +
tkcon show or tkcon deiconify +: Redisplays TkCon on the screen. + +
tkcon slave ?slavename ?arg arg ...?? +: If called with no args, it returns the name of all the TkCon +interpreters. Otherwise given an interp name it passes the args +to the named interpreter to be evaluated and returns the result. +If no args are passed, then it returns the [tk appname] +of that interpreter. + +
tkcon title ?title? +: Sets or returns the title for TkCon. + +
tkcon version +: Returns of version of TkCon. + +

+ +

+ + + diff --git a/docs/todo.html b/docs/todo.html new file mode 100755 index 0000000..6415e19 --- /dev/null +++ b/docs/todo.html @@ -0,0 +1,76 @@ + + +TkCon: To Do Ideas + + + +

TkCon: To Do Ideas

+ + + + + + + + + + + + +

TkCon Docs	Purpose & Features	Limitations	To Do
Changes	License Terms	Using TkCon with other Tk Languages

+ +

Future Ideas

+ +

Add encoding auto-conversion to exec commands +
keep history file, also keep history of sourced files +

set mimetype(extension,au) "audio/u-law"
+set mimetype(extension,wav) "audio/wave"
+set mimetype(extension,mid) "audio/midi"
+/etc/magic
+proc run {file} {
+    global mimetype
+
+    if {[file executable $file]} {
+        exec $file
+        return
+    }
+
+    catch {set mimetype $mimetype(extension,[file extension $file])}
+
+    if {![info exists mimetype]} {
+        set mimetype $mimetype(magic,[exec /bin/file $file])
+    }
+
+    exec $mimetype(application,$mimetype) $file
+}

+ +

Add socket level communication model +
Enhance the true debugging capabilities - I'm looking at +tcl-debug and into what I can adopt from the tkInspect philosophy. +
I'm taking ideas... +

+ +

Known Bugs/Quirks

+ +

Command highlighting isn't perfect because I try to make it too +efficient. +
All interpreters have the same current working directory. This is +a limitation of tcl. +
You can't 'attach' on machines where send does not exist. +John Loverso has a comm.tcl +replacement. +In any case, you can still attach to internal interpreters and namespaces. +
Need to clean up checkpointed states when the associated interp dies. +Works with slaves, but not foreign interps. +
Can't identify non-Tcl or pre-Tk4 interpreters automagically... +
You tell me... +

+ +

+ + + diff --git a/extra/console1_1.tcl b/extra/console1_1.tcl new file mode 100644 index 0000000..78975f0 --- /dev/null +++ b/extra/console1_1.tcl @@ -0,0 +1,2209 @@ +## +## Copyright 1996-1997 Jeffrey Hobbs +## +## source standard_disclaimer.tcl +## source beer_ware.tcl +## +## Based off previous work for TkCon +## + +##------------------------------------------------------------------------ +## PROCEDURE +## console +## +## DESCRIPTION +## Implements a console mega-widget +## +## ARGUMENTS +## console +## +## OPTIONS +## (Any toplevel widget option may be used in addition to these) +## +## -blinkcolor color DEFAULT: yellow +## Specifies the background blink color for brace highlighting. +## This doubles as the highlight color for the find box. +## +## -blinkrange TCL_BOOLEAN DEFAULT: 1 +## When doing electric brace matching, specifies whether to blink +## the entire range or just the matching braces. +## +## -proccolor color DEFAULT: darkgreen +## Specifies the color to highlight recognized procs. +## +## -promptcolor color DEFAULT: brown +## Specifies the prompt color. +## +## -stdincolor color DEFAULT: black +## Specifies the color for "stdin". +## This doubles as the console foreground color. +## +## -stdoutcolor color DEFAULT: blue +## Specifies the color for "stdout". +## +## -stderrcolor color DEFAULT: red +## Specifies the color for "stderr". +## +## -blinktime delay DEFAULT: 500 +## For electric brace matching, specifies the amount of time to +## blink the background for. +## +## -cols ## DEFAULT: 80 +## Specifies the startup width of the console. +## +## -grabputs TCL_BOOLEAN DEFAULT: 1 +## Whether this console should grab the "puts" default output +## +## -lightbrace TCL_BOOLEAN DEFAULT: 1 +## Specifies whether to activate electric brace matching. +## +## -lightcmd TCL_BOOLEAN DEFAULT: 1 +## Specifies whether to highlight recognized commands. +## +## -rows ## DEFAULT: 20 +## Specifies the startup height of the console. +## +## -scrollypos left|right DEFAULT: right +## Specified position of the console scrollbar relative to the text. +## +## -showmultiple TCL_BOOLEAN DEFAULT: 1 +## For file/proc/var completion, specifies whether to display +## completions when multiple choices are possible. +## +## -showmenu TCL_BOOLEAN DEFAULT: 1 +## Specifies whether to show the menubar. +## +## -subhistory TCL_BOOLEAN DEFAULT: 1 +## Specifies whether to allow substitution in the history. +## +## RETURNS: the window pathname +## +## BINDINGS (these are the bindings for Console, used in the text widget) +## +## <> +## <> +## <> +## <> +## <>

+## +## <> +## <> +## <> +## <> +## <> +## +## <> +## <> +## <> +## <> +## <> +## <> +## +## <> +## <> +## <> +## <> +## <> +## <> +## +## METHODS +## These are the methods that the console megawidget recognizes. +## +## configure ?option? ?value option value ...? +## cget option +## Standard tk widget routines. +## +## load ?filename? +## Loads the named file into the current interpreter. +## If no file is specified, it pops up the file requester. +## +## save ?filename? +## Saves the console buffer to the named file. +## If no file is specified, it pops up the file requester. +## +## clear ?percentage? +## Clears a percentage of the console buffer (1-100). If no +## percentage is specified, the entire buffer is cleared. +## +## error +## Displays the last error in the interpreter in a dialog box. +## +## hide +## Withdraws the console from the screen +## +## history ?-newline? +## Prints out the history without numbers (basically providing a +## list of the commands you've used). +## +## show +## Deiconifies and raises the console +## +## subwidget widget +## Returns the true widget path of the specified widget. Valid +## widgets are console, scrolly, menubar. +## +## NAMESPACE & STATE +## The megawidget creates a global array with the classname, and a +## global array which is the name of each megawidget created. The latter +## array is deleted when the megawidget is destroyed. +## The procedure console and those beginning with Console are +## used. Also, when a widget is created, commands named .$widgetname +## and Console$widgetname are created. +## +## EXAMPLE USAGE: +## +## console .con -rows 24 -showmenu false +## +##------------------------------------------------------------------------ + +package require Tk + +proc megawidget {CLASS} { + upvar \#0 $CLASS class + + foreach o [array names class -*] { + foreach {name cname val} $class($o) { + if [string match -* $name] continue + option add *$CLASS.$name [uplevel \#0 [list subst $val]] widgetDefault + } + } + set class(class) $CLASS + + bind $CLASS "catch {${CLASS}_destroy %W}" + + ;proc $CLASS:eval {w method args} { + upvar \#0 $w data + set class [winfo class $w] + if [string match {} [set arg [info command ${class}_$method]]] { + set arg [info command ${class}_$method*] + } + set num [llength $arg] + if {$num==1} { + return [uplevel $arg [list $w] $args] + } elseif {$num} { + return -code error "ambiguous option \"$method\"" + } elseif {[catch {uplevel [list $data(cmd) $method] $args} err]} { + return -code error $err + } else { + return $err + } + } + + ;proc ${CLASS}_destroy w { + upvar \#0 $w data + catch { [winfo class $w]:destroy $w } + catch { rename $w {} } + catch { rename $data(cmd) {} } + catch { unset data } + } + + ;proc ${CLASS}_cget {w args} { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be \"$w cget option\"" + } + upvar \#0 $w data [winfo class $w] class + if {[info exists class($args)] && [string match -* $class($args)]} { + set args $class($args) + } + if [string match {} [set arg [array names data $args]]] { + set arg [array names data ${args}*] + } + set num [llength $arg] + if {$num==1} { + return $data($arg) + } elseif {$num} { + return -code error "ambiguous option \"$args\"" + } elseif {[catch {$data(cmd) cget $args} err]} { + return -code error $err + } else { + return $err + } + } + + ;proc ${CLASS}_configure {w args} { + upvar \#0 $w data [winfo class $w] class + + set num [llength $args] + if {$num==1} { + if {[info exists class($args)] && [string match -* $class($args)]} { + set args $class($args) + } + if [string match {} [set arg [array names data $args]]] { + set arg [array names data ${args}*] + } + set num [llength $arg] + if {$num==1} { + return [list $arg $class($arg) $data($arg)] + } elseif {$num} { + return -code error "ambiguous option \"$args\"" + } elseif {[catch {$data(cmd) config $args} err]} { + return -code error $err + } else { + return $err + } + } elseif {$num} { + for {set i 0} {$i<$num} {incr i} { + set key [lindex $args $i] + if {[info exists class($key)] && [string match -* $class($key)]} { + set key $class($key) + } + if [string match {} [set arg [array names data $key]]] { + set arg [array names data $key*] + } + set val [lindex $args [incr i]] + set len [llength $arg] + if {$len==1} { + $class(class):configure $w $arg $val + } elseif {$len} { + return -code error "ambiguous option \"$args\"" + } elseif {[catch {$data(cmd) configure $key $val} err]} { + return -code error $err + } + } + return + } else { + set conf [$data(cmd) config] + foreach i [array names data -*] { + lappend conf "$i $class($i) [list $data($i)]" + } + return [lsort $conf] + } + } + + ;proc $CLASS:configure {w key value} { + puts "$w: $key configured to [list $value]" + } + + return $CLASS +} + +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]" + } + } +} +catch {unset file name version} + +set Console(WWW) [info exists embed_args] + +array set Console { + -blinkcolor {blinkColor BlinkColor yellow} + -blinkrange {blinkRange BlinkRange 1} + -proccolor {procColor ProcColor darkgreen} + -promptcolor {promptColor PromptColor brown} + -stdincolor {stdinColor StdinColor black} + -stdoutcolor {stdoutColor StdoutColor blue} + -stderrcolor {stderrColor StderrColor red} + + -blinktime {blinkTime BlinkTime 500} + -cols {columns Columns 80} + -grabputs {grabPuts GrabPuts 0} + -lightbrace {lightBrace LightBrace 1} + -lightcmd {lightCmd LightCmd 1} + -rows {rows Rows 20} + -scrollypos {scrollYPos ScrollYPos right} + -showmultiple {showMultiple ShowMultiple 1} + -showmenu {showMenu ShowMenu 1} + -subhistory {subhistory SubHistory 1} + + active {} + version 1.2 + release {February 1997} + contact {jhobbs@cs.uoregon.edu} + docs {http://www.sunlabs.com/tcl/plugin/} + slavealias { console } + slaveprocs { alias dir dump lremove puts echo unknown tcl_unknown which } +} + +if [string compare unix $tcl_platform(platform)] { + set Console(-font) {font Font {Courier 14}} +} else { + set Console(-font) {font Font fixed} +} + +if $Console(WWW) { + set Console(-prompt) {prompt Prompt {\[history nextid\] % }} +} else { + set Console(-prompt) {prompt Prompt \ + {(\[file tail \[pwd\]\]) \[history nextid\] % }} +} + +megawidget Console + +## console - +# ARGS: w - widget pathname of the Console console +# args +# Calls: ConsoleInitUI +# Outputs: errors found in Console resource file +## +proc console {W args} { + set CLASS Console + upvar \#0 $W data $CLASS class + if {[winfo exists $W]} { + catch {eval destroy [winfo children $W]} + } else { + toplevel $W -class $CLASS + } + wm withdraw $W + wm title $W "Console $class(version)" + + ## User definable options + foreach o [array names class -*] { + if [string match -* $class($o)] continue + set data($o) [option get $W [lindex $class($o) 0] $CLASS] + } + + global auto_path tcl_pkgPath tcl_interactive + set tcl_interactive 1 + + ## Private variables + array set data { + appname {} cmdbuf {} cmdsave {} errorInfo {} + event 1 histid 0 find {} find,case 0 find,reg 0 + } + array set data [list class $CLASS cmd $CLASS$W \ + menubar $W.bar \ + console $W.text \ + scrolly $W.sy \ + ] + + rename $W $data(cmd) + if {[string comp {} $args] && \ + [catch {eval ${CLASS}_configure $W $args} err]} { + catch {destroy $W} + catch {unset data} + return -code error $err + } + ;proc $W args "eval $CLASS:eval [list $W] \$args" + + 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} + + ## Menus + frame $data(menubar) -relief raised -bd 2 + set c [text $data(console) -font $data(-font) -wrap char -setgrid 1 \ + -yscrollcomm [list $W.sy set] -foreground $data(-stdincolor) \ + -width $data(-cols) -height $data(-rows)] + bindtags $W [list $W all] + bindtags $c [list $c PreCon Console PostCon $W all] + scrollbar $data(scrolly) -takefocus 0 -bd 1 -command "$c yview" + + ConsoleInitMenus $W + + if $data(-showmenu) { pack $data(menubar) -fill x } + pack $data(scrolly) -side $data(-scrollypos) -fill y + pack $c -fill both -expand 1 + + Console:prompt $W "console display active\n" + + foreach col {prompt stdout stderr stdin proc} { + $c tag configure $col -foreground $data(-${col}color) + } + $c tag configure blink -background $data(-blinkcolor) + $c tag configure find -background $data(-blinkcolor) + + bind $c { + set W [winfo toplevel %W] + scan [wm geometry $W] "%%dx%%d" $W$-cols$ $W$-rows$ + } + wm deiconify $W + focus -force $c + + return $W +} + +;proc Console:configure { W key val } { + upvar \#0 $W data + global Console + + set truth {^(1|yes|true|on)$} + switch -- $key { + -blinkcolor { + $data(console) tag config blink -background $val + $data(console) tag config find -background $val + } + -proccolor { $data(console) tag config proc -foreground $val } + -promptcolor { $data(console) tag config prompt -foreground $val } + -stdincolor { + $data(console) tag config stdin -foreground $val + $data(console) config -foreground $val + } + -stdoutcolor { $data(console) tag config stdout -foreground $val } + -stderrcolor { $data(console) tag config stderr -foreground $val } + + -blinktime { + if ![regexp {[0-9]+} $val] { + return -code error "$key option requires an integer value" + } + } + -cols { + if [winfo exists $data(console)] { $data(console) config -width $val } + } + -font { $data(console) config -font $val } + -grabputs { + set val [regexp -nocase $truth $val] + if $val { + set Console(active) [linsert $Console(active) 0 $W] + } else { + set Console(active) [lremove -all $Console(active) $W] + } + } + -lightbrace { set val [regexp -nocase $truth $val] } + -lightcmd { set val [regexp -nocase $truth $val] } + -prompt { + if [catch {uplevel \#0 [list subst $val]} err] { + return -code error "\"$val\" threw an error:\n$err" + } + } + -rows { + if [winfo exists $data(console)] { $data(console) config -height $val } + } + -scrollypos { + if [regexp {^(left|right)$} $val junk val] { + if [winfo exists $data(scrolly)] { + pack config $data(scrolly) -side $val + } + } else { + return -code error "bad option \"$val\": must be left or right" + } + } + -showmultiple { set val [regexp -nocase $truth $val] } + -showmenu { + set val [regexp -nocase $truth $val] + if [winfo exists $data(menubar)] { + if $val { + pack $data(menubar) -fill x -before $data(console) \ + -before $data(scrolly) + } else { pack forget $data(menubar) } + } + } + -subhistory { set val [regexp -nocase $truth $val] } + } + set data($key) $val +} + +;proc Console:destroy W { + global Console + set Console(active) [lremove $Console(active) $W] +} + +## ConsoleEval - evaluates commands input into console window +## This is the first stage of the evaluating commands in the console. +## They need to be broken up into consituent commands (by ConsoleCmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## ConsoleEvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: ConsoleCmdGet, ConsoleCmdSep, ConsoleEvalCmd +## +;proc ConsoleEval {w} { + ConsoleCmdSep [ConsoleCmdGet $w] cmds cmd + $w mark set insert end-1c + $w insert end \n + if [llength $cmds] { + foreach c $cmds {ConsoleEvalCmd $w $c} + $w insert insert $cmd {} + } elseif {[info complete $cmd] && ![regexp {[^\\]\\$} $cmd]} { + ConsoleEvalCmd $w $cmd + } + $w see insert +} + +## ConsoleEvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: Console:prompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +;proc ConsoleEvalCmd {w cmd} { + ## HACK to get $W as we need it + set W [winfo parent $w] + upvar \#0 $W data + + $w mark set output end + if [string comp {} $cmd] { + set err 0 + if $data(-subhistory) { + set ev [ConsoleEvalSlave history nextid] + incr ev -1 + if {[string match !! $cmd]} { + set err [catch {ConsoleEvalSlave history event $ev} cmd] + if !$err {$w insert output $cmd\n stdin} + } elseif {[regexp {^!(.+)$} $cmd dummy event]} { + ## Check last event because history event is broken + set err [catch {ConsoleEvalSlave history event $ev} cmd] + if {!$err && ![string match ${event}* $cmd]} { + set err [catch {ConsoleEvalSlave history event $event} cmd] + } + if !$err {$w insert output $cmd\n stdin} + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { + if ![set err [catch {ConsoleEvalSlave 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 {} $data(appname)] { + if [catch {ConsoleEvalSlave eval $cmd} res] { + set data(errorInfo) [ConsoleEvalSlave set errorInfo] + set err 1 + } + } else { + if [catch [list ConsoleEvalAttached $cmd] res] { + if [catch {ConsoleEvalAttached set errorInfo} err] { + set data(errorInfo) {Error attempting to retrieve errorInfo} + } else { + set data(errorInfo) $err + } + set err 1 + } + } + ConsoleEvalSlave history add $cmd + if $err { + $w insert output $res\n stderr + } elseif {[string comp {} $res]} { + $w insert output $res\n stdout + } + } + } + Console:prompt $W + set data(event) [ConsoleEvalSlave history nextid] +} + +## ConsoleEvalSlave - 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 ConsoleEvalSlave {args} { + uplevel \#0 $args +} + +## ConsoleEvalAttached +## +;proc ConsoleEvalAttached {args} { + eval uplevel \#0 $args +} + +## ConsoleCmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +;proc ConsoleCmdGet w { + if [string match {} [$w tag nextrange prompt limit end]] { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## ConsoleCmdSep - separates multiple commands into a list and remainder +# ARGS: cmd - (possible) multiple command to separate +# list - varname for the list of commands that were separated. +# rmd - varname of any remainder (like an incomplete final command). +# If there is only one command, it's placed in this var. +# Returns: constituent command info in varnames specified by list & rmd. +## +;proc ConsoleCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if [string comp {} $tmp] { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } + } + if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] + } +} + +## Console:prompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in data(-prompt)) to console +## +;proc Console:prompt {W {pre {}} {post {}} {prompt {}}} { + upvar \#0 $W data + + set w $data(console) + if [string comp {} $pre] { $w insert end $pre stdout } + set i [$w index end-1c] + if [string comp {} $data(appname)] { + $w insert end ">$data(appname)< " prompt + } + if [string comp {} $prompt] { + $w insert end $prompt prompt + } else { + $w insert end [ConsoleEvalSlave subst $data(-prompt)] 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 +} + +## ConsoleAbout - gives about info for Console +## +;proc ConsoleAbout W { + global Console + + set w $W.about + if [winfo exists $w] { + wm deiconify $w + } else { + toplevel $w + wm title $w "About Console v$Console(version)" + button $w.b -text Dismiss -command [list wm withdraw $w] + text $w.text -height 8 -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 + $w.text tag config title -justify center -font {Courier 18 bold} + $w.text insert 1.0 "About Console v$Console(version)\n\n" title \ + "Copyright 1995-1997 Jeffrey Hobbs, $Console(contact)\ + \nhttp://www.cs.uoregon.edu/~jhobbs/\ + \nRelease Date: v$Console(version), $Console(release)\ + \nDocumentation available at:\n$Console(docs)" center + } +} + +## ConsoleInitMenus - inits the menubar and popup for the console +# ARGS: W - console +## +;proc ConsoleInitMenus {W} { + upvar \#0 $W data + + set w $data(menubar) + set text $data(console) + + 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.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.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.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.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 -disabledfore $data(-promptcolor)] \ + [menu $w.pop.con -disabledfore $data(-promptcolor)]] { + $m add command -label "Console $W" -state disabled + $m add command -label "Close Console " -un 0 \ + -acc [event info <>] -com [list destroy $W] + $m add command -label "Clear Console " -un 1 \ + -acc [event info <>] -com [list Console_clear $W] + $m add separator + $m add command -label "Quit" -un 0 -acc [event info <>] \ + -command exit + } + + ## Edit Menu + ## + foreach m [list [menu $w.edit.m] [menu $w.pop.edit]] { + $m add command -label "Cut" -un 1 \ + -acc [lindex [event info <>] 0] \ + -command [list ConsoleCut $text] + $m add command -label "Copy" -un 1 \ + -acc [lindex [event info <>] 0] \ + -command [list ConsoleCopy $text] + $m add command -label "Paste" -un 0 \ + -acc [lindex [event info <>] 0] \ + -command [list ConsolePaste $text] + $m add separator + $m add command -label "Find" -un 0 -acc [event info <>] \ + -command [list ConsoleFindBox $W] + } + + ## Prefs Menu + ## + foreach m [list [menu $w.pref.m] [menu $w.pop.pref]] { + $m add checkbutton -label "Brace Highlighting" -var $W$-lightbrace$ + $m add checkbutton -label "Command Highlighting" -var $W$-lightcmd$ + $m add checkbutton -label "History Substitution" -var $W$-subhistory$ + $m add checkbutton -label "Show Multiple Matches" -var $W$-showmultiple$ + $m add checkbutton -label "Show Menubar" -var $W$-showmenu$ \ + -command "Console:configure $W -showmenu \[set $W$-showmenu$\]" + $m add cascade -label Scrollbar -un 0 -menu $m.scroll + + ## Scrollbar Menu + ## + set m [menu $m.scroll -tearoff 0] + $m add radio -label "Left" -var $W$-scrollypos$ -value left \ + -command [list Console:configure $W -scrollypos left] + $m add radio -label "Right" -var $W$-scrollypos$ -value right \ + -command [list Console:configure $W -scrollypos right] + } + + ## History Menu + ## + foreach m [list $w.hist.m $w.pop.hist] { + menu $m -disabledfore $data(-promptcolor) \ + -postcommand [list ConsoleHistoryMenu $W $m] + } + + ## Help Menu + ## + foreach m [list [menu $w.help.m] [menu $w.pop.help]] { + $m config -disabledfore $data(-promptcolor) + $m add command -label "About " -un 0 -acc [event info <>] \ + -command [list ConsoleAbout $W] + } + + bind $W <> exit + #bind $W <> ConsoleNew + bind $W <> [list destroy $W] + bind $W <> [list ConsoleAbout $W] + bind $W <> [list ConsoleHelp $W] + bind $W <> [list ConsoleFindBox $W] + + ## Menu items need null PostCon bindings to avoid the TagProc + ## + foreach ev [bind $W] { + bind PostCon $ev { + # empty + } + } +} + +## ConsoleHistoryMenu - dynamically build the menu for attached interpreters +## +# ARGS: w - menu widget +## +;proc ConsoleHistoryMenu {W w} { + upvar \#0 $W data + + if ![winfo exists $w] return + set id [ConsoleEvalSlave history nextid] + if {$data(histid)==$id} return + set data(histid) $id + $w delete 0 end + set con $data(console) + while {($id>$data(histid)-10) && \ + ![catch {ConsoleEvalSlave 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 " + $con delete limit end + $con insert limit [list $tmp] + $con see end + ConsoleEval $con + " + } +} + +## ConsoleFindBox - creates minimal dialog interface to ConsoleFind +# ARGS: w - text widget +# str - optional seed string for data(find) +## +;proc ConsoleFindBox {W {str {}}} { + upvar \#0 $W data + + set t $data(console) + set base $W.find + if ![winfo exists $base] { + toplevel $base + wm withdraw $base + wm title $base "Console Find" + + pack [frame $base.f] -fill x -expand 1 + label $base.f.l -text "Find:" + entry $base.f.e -textvar $W$find$ + pack [frame $base.opt] -fill x + checkbutton $base.opt.c -text "Case Sensitive" -variable $W$find,case$ + checkbutton $base.opt.r -text "Use Regexp" -variable $W$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 "Console_find $W \$data(find) \ + -case \$data(find,case) -reg \$data(find,reg)" + $base.btn.clr config -command " + $t tag remove find 1.0 end + set data(find) {} + " + $base.btn.dis config -command " + $t tag remove find 1.0 end + wm withdraw $base + " + if [string comp {} $str] { + set data(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 +} + +## Console_find - searches in text widget for $str and highlights it +## If $str is empty, it just deletes any highlighting +# ARGS: W - console widget +# str - string to search for +# -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0 +# -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0 +## +;proc ConsoleFind {W str args} { + upvar \#0 $W data + set t $data(console) + $t 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 + $t mark set findmark 1.0 + while {[string comp {} [set ix [eval $t search $opts -count numc -- \ + [list $str] findmark end]]]} { + $t tag add find $ix ${ix}+${numc}c + $t mark set findmark ${ix}+1c + } + catch {$t see find.first} + return [expr [llength [$t tag ranges find]]/2] +} + +## Console:savecommand - saves a command in a buffer for later retrieval +# +## +;proc Console:savecommand {w} { + upvar \#0 [winfo parent $w] data + + set tmp $data(cmdsave) + set data(cmdsave) [ConsoleCmdGet $w] + if {[string match {} $data(cmdsave)]} { + set data(cmdsave) $tmp + } else { + $w delete limit end-1c + } + $w insert limit $tmp + $w see end +} + +## Console_load - sources a file into the console +# ARGS: fn - (optional) filename to source in +# Returns: selected filename ({} if nothing was selected) +## +;proc Console_load {W {fn {}}} { + if {[string match {} $fn] && + ([catch {tk_getOpenFile} fn] || [string match {} $fn])} return + ConsoleEvalAttached [list source $fn] +} + +## Console_save - saves the console buffer to a file +## This does not eval in a slave because it's not necessary +# ARGS: w - console text widget +# fn - (optional) filename to save to +## +;proc Console_save {W {fn {}}} { + upvar \#0 $W data + + 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 [$data(console) get 1.0 end-1c] + close $fid +} + +## clear - clears the buffer of the console (not the history though) +## +;proc Console_clear {W {pcnt 100}} { + upvar \#0 $W data + + set data(tmp) [ConsoleCmdGet $data(console)] + 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} { + $data(console) delete 1.0 end + } else { + set tmp [expr $pcnt/100.0*[$data(console) index end]] + $data(console) delete 1.0 "$tmp linestart" + } + Console:prompt $W {} $data(tmp) +} + +;proc Console_error {W} { + ## Outputs stack caused by last error. + upvar \#0 $W data + set info $data(errorInfo) + if [string match {} $info] { set info {errorInfo empty} } + catch {destroy $W.error} + set w [toplevel $W.error] + wm title $w "Console 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 $data(-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 +} + +## Console_event - searches for history based on a string +## Search forward (next) if $int>0, otherwise search back (prev) +# ARGS: W - console widget +## +;proc Console_event {W int {str {}}} { + upvar \#0 $W data + + if !$int return + set w $data(console) + + set nextid [ConsoleEvalSlave history nextid] + if [string comp {} $str] { + ## String is not empty, do an event search + set event $data(event) + if {$int < 0 && $event == $nextid} { set data(cmdbuf) $str } + set len [string len $data(cmdbuf)] + incr len -1 + if {$int > 0} { + ## Search history forward + while {$event < $nextid} { + if {[incr event] == $nextid} { + $w delete limit end + $w insert limit $data(cmdbuf) + break + } elseif {![catch {ConsoleEvalSlave history event $event} res] \ + && ![string comp $data(cmdbuf) [string range $res 0 $len]]} { + $w delete limit end + $w insert limit $res + break + } + } + set data(event) $event + } else { + ## Search history reverse + while {![catch {ConsoleEvalSlave history event [incr event -1]} res]} { + if {![string comp $data(cmdbuf) [string range $res 0 $len]]} { + $w delete limit end + $w insert limit $res + set data(event) $event + break + } + } + } + } else { + ## String is empty, just get next/prev event + if {$int > 0} { + ## Goto next command in history + if {$data(event) < $nextid} { + $w delete limit end + if {[incr data(event)] == $nextid} { + $w insert limit $data(cmdbuf) + } else { + $w insert limit [ConsoleEvalSlave history event $data(event)] + } + } + } else { + ## Goto previous command in history + if {$data(event) == $nextid} { set data(cmdbuf) [ConsoleCmdGet $w] } + if [catch {ConsoleEvalSlave history event [incr data(event) -1]} res] { + incr data(event) + } else { + $w delete limit end + $w insert limit $res + } + } + } + $w mark set insert end + $w see end +} + +;proc Console_history {W args} { + set sub {\2} + if [string match -n* $args] { append sub "\n" } + set h [ConsoleEvalSlave history] + regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h + return $h +} + +;proc Console_hide {W} { + wm withdraw $W +} + +;proc Console_show {W} { + wm deiconify $W + raise $W +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## puts +## This allows me to capture all stdout/stderr to the console window +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +if ![catch {rename puts tcl_puts}] { + ;proc puts args { + global Console + set w [lindex $Console(active) 0].text + if {[llength $Console(active)] && [winfo exists $w]} { + set len [llength $args] + if {$len==1} { + eval $w insert output $args stdout {\n} stdout + $w see output + } elseif {$len==2 && \ + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if [string comp $tmp -nonewline] { + eval $w insert output [lreplace $args 0 0] $tmp {\n} $tmp + } else { + eval $w insert output [lreplace $args 0 0] stdout + } + $w see output + } elseif {$len==3 && \ + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if [string comp [lreplace $args 1 2] -nonewline] { + eval $w insert output [lrange $args 1 1] $tmp + } else { + eval $w insert output [lreplace $args 0 1] $tmp + } + $w 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 + } + if $len update + } 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 + } + } +} + +## echo +## Relaxes the one string restriction of 'puts' +# ARGS: any number of strings to output to stdout +## +proc echo args { puts [concat $args] } + +## alias - akin to the csh alias command +## If called with no args, then it dumps out all current aliases +## If called with one arg, returns the alias of that arg (or {} if none) +# ARGS: newcmd - (optional) command to bind alias to +# args - command and args being aliased +## +proc alias {{newcmd {}} args} { + if [string match {} $newcmd] { + set res {} + foreach a [interp aliases] { + lappend res [list $a -> [interp alias {} $a]] + } + return [join $res \n] + } elseif {[string match {} $args]} { + interp alias {} $newcmd + } else { + eval interp alias [list {} $newcmd {}] $args + } +} + +## dump - outputs variables/procedure/widget info in source'able form. +## Accepts glob style pattern matching for the names +# ARGS: type - type of thing to dump: must be variable, procedure, widget +# OPTS: -nocomplain +# don't complain if no vars match something +# -filter pattern +# specifies a glob filter pattern to be used by the variable +# method as an array filter pattern (it filters down for +# nested elements) and in the widget method as a config +# option filter pattern +# -- forcibly ends options recognition +# 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]]" + } + } + 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" + } + } + return -code $code [string trimr $res \n] +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + if {[string comp {} [info commands $cmd]] || + ([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" + } +} + +## dir - directory list +# ARGS: args - names/glob patterns of directories to list +# OPTS: -all - list hidden files as well (Unix dot files) +# -long - list in full format "permissions size date filename" +# -full - displays / after directories and link paths for links +# 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 - + } 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 + } + } 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 Console console widget + set j [expr 64/$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 + +## lremove - remove items from a list +# OPTS: -all remove all instances of each item +# ARGS: l a list to remove items from +# 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 l [lreplace $l $ix $ix] + } + } + } + return $l +} + +## Unknown changed to get output into Console 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: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc tcl_unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive Console + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if {[array size unknown_pending] == 0} { + unset unknown_pending + } + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if $ret { + 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 + ## + ## History substitution moved into ConsoleEvalCmd + ## + 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]" + } + } + } + return -code continue +} + +switch -glob $tcl_platform(platform) { + win* { set META Alt } + mac* { set META Command } + default { set META Meta } +} + +# ConsoleClipboardKeysyms -- +# 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 ConsoleClipboardKeysyms {copy cut paste} { + bind Console <$copy> {ConsoleCopy %W} + bind Console <$cut> {ConsoleCut %W} + bind Console <$paste> {ConsolePaste %W} +} + +;proc ConsoleCut 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 ConsoleCopy w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch {clipboard append -displayof $w [selection get -displayof $w]} + } +} + +;proc ConsolePaste 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] {ConsoleEval $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] +} + +foreach {ev key} { + <> + <> + <> + <> + <> + <> + + <> + <> + <> + <> + <> + <> + + <> + <> + <> + <> + <> + + <> + <> + <> + <> + <> + <> +} { + event add $ev $key + bind Console $key {} +} +catch {unset ev key} + +## Redefine for Console what we need +## +event delete <> +ConsoleClipboardKeysyms + +bind Console {catch {ConsoleInsert %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 Console <> { + if [%W compare insert > limit] {Console:expand %W path} + break +} +bind Console <> { + if [%W compare insert > limit] {Console:expand %W proc} +} +bind Console <> { + if [%W compare insert > limit] {Console:expand %W var} +} +bind Console <> { + if [%W compare insert >= limit] { + ConsoleInsert %W \t + } +} +bind Console <> { + ConsoleEval %W +} +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 { + ConsoleInsert %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 <> { + Console_clear [winfo parent %W] +} +bind Console <> { + if [%W compare {insert linestart} != {limit linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W -1] + } else { + Console_event [winfo parent %W] -1 + } +} +bind Console <> { + if [%W compare {insert linestart} != {end-1c linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W 1] + } else { + Console_event [winfo parent %W] 1 + } +} +bind Console <> { + Console_event [winfo parent %W] 1 +} +bind Console <> { + Console_event [winfo parent %W] -1 +} +bind Console <> { + Console_event [winfo parent %W] -1 [ConsoleCmdGet %W] +} +bind Console <> { + Console_event [winfo parent %W] 1 [ConsoleCmdGet %W] +} +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) + Console:savecommand %W +} +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 <$META-d> { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } +} +bind Console <$META-BackSpace> { + if [%W compare {insert -1c wordstart} >= limit] { + %W delete {insert -1c wordstart} insert + } +} +bind Console <$META-Delete> { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } +} +bind Console { + if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \ + && ![catch {selection get -displayof %W} tkPriv(junk)]} { + if [%W compare @%x,%y < limit] { + %W insert end $tkPriv(junk) + } else { + %W insert @%x,%y $tkPriv(junk) + } + if [string match *\n* $tkPriv(junk)] {ConsoleEval %W} + } +} + +## +## End Console bindings +## + +## +## Bindings for doing special things based on certain keys +## +bind PostCon { + if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W  limit } +} +bind PostCon { + if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \[ \] limit } +} +bind PostCon { + if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \{ \} limit } +} +bind PostCon { + if [string comp \\ [%W get insert-2c]] { ConsoleMatchQuote %W limit } +} + +bind PostCon { + if [string comp {} %A] { ConsoleTagProc %W } +} + + +## ConsoleTagProc - tags a procedure in the console if it's recognized +## This procedure is not perfect. However, making it perfect wastes +## too much CPU time... Also it should check the existence of a command +## in whatever is the connected slave, not the master interpreter. +## +;proc ConsoleTagProc w { + upvar \#0 [winfo parent $w] data + if !$data(-lightcmd) return + set i [$w index "insert-1c wordstart"] + set j [$w index "insert-1c wordend"] + if {[string comp {} \ + [ConsoleEvalAttached info command [list [$w get $i $j]]]]} { + $w tag add proc $i $j + } else { + $w tag remove proc $i $j + } +} + +## ConsoleMatchPair - blinks a matching pair of characters +## c2 is assumed to be at the text index 'insert'. +## This proc is really loopy and took me an hour to figure out given +## all possible combinations with escaping except for escaped \'s. +## It doesn't take into account possible commenting... Oh well. If +## anyone has something better, I'd like to see/use it. This is really +## only efficient for small contexts. +# ARGS: w - console text widget +# c1 - first char of pair +# c2 - second char of pair +# Calls: Console:blink +## +;proc ConsoleMatchPair {w c1 c2 {lim 1.0}} { + upvar \#0 [winfo parent $w] data + if {!$data(-lightbrace) || $data(-blinktime)<100} return + 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 + } + } + if [string match {} $ix] { set ix [$w index $lim] } + } else { set ix [$w index $lim] } + if $data(-blinkrange) { + Console:blink $w $data(-blinktime) $ix [$w index insert] + } else { + Console:blink $w $data(-blinktime) $ix $ix+1c \ + [$w index insert-1c] [$w index insert] + } +} + +## ConsoleMatchQuote - blinks between matching quotes. +## Blinks just the quote if it's unmatched, otherwise blinks quoted string +## The quote to match is assumed to be at the text index 'insert'. +# ARGS: w - console text widget +# Calls: Console:blink +## +;proc ConsoleMatchQuote {w {lim 1.0}} { + upvar \#0 [winfo parent $w] data + if {!$data(-lightbrace) || $data(-blinktime)<100} return + 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] { + if $data(-blinkrange) { + Console:blink $w $data(-blinktime) $i0 [$w index insert] + } else { + Console:blink $w $data(-blinktime) $i0 $i0+1c \ + [$w index insert-1c] [$w index insert] + } + } else { + Console:blink $w $data(-blinktime) [$w index insert-1c] [$w index insert] + } +} + +## Console:blink - blinks between 2 indices for a specified duration. +# ARGS: w - console text widget +# delay - millisecs to blink for +# args - indices of regions to blink +# Outputs: blinks selected characters in $w +## +;proc Console:blink {w delay args} { + eval $w tag add blink $args + after $delay eval $w tag remove blink $args + return +} + + +## ConsoleInsert +## Insert a string into a text console at the point of the insertion cursor. +## If there is a selection in the text, and it covers the point of the +## insertion cursor, then delete the selection before inserting. +# ARGS: w - text window in which to insert the string +# s - string to insert (usually just a single char) +# Outputs: $s to text widget +## +;proc ConsoleInsert {w s} { + if {[string match {} $s] || [string match disabled [$w cget -state]]} { + return + } + if [$w comp insert < limit] { + $w mark set insert end + } + catch { + if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert +} + +## Console:expand - +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# Calls: ConsoleExpand(Pathname|Procname|Variable) +# Outputs: The string to match is expanded to the longest possible match. +# If data(-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 Console:expand {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 [ConsoleExpandPathname $str] } + pr* { set res [ConsoleExpandProcname $str] } + v* { set res [ConsoleExpandVariable $str] } + default {set res {}} + } + set len [llength $res] + if $len { + $w delete $tmp insert + $w insert $tmp [lindex $res 0] + if {$len > 1} { + upvar \#0 [winfo parent $w] data + if {$data(-showmultiple) && ![string comp [lindex $res 0] $str]} { + puts stdout [lreplace $res 0 0] + } + } + } else bell + return [incr len -1] +} + +## ConsoleExpandPathname - expand a file pathname based on $str +## This is based on UNIX file name conventions +# ARGS: str - partial file pathname to expand +# Calls: ConsoleExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +;proc ConsoleExpandPathname str { + set pwd [ConsoleEvalAttached pwd] + if [catch {ConsoleEvalAttached [list cd [file dirname $str]]} err] { + return -code error $err + } + if [catch {lsort [ConsoleEvalAttached glob [file tail $str]*]} m] { + set match {} + } else { + if {[llength $m] > 1} { + set tmp [ConsoleExpandBestMatch $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] + } + } + ConsoleEvalAttached [list cd $pwd] + return $match +} + +## ConsoleExpandProcname - expand a tcl proc name based on $str +# ARGS: str - partial proc name to expand +# Calls: ConsoleExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +;proc ConsoleExpandProcname str { + set match [ConsoleEvalAttached info commands $str*] + if {[llength $match] > 1} { + regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + return $match +} + +## ConsoleExpandVariable - expand a tcl variable name based on $str +# ARGS: str - partial tcl var name to expand +# Calls: ConsoleExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +;proc ConsoleExpandVariable str { + if [regexp {([^$]*)\((.*)} $str junk ary str] { + ## Looks like they're trying to expand an array. + set match [ConsoleEvalAttached array names $ary $str*] + if {[llength $match] > 1} { + set vars $ary\([ConsoleExpandBestMatch $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 [ConsoleEvalAttached info vars $str*] + if {[llength $match] > 1} { + regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + } + return $match +} + +## ConsoleExpandBestMatch2 - finds the best unique match in a list of names +## Improves upon the speed of the below proc only when $l is small +## or $e is {}. $e is extra for compatibility with proc below. +# ARGS: l - list to find best unique match in +# Returns: longest unique match in the list +## +;proc ConsoleExpandBestMatch2 {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 +} + +## ConsoleExpandBestMatch - finds the best unique match in a list of names +## The extra $e in this argument allows us to limit the innermost loop a +## little further. This improves speed as $l becomes large or $e becomes long. +# ARGS: l - list to find best unique match in +# e - currently best known unique match +# Returns: longest unique match in the list +## +;proc ConsoleExpandBestMatch {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 +} + + +## ConsoleResource - 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 Console(SCRIPT) [info script] +if !$Console(WWW) { + while {[string match link [file type $Console(SCRIPT)]]} { + set link [file readlink $Console(SCRIPT)] + if [string match relative [file pathtype $link]] { + set Console(SCRIPT) [file join [file dirname $Console(SCRIPT)] $link] + } else { + set Console(SCRIPT) $link + } + } + catch {unset link} + if [string match relative [file pathtype $Console(SCRIPT)]] { + set Console(SCRIPT) [file join [pwd] $Console(SCRIPT)] + } +} + +;proc Console:resource {} { + global Console + uplevel \#0 [list source $Console(SCRIPT)] +} + +catch {destroy .c} +console .c +wm iconify .c +wm title .c "Tcl Plugin Console" +wm geometry .c +10+10 diff --git a/extra/stripped.tcl b/extra/stripped.tcl new file mode 100755 index 0000000..64ef1f5 --- /dev/null +++ b/extra/stripped.tcl @@ -0,0 +1,1083 @@ +#!/bin/sh +# \ +exec wish4.1 "$0" ${1+"$@"} + +# +## stripped.tcl +## Stripped down version of Tk Console Widget, part of the VerTcl system +## Stripped to work with Netscape Tk Plugin. +## +## Copyright (c) 1995,1996 by Jeffrey Hobbs +## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/ +## source standard_disclaimer.tcl + +if {[info tclversion] < 7.5} { + error "TkCon requires at least the stable version of tcl7.5/tk4.1" +} + +## tkConInit - inits tkCon +# ARGS: root - widget pathname of the tkCon console root +# title - title for the console root and main (.) windows +# Calls: tkConInitUI +# Outputs: errors found in tkCon resource file +## +proc tkConInit {{title Main}} { + global tkCon tcl_platform env auto_path tcl_interactive + + set tcl_interactive 1 + + array set tkCon { + color,blink yellow + color,proc darkgreen + color,prompt brown + color,stdin black + color,stdout blue + color,stderr red + + blinktime 500 + font fixed + lightbrace 1 + lightcmd 1 + prompt1 {[history nextid] % } + prompt2 {[history nextid] cont > } + showmultiple 1 + slavescript {} + + cmd {} cmdbuf {} cmdsave {} event 1 svnt 1 cols 80 rows 24 + + version {0.5x Stripped} + base .console + } + + if [string comp $tcl_platform(platform) unix] { + array set tkCon { + font {Courier 12 {}} + } + } + + tkConInitUI $title + + interp alias {} clean {} tkConStateRevert tkCon + tkConStateCheckpoint tkCon +} + +## tkConInitUI - inits UI portion (console) of tkCon +## Creates all elements of the console window and sets up the text tags +# ARGS: title - title for the console root and main (.) windows +# Calls: tkConInitMenus, tkConPrompt +## +proc tkConInitUI {title} { + global tkCon + + set root $tkCon(base) + if [string match $root .] { set w {} } else { set w [frame $root] } + + set tkCon(console) [text $w.text -font $tkCon(font) -wrap char \ + -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin)] + bindtags $w.text "$w.text PreCon Console PostCon $root all" + set tkCon(scrolly) [scrollbar $w.sy \ + -command "$w.text yview" -takefocus 0 -bd 1] + + pack $w.sy -side left -fill y + set tkCon(scrollypos) left + pack $w.text -fill both -expand 1 + + $w.text insert insert "$title console display active\n" stdout + tkConPrompt $w.text + + foreach col {prompt stdout stderr stdin proc} { + $w.text tag configure $col -foreground $tkCon(color,$col) + } + $w.text tag configure blink -background $tkCon(color,blink) + + pack $root -fill both -expand 1 + focus $w.text +} + +## tkConEval - evaluates commands input into console window +## This is the first stage of the evaluating commands in the console. +## They need to be broken up into consituent commands (by tkConCmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd +## +proc tkConEval {w} { + global tkCon + tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd) + $w mark set insert end-1c + $w insert end \n + if [llength $cmds] { + foreach cmd $cmds {tkConEvalCmd $w $cmd} + $w insert insert $tkCon(cmd) {} + } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} { + tkConEvalCmd $w $tkCon(cmd) + } + $w see insert +} + +## tkConEvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: tkConPrompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +proc tkConEvalCmd {w cmd} { + global tkCon + $w mark set output end + if [catch {uplevel \#0 history add [list $cmd] exec} result] { + $w insert output $result\n stderr + } elseif [string comp {} $result] { + $w insert output $result\n stdout + } + tkConPrompt $w + set tkCon(svnt) [set tkCon(event) [history nextid]] +} + +## tkConCmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +proc tkConCmdGet w { + if [string match {} [set ix [$w tag nextrange prompt limit end]]] { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## tkConCmdSep - separates multiple commands into a list and remainder +# ARGS: cmd - (possible) multiple command to separate +# list - varname for the list of commands that were separated. +# rmd - varname of any remainder (like an incomplete final command). +# If there is only one command, it's placed in this var. +# Returns: constituent command info in varnames specified by list & rmd. +## +proc tkConCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if [string comp {} $tmp] { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } + } + if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] + } +} + +## tkConPrompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in tkCon(prompt1)) to console +## +proc tkConPrompt w { + global tkCon env + set i [$w index end-1c] + $w insert end [subst $tkCon(prompt1)] prompt + $w mark set output $i + $w mark set limit insert + $w mark gravity limit left +} + +## tkConStateCheckpoint - checkpoints the current state of the system +## This allows you to return to this state with tkConStateRevert +# ARGS: ary an array into which several elements are stored: +# commands - the currently defined commands +# variables - the current global vars +# This is the array you would pass to tkConRevertState +## +proc tkConStateCheckpoint {ary} { + global tkCon + upvar $ary a + set a(commands) [uplevel \#0 info commands *] + set a(variables) [uplevel \#0 info vars *] + return +} + +## tkConStateCompare - compare two states and output difference +# ARGS: ary1 an array with checkpointed state +# ary2 a second array with checkpointed state +# Outputs: +## +proc tkConStateCompare {ary1 ary2} { + upvar $ary1 a1 $ary2 a2 + puts "Commands unique to $ary1:\n[lremove $a1(commands) $a2(commands)]" + puts "Commands unique to $ary2:\n[lremove $a2(commands) $a1(commands)]" + puts "Variables unique to $ary1:\n[lremove $a1(variables) $a2(variables)]" + puts "Variables unique to $ary2:\n[lremove $a2(variables) $a1(variables)]" +} + +## tkConStateRevert - reverts interpreter to a previous state +# ARGS: ary an array with checkpointed state +## +proc tkConStateRevert {ary} { + upvar $ary a + tkConStateCheckpoint tmp + foreach i [lremove $tmp(commands) $a(commands)] { catch "rename $i {}" } + foreach i [lremove $tmp(variables) $a(variables)] { uplevel \#0 unset $i } +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## puts +## This allows me to capture all stdout/stderr to the console window +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +catch {rename puts tcl_puts} +proc puts args { + set len [llength $args] + if {$len==1} { + eval tkcon console insert output $args stdout {\n} stdout + tkcon console see output + } elseif {$len==2 && + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if [string comp $tmp -nonewline] { + eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp + } else { + eval tkcon console insert output [lreplace $args 0 0] stdout + } + tkcon console see output + } elseif {$len==3 && + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if [string comp [lreplace $args 1 2] -nonewline] { + eval tkcon console insert output [lrange $args 1 1] $tmp + } else { + eval tkcon console insert output [lreplace $args 0 1] $tmp + } + tkcon console see output + } else { + eval tcl_puts $args + } +} + +## alias - akin to the csh alias command +## If called with no args, then it prints out all current aliases +## If called with one arg, returns the alias of that arg (or {} if none) +# ARGS: newcmd - (optional) command to bind alias to +# args - command and args being aliased +## +proc alias {{newcmd {}} args} { + if [string match $newcmd {}] { + set res {} + foreach a [interp aliases] { + lappend res [list $a: [interp alias {} $a]] + } + return [join $res \n] + } elseif {[string match {} $args]} { + interp alias {} $newcmd + } else { + eval interp alias {{}} $newcmd {{}} $args + } +} + +## unalias - unaliases an alias'ed command +# ARGS: cmd - command to unbind as an alias +## +proc unalias {cmd} { + interp alias {} $cmd {} +} + +## tkcon - command that allows control over the console +# ARGS: totally variable, see internal comments +## +proc tkcon {args} { + global tkCon + switch -- [lindex $args 0] { + clean { + ## 'cleans' the interpreter - reverting to original tkCon state + tkConStateRevert tkCon + } + console { + ## Passes the args to the text widget of the console. + eval $tkCon(console) [lreplace $args 0 0] + } + font { + ## "tkcon font ?fontname?". Sets the font of the console + if [string comp {} [lindex $args 1]] { + return [$tkCon(console) config -font [lindex $args 1]] + } else { + return [$tkCon(console) config -font] + } + } + version { + return $tkCon(version) + } + default { + ## tries to determine if the command exists, otherwise throws error + set cmd [lindex $args 0] + set cmd tkCon[string toup [string index $cmd 0]][string range $cmd 1 end] + if [string match $cmd [info command $cmd]] { + eval $cmd [lreplace $args 0 0] + } else { + error "bad option \"[lindex $args 0]\": must be attach,\ + clean, console, font" + } + } + } +} + +## clear - clears the buffer of the console (not the history though) +## This is executed in the parent interpreter +## +proc clear {{pcnt 100}} { + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + error "invalid percentage to clear: must be 1-100 (100 default)" + } elseif {$pcnt == 100} { + tkcon console delete 1.0 end + } else { + set tmp [expr $pcnt/100.0*[tkcon console index end]] + tkcon console delete 1.0 "$tmp linestart" + } +} + +## dump - outputs variables/procedure/widget info in source'able form. +## Accepts glob style pattern matching for the names +# ARGS: type - type of thing to dump: must be variable, procedure, widget +# OPTS: -nocomplain don't complain if no vars match something +# Returns: the values of the variables in a 'source'able form +## +proc dump {type args} { + set whine 1 + set code ok + if [string match \-n* [lindex $args 0]] { + set whine 0 + set args [lreplace $args 0 0] + } + if {$whine && [string match {} $args]} { + error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?" + } + set res {} + switch -glob -- $type { + v* { + # variable + # outputs variables value(s), whether array or simple. + foreach arg $args { + if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { + if {[uplevel info exists $arg]} { + set vars $arg + } elseif $whine { + append res "\#\# No known variable $arg\n" + set code error + continue + } else continue + } + foreach var [lsort $vars] { + upvar $var v + if {[array exists v]} { + append res "array set $var \{\n" + foreach i [lsort [array names v]] { + upvar 0 v$$i$ w + if {[array exists w]} { + append res " [list $i {NESTED VAR ERROR}]\n" + if $whine { set code error } + } else { + append res " [list $i $v($i)]\n" + } + } + append res "\}\n" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if {[string comp {} [set ps [info proc $arg]]]} { + foreach p [lsort $ps] { + set as {} + foreach a [info args $p] { + if {[info default $p $a tmp]} { + lappend as [list $a $tmp] + } else { + lappend as $a + } + } + append res [list proc $p $as [info body $p]]\n + } + } elseif $whine { + append res "\#\# No known proc $arg\n" + } + } + } + w* { + # widget + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"[lindex $args 0]\":\ must be procedure, variable, widget" + } + } + return -code $code [string trimr $res \n] +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + if [string comp {} [info commands $cmd]] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + return "$cmd:\taliased to [alias $cmd]" + } elseif [string comp {} [info procs $cmd]] { + return "$cmd:\tinternal proc" + } else { + return "$cmd:\tinternal command" + } + } else { + return "$cmd:\tunknown command" + } +} + +## lremove - remove items from a list +# OPTS: -all remove all instances of each item +# ARGS: l a list to remove items from +# is a list of items to remove +## +proc lremove {args} { + set all 0 + if [string match \-a* [lindex $args 0]] { + set all 1 + set args [lreplace $args 0 0] + } + set l [lindex $args 0] + eval append is [lreplace $args 0 0] + foreach i $is { + if {[set ix [lsearch -exact $l $i]] == -1} continue + set l [lreplace $l $ix $ix] + if $all { + while {[set ix [lsearch -exact $l $i]] != -1} { + set l [lreplace $l $i $i] + } + } + } + return $l +} + + +## Unknown changed to get output into tkCon window +## See $tcl_library/init.tcl for an explanation +## +proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if {[array size unknown_pending] == 0} { + unset unknown_pending + } + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {[info level] == 1 && [string match {} [info script]] \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + if [auto_execok $name] { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec $args] + #return [uplevel exec >&@stdout <@stdin $args] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + if {[string match $name !!]} { + catch {set tkCon(cmd) [history event]} + return [uplevel {history redo}] + } elseif [regexp {^!(.+)$} $name dummy event] { + catch {set tkCon(cmd) [history event $event]} + return [uplevel [list history redo $event]] + } elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] { + catch {set tkCon(cmd) [history substitute $old $new]} + return [uplevel [list history substitute $old $new]] + } + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } elseif {[llength $cmds]} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code error "invalid command name \"$name\"" +} + + +# tkConClipboardKeysyms -- +# This procedure is invoked to identify the keys that correspond to +# the "copy", "cut", and "paste" functions for the clipboard. +# +# Arguments: +# copy - Name of the key (keysym name plus modifiers, if any, +# such as "Meta-y") used for the copy operation. +# cut - Name of the key used for the cut operation. +# paste - Name of the key used for the paste operation. + +proc tkConCut w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch { + clipboard append -displayof $w [selection get -displayof $w] + if [$w compare sel.first >= limit] {$w delete sel.first sel.last} + } + } +} +proc tkConCopy w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch {clipboard append -displayof $w [selection get -displayof $w]} + } +} + +proc tkConPaste w { + if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] { + if [$w compare insert < limit] {$w mark set insert end} + $w insert insert $tmp + $w see insert + if [string match *\n* $tmp] {tkConEval $w} + } +} + +proc tkConClipboardKeysyms {copy cut paste} { + bind Console <$copy> {tkConCopy %W} + bind Console <$cut> {tkConCut %W} + bind Console <$paste> {tkConPaste %W} +} + +## Get all Text bindings into Console +## +foreach ev [lremove [bind Text] {

\ +

}] { + bind Console $ev [bind Text $ev] +} +unset ev + +## Redefine for Console what we need +## +tkConClipboardKeysyms F16 F20 F18 +tkConClipboardKeysyms Control-c Control-x Control-v + +bind Console {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) == [history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] { + incr tkCon(event) + } else { + %W delete limit end + %W insert limit $tkCon(tmp) + %W see end + } + } +} +bind Console { + if [%W compare {insert linestart} != {end-1c linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W 1] + } else { + if {$tkCon(event) < [history nextid]} { + %W delete limit end + if {[incr tkCon(event)] == [history nextid]} { + %W insert limit $tkCon(cmdbuf) + } else { + %W insert limit [history event $tkCon(event)] + } + %W see end + } + } +} +bind Console { + 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 { + 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-1c >= 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 + tkConInsert %W $tkCon(tmp) +} +bind Console { + ## Goto next command in history + if {$tkCon(event) < [history nextid]} { + %W delete limit end + if {[incr tkCon(event)] == [history nextid]} { + %W insert limit $tkCon(cmdbuf) + } else { + %W insert limit [history event $tkCon(event)] + } + %W see end + } +} +bind Console { + ## Goto previous command in history + if {$tkCon(event) == [history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] { + incr tkCon(event) + } else { + %W delete limit end + %W insert limit $tkCon(tmp) + %W see end + } +} +bind Console { + ## Search history reverse + if {$tkCon(svnt) == [history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + set tkCon(tmp1) [string len $tkCon(cmdbuf)] + incr tkCon(tmp1) -1 + while 1 { + if {[catch {history event [incr tkCon(svnt) -1]} tkCon(tmp)]} { + incr tkCon(svnt) + break + } elseif {![string comp $tkCon(cmdbuf) \ + [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { + %W delete limit end + %W insert limit $tkCon(tmp) + break + } + } + %W see end +} +bind Console { + ## Search history forward + set tkCon(tmp1) [string len $tkCon(cmdbuf)] + incr tkCon(tmp1) -1 + while {$tkCon(svnt) < [history nextid]} { + if {[incr tkCon(svnt)] == [history nextid]} { + %W delete limit end + %W insert limit $tkCon(cmdbuf) + break + } elseif {![catch {history event $tkCon(svnt)} tkCon(tmp)] + && ![string comp $tkCon(cmdbuf) \ + [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { + %W delete limit end + %W insert limit $tkCon(tmp) + break + } + } + %W see end +} +bind Console { + ## 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 + } + 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 { + if [%W compare {insert -1c wordstart} >= limit] { + %W delete {insert -1c wordstart} insert + } +} +bind Console { + 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 weird bindings +## + +## +## PostCon 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  + } +} +bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \[ \] + } +} +bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \{ \} + } +} +bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchQuote %W + } +} + +bind PostCon { + if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W } +} + +## tkConTagProc - tags a procedure in the console if it's recognized +## This procedure is not perfect. However, making it perfect wastes +## too much CPU time... Also it should check the existence of a command +## in whatever is the connected slave, not the master interpreter. +## +proc tkConTagProc w { + set i [$w index "insert-1c wordstart"] + set j [$w index "insert-1c wordend"] + if {[string comp {} [info command [list [$w get $i $j]]]]} { + $w tag add proc $i $j + } else { + $w tag remove proc $i $j + } +} + + +## tkConMatchPair - blinks a matching pair of characters +## c2 is assumed to be at the text index 'insert'. +## This proc is really loopy and took me an hour to figure out given +## all possible combinations with escaping except for escaped \'s. +## It doesn't take into account possible commenting... Oh well. If +## anyone has something better, I'd like to see/use it. This is really +## only efficient for small contexts. +# ARGS: w - console text widget +# c1 - first char of pair +# c2 - second char of pair +# Calls: tkConBlink +## +proc tkConMatchPair {w c1 c2} { + if [string comp {} [set ix [$w search -back $c1 insert limit]]] { + while {[string match {\\} [$w get $ix-1c]] && + [string comp {} [set ix [$w search -back $c1 $ix-1c limit]]]} {} + set i1 insert-1c + while {[string comp {} $ix]} { + set i0 $ix + set j 0 + while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} { + append i0 +1c + if {[string match {\\} [$w get $i0-2c]]} continue + incr j + } + if {!$j} break + set i1 $ix + while {$j && + [string comp {} [set ix [$w search -back $c1 $ix limit]]]} { + if {[string match {\\} [$w get $ix-1c]]} continue + incr j -1 + } + } + if [string match {} $ix] { set ix [$w index limit] } + } else { set ix [$w index limit] } + tkConBlink $w $ix [$w index insert] +} + +## tkConMatchQuote - blinks between matching quotes. +## Blinks just the quote if it's unmatched, otherwise blinks quoted string +## The quote to match is assumed to be at the text index 'insert'. +# ARGS: w - console text widget +# Calls: tkConBlink +## +proc tkConMatchQuote w { + set i insert-1c + set j 0 + while {[string comp {} [set i [$w search -back \" $i limit]]]} { + if {[string match {\\} [$w get $i-1c]]} continue + if {!$j} {set i0 $i} + incr j + } + if [expr $j%2] { + tkConBlink $w $i0 [$w index insert] + } else { + tkConBlink $w [$w index insert-1c] [$w index insert] + } +} + +## tkConBlink - blinks between 2 indices for a specified duration. +# ARGS: w - console text widget +# i1 - start index to blink region +# i2 - end index of blink region +# dur - duration in usecs to blink for +# Outputs: blinks selected characters in $w +## +proc tkConBlink {w i1 i2} { + global tkCon + $w tag add blink $i1 $i2 + after $tkCon(blinktime) $w tag remove blink $i1 $i2 + return +} + + +## tkConInsert +## Insert a string into a text at the point of the insertion cursor. +## If there is a selection in the text, and it covers the point of the +## insertion cursor, then delete the selection before inserting. +# ARGS: w - text window in which to insert the string +# s - string to insert (usually just a single char) +# Outputs: $s to text widget +## +proc tkConInsert {w s} { + if {[string match {} $s] || [string match disabled [$w cget -state]]} { + return + } + if [$w comp insert < limit] { + $w mark set insert end + } + catch { + if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert +} + +## tkConExpand - +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# Calls: tkConExpand(Pathname|Procname|Variable) +# Outputs: The string to match is expanded to the longest possible match. +# If tkCon(showmultiple) is non-zero and the user longest match +# equaled the string to expand, then all possible matches are +# output to stdout. Triggers bell if no matches are found. +# Returns: number of matches found +## +proc tkConExpand {w type} { + set exp "\[^\\]\[ \t\n\r\[\{\"\$]" + set tmp [$w search -back -regexp $exp insert-1c limit-1c] + if [string compare {} $tmp] {append tmp +2c} else {set tmp limit} + if [$w compare $tmp >= insert] return + set str [$w get $tmp insert] + switch -glob $type { + pr* {set res [tkConExpandProcname $str]} + v* {set res [tkConExpandVariable $str]} + default {set res {}} + } + set len [llength $res] + if $len { + $w delete $tmp insert + $w insert $tmp [lindex $res 0] + if {$len > 1} { + global tkCon + if {$tkCon(showmultiple) && [string match [lindex $res 0] $str]} { + puts stdout [lreplace $res 0 0] + } + } + } + return [incr len -1] +} + +## tkConExpandProcname - expand a tcl proc name based on $str +# ARGS: str - partial proc name to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandProcname str { + set match [info commands $str*] + if {[llength $match] > 1} { + regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + return $match +} + +## tkConExpandVariable - expand a tcl variable name based on $str +# ARGS: str - partial tcl var name to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandVariable str { + if [regexp {([^$]*)\((.*)} $str junk ary str] { + set match [uplevel \#0 array names $ary $str*] + if {[llength $match] > 1} { + set vars $ary\([tkConExpandBestMatch $match $str] + foreach var $match {lappend vars $ary\($var$} + return $vars + } else {set match $ary$$match$} + } else { + set match [uplevel \#0 info vars $str*] + if {[llength $match] > 1} { + regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + } + return $match +} + +## tkConExpandBestMatch - finds the best unique match in a list of names +## The extra $e in this argument allows us to limit the innermost loop a +## little further. This improves speed as $l becomes large or $e becomes long. +# ARGS: l - list to find best unique match in +# e - currently best known unique match +# Returns: longest unique match in the list +## +proc tkConExpandBestMatch {l {e {}}} { + set ec [lindex $l 0] + if {[llength $l]>1} { + set e [string length $e]; incr e -1 + set ei [string length $ec]; incr ei -1 + foreach l $l { + while {$ei>=$e && [string first $ec $l]} { + set ec [string range $ec 0 [incr ei -1]] + } + } + } + return $ec +} + + +## Initialize only if we haven't yet +## +if [catch {winfo exists $tkCon(base)}] tkConInit diff --git a/tkcon.tcl b/tkcon.tcl new file mode 100755 index 0000000..53091e7 --- /dev/null +++ b/tkcon.tcl @@ -0,0 +1,2141 @@ +#!/bin/sh +# The wish executable needs to be Tk4.1+ \ +exec wish "$0" ${1+"$@"} + +# +## tkcon.tcl +## Tk Console Widget, part of the VerTcl system +## +## Based (loosely) off Brent Welch's Tcl Shell Widget +## +## Thanks especially to the following for bug reports & code ideas: +## Steven Wahl +## Jan Nijtmans +## Crimmins < @umich.edu somewhere > +## +## Copyright 1995,1996 Jeffrey Hobbs. All rights reserved. +## Initiated: Thu Aug 17 15:36:47 PDT 1995 +## +## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/ +## +## source standard_disclaimer.tcl + +if [catch {package require Tk 4.1}] { + 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 +# Calls: tkConInitUI +# Outputs: errors found in tkCon resource file +## +proc tkConInit {} { + global tkCon tcl_interactive tcl_platform env auto_path argv0 argc argv + + 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 + font fixed + history 32 + library {} + lightbrace 1 + lightcmd 0 + loadTk 0 + maineval {} + nontcl 0 + prompt1 {([file tail [pwd]]) [history nextid] % } + prompt2 {[history nextid] cont > } + rcfile .tkconrc + scrollypos left + showmultiple 1 + showmenu 1 + slaveeval {} + 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 + root . + } + + ## 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)] + } + + ## 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 [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) + } + + set dir [file dir [info nameofexec]] + foreach dir [list $dir [file join [file dir $dir] lib]] { + if [file exists [file join $dir pkgIndex.tcl]] { + if {[lsearch -exact $auto_path $dir] < 0} { + lappend auto_path $dir + } + } + } + + foreach dir $auto_path { + if [file exists [file join $dir pkgIndex.tcl]] { + source [file join $dir pkgIndex.tcl] + } + } + + ## 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 {} + for {set i 0} {$i < $argc} {incr i} { + set arg [lindex $argv $i] + if [regexp -- {-.+} $arg] { + ## 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 } + } + } elseif {[file isfile $arg]} { + lappend slavefiles $arg + } else { + lappend slaveargs $arg + } + } + + ## Create slave executable + if [string comp {} $tkCon(exec)] { + eval tkConInitSlave $tkCon(exec) $slaveargs + } + + tkConAttach $tkCon(appname) $tkCon(apptype) + tkConInitUI $title + + ## Set up package info for the slave + tkConCheckPackages + + ## 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" + } + } + + 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" + } + ## 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" + } else { + puts stdout "returned from $tkCon(rcfile):\n$err" + } + } +} + +## tkConInitSlave - inits the slave by placing key procs and aliases in it +## It's arg[cv] are based on passed in options, while argv0 is the same as +## the master. tcl_interactive is the same as the master as well. +# 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 + if [string match {} $slave] { + 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 + } + 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) + + foreach pkg [lremove [package names] Tcl] { + foreach v [package versions $pkg] { + interp eval $slave [list package ifneeded $pkg $v \ + [package ifneeded $pkg $v]] + } + } +} + +## 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 +# 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] } + set tkCon(base) $w + wm withdraw $root + + 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)] + bindtags $w.text "$w.text PreCon Console PostCon $root all" + set tkCon(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 \ + -command "$w.text yview"] + + tkConInitMenus $tkCon(menubar) + + if $tkCon(showmenu) { pack $tkCon(menubar) -fill x } + pack $tkCon(scrolly) -side $tkCon(scrollypos) -fill y + pack $tkCon(console) -fill both -expand 1 + + tkConPrompt "$title console display active\n" + + foreach col {prompt stdout stderr stdin proc} { + $w.text tag configure $col -foreground $tkCon(color,$col) + } + $w.text tag configure blink -background $tkCon(color,blink) + + bind $w.text { + scan [wm geometry [winfo toplevel %W]] "%%dx%%d" tkCon(cols) tkCon(rows) + } + + wm title $root "tkCon $tkCon(version) $title" + wm deiconify $root + focus $w.text +} + +## tkConEval - evaluates commands input into console window +## This is the first stage of the evaluating commands in the console. +## They need to be broken up into consituent commands (by tkConCmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd +## +proc tkConEval {w} { + global tkCon + tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd) + $w mark set insert end-1c + $w insert end \n + if [llength $cmds] { + foreach cmd $cmds {tkConEvalCmd $w $cmd} + $w insert insert $tkCon(cmd) {} + } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} { + tkConEvalCmd $w $tkCon(cmd) + } + $w see insert +} + +## tkConEvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: tkConPrompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +proc tkConEvalCmd {w cmd} { + global tkCon + $w mark set output end + if [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] + } elseif [regexp {^!(.+)$} $cmd dummy event] { + set err [catch {tkConEvalSlave history event $event} cmd] + } elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new] { + if ![set err [catch {tkConEvalSlave history event $ev} cmd]] { + regsub -all -- $old $cmd $new cmd + } + } + } + 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 + } + } else { + if [catch [list tkConEvalAttached $cmd] res] { + set tkCon(errorInfo) [tkConEvalAttached set errorInfo] + 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(svnt) [set tkCon(event) [tkConEvalSlave history nextid]] +} + +## tkConEvalSlave - evaluates the args in the associated slave +# ARGS: args - the command and args to evaluate +## +proc tkConEvalSlave args { + global tkCon + interp eval $tkCon(exec) $args +} + +## tkConEvalSend - sends the args to the attached interpreter +## Varies from 'send' by determining whether attachment is dead +## when an error is received +# 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 [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 {} + tkConEvalSlave set errorInfo $err + } + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } + return -code $code $result +} + +## tkConCmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +proc tkConCmdGet w { + if [string match {} [set ix [$w tag nextrange prompt limit end]]] { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## tkConCmdSep - separates multiple commands into a list and remainder +# ARGS: cmd - (possible) multiple command to separate +# list - varname for the list of commands that were separated. +# rmd - varname of any remainder (like an incomplete final command). +# If there is only one command, it's placed in this var. +# Returns: constituent command info in varnames specified by list & rmd. +## +proc tkConCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if [string comp {} $tmp] { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } + } + if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] + } +} + +## tkConPrompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in tkCon(prompt1)) to console +## +proc tkConPrompt {{pre {}} {post {}}} { + 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 + } + $w insert end [tkConEvalSlave subst $tkCon(prompt1)] prompt + $w mark set output $i + $w mark set limit insert + $w mark gravity limit left + if [string comp {} $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/" 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 +} + +## tkConInitMenus - inits the menus for the console +# ARGS: w - console text widget +## +proc tkConInitMenus w { + 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" + + ## Console Menu + ## + foreach m [list [menu $w.con.m] [menu $w.pop.con]] { + $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 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 + + ## Attach Console 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" + } + + ## 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 + ## + 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" + + ## 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(scrolly) + } else { pack forget $w }" + $m add cascade -label Scrollbar -un 0 -menu $m.scroll + + ## Scrollbar 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 + } + } + + ## 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 + } + + ## 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)] + } + bind all { + if [string comp {} $tkCon(name)] { + tkConAttach $tkCon(name) + } else { + tkConAttach Main + } + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } + bind all { + tkConAttach Main + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } +} + +## 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 + } + } + } + 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" + } + } +} + +## tkConFillAppsMenu - fill in in the applications sub-menu +## with a list of all the applications that currently exist. +## +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]]] + + 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 separator + $m add command -label "Foreign Tk Interpreters" -state disabled + foreach i [lsort [lremove [winfo interps] \ + [concat $masters $slaves [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] { + 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" + } + } 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" + } + } + } +} + +## 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. +# type - (slave|interp) type of interpreter we're attaching to +# slave means it's a TkCon interpreter +# interp means we'll need to 'send' to it. +# Results: tkConEvalAttached is recreated to evaluate in the +# appropriate interpreter +## +proc tkConAttach {an {type slave}} { + global tkCon + 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 {$tkCon(loadTk) && [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 + } + } else { + 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 + + ## 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. + # ARGS: args - the command and args to evaluate + ## + switch $type { + slave { + if [string match {} $an] { + interp alias {} tkConEvalAttached {} tkConEvalSlave + } 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 { error "[lindex [info level 0] 0] did not specify type" } + } + return +} + +## tkConLoad - sources a file into the console +# ARGS: fn - (optional) filename to source in +# Returns: selected filename ({} if nothing was selected) +## +proc tkConLoad {{fn {}}} { + global tkCon + if {[string match {} $fn] && + ([catch {tkFileSelect} fn] || [string match {} $fn])} return + tkConEvalAttached source $fn +} + +## tkConSave - saves the console buffer to a file +## This does not eval in a slave because it's not necessary +# ARGS: w - console text widget +# fn - (optional) filename to save to +## +proc tkConSave {{fn {}}} { + global tkCon + if {[string match {} $fn] && + ([catch {tkFileSelect} fn] || [string match {} $fn])} return + if [catch {open $fn w} fid] { + 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. +## +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 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 + 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 + } + } + + ## 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 {} [list [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 {} + } else { + lappend ls $i $name + } + set ls [tkConInterps $ls $i] + } + return $ls + } +} + + +## 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 +} + +## tkConStateCompare - compare two states and output difference +# ARGS: ary1 - an array with checkpointed state +# ary2 - a second array with checkpointed state +# Outputs: +## +proc tkConStateCompare {ary1 ary2} { + upvar $ary1 a1 $ary2 a2 + puts "Commands unique to $ary1:\n[lremove $a1(commands) $a2(commands)]" + puts "Commands unique to $ary2:\n[lremove $a2(commands) $a1(commands)]" + puts "Variables unique to $ary1:\n[lremove $a1(variables) $a2(variables)]" + puts "Variables unique to $ary2:\n[lremove $a2(variables) $a1(variables)]" +} + +## tkConStateRevert - reverts interpreter to a previous state +# ARGS: ary - an array with checkpointed state +## +proc tkConStateRevert {ary} { + upvar $ary a + foreach i [lremove [tkConEvalAttached info commands *] $a(commands)] { + catch "tkConEvalAttached rename $i {}" + } + foreach i [lremove [tkConEvalAttached info vars *] $a(variables)] { + catch "tkConEvalAttached unset $i" + } +} + + +## 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 + tkConDestroy + } + clean { + ## 'cleans' the interpreter - reverting to original tkCon state + ## FIX + ## tkConStateRevert tkCon + } + console { + ## Passes the args to the text widget of the console. + eval $tkCon(console) [lreplace $args 0 0] + } + error { + ## Outputs stack caused by last error. + if [string match {} $tkCon(errorInfo)] { + set tkCon(errorInfo) {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" + 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 config -state disabled + } + eval { + ## evals contents in master interpreter + eval [lreplace $args 0 0] + } + font { + ## "tkcon font ?fontname?". Sets the font of the console + if [string comp {} [lindex $args 1]] { + return [$tkCon(console) config -font [lindex $args 1]] + } else { + return [$tkCon(console) config -font] + } + } + hide { + ## Hides the console with 'withdraw'. + wm withdraw $tkCon(root) + } + iconify { + ## Iconifies the console with 'iconify'. + wm iconify $tkCon(root) + } + show - deiconify { + ## "tkcon show|deiconify". Deiconifies the console. + wm deiconify $tkCon(root) + } + title { + ## "tkcon title ?title?". Retitles the console + if [string comp {} [lindex $args 1]] { + return [wm title $tkCon(root) [lindex $args 1]] + } else { + return [wm title $tkCon(root)] + } + } + version { + return $tkCon(version) + } + default { + ## tries to determine if the command exists, otherwise throws error + set cmd [lindex $args 0] + set cmd tkCon[string toup [string index $cmd 0]][string range $cmd 1 end] + if [string match $cmd [info command $cmd]] { + eval $cmd [lreplace $args 0 0] + } else { + error "bad option \"[lindex $args 0]\": must be attach, close,\ + console, destroy, eval, font, hide, iconify,\ + load, main, new, save, show, slave, deiconify, title" + } + } + } +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## puts +## This allows me to capture all stdout/stderr to the console window +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +catch {rename puts tcl_puts} +proc puts args { + set len [llength $args] + if {$len==1} { + eval tkcon console insert output $args stdout {\n} stdout + tkcon console see output + } elseif {$len==2 && + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if [string comp $tmp -nonewline] { + eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp + } else { + eval tkcon console insert output [lreplace $args 0 0] stdout + } + tkcon console see output + } elseif {$len==3 && + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if [string comp [lreplace $args 1 2] -nonewline] { + eval tkcon console insert output [lrange $args 1 1] $tmp + } else { + eval tkcon console insert output [lreplace $args 0 1] $tmp + } + tkcon console see output + } else { + eval tcl_puts $args + } +} + +## clear - clears the buffer of the console (not the history though) +## This is executed in the parent interpreter +## +proc clear {{pcnt 100}} { + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + error "invalid percentage to clear: must be 1-100 (100 default)" + } elseif {$pcnt == 100} { + tkcon console delete 1.0 end + } else { + set tmp [expr $pcnt/100.0*[tkcon console index end]] + tkcon console delete 1.0 "$tmp linestart" + } +} + +## alias - akin to the csh alias command +## If called with no args, then it dumps out all current aliases +## If called with one arg, returns the alias of that arg (or {} if none) +# ARGS: newcmd - (optional) command to bind alias to +# args - command and args being aliased +## +proc alias {{newcmd {}} args} { + if [string match {} $newcmd] { + set res {} + foreach a [interp aliases] { + lappend res [list $a: [interp alias {} $a]] + } + return [join $res \n] + } elseif {[string match {} $args]} { + interp alias {} $newcmd + } else { + eval interp alias {{}} $newcmd {{}} $args + } +} + +## unalias - unaliases an alias'ed command +# ARGS: cmd - command to unbind as an alias +## +proc unalias {cmd} { + interp alias {} $cmd {} +} + +## dump - outputs variables/procedure/widget info in source'able form. +## Accepts glob style pattern matching for the names +# ARGS: type - type of thing to dump: must be variable, procedure, widget +# OPTS: -nocomplain don't complain if no vars match something +# Returns: the values of the variables in a 'source'able form +## +proc dump {type args} { + set whine 1 + set code ok + if [string match \-n* [lindex $args 0]] { + set whine 0 + set args [lreplace $args 0 0] + } + if {$whine && [string match {} $args]} { + error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?" + } + set res {} + switch -glob -- $type { + v* { + # variable + # outputs variables value(s), whether array or simple. + foreach arg $args { + if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { + if {[uplevel info exists $arg]} { + set vars $arg + } elseif $whine { + append res "\#\# No known variable $arg\n" + set code error + continue + } else continue + } + foreach var [lsort $vars] { + upvar $var v + if {[array exists v]} { + append res "array set $var \{\n" + foreach i [lsort [array names v]] { + upvar 0 v$$i$ w + if {[array exists w]} { + append res " [list $i {NESTED VAR ERROR}]\n" + if $whine { set code error } + } else { + append res " [list $i $v($i)]\n" + } + } + append res "\}\n" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if {[string comp {} [set ps [info proc $arg]]]} { + foreach p [lsort $ps] { + set as {} + foreach a [info args $p] { + if {[info default $p $a tmp]} { + lappend as [list $a $tmp] + } else { + lappend as $a + } + } + append res [list proc $p $as [info body $p]]\n + } + } elseif $whine { + append res "\#\# No known proc $arg\n" + } + } + } + w* { + # widget + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"[lindex $args 0]\":\ must be procedure, variable, widget" + } + } + return -code $code [string trimr $res \n] +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + if [string comp {} [info commands $cmd]] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + return "$cmd:\taliased to [alias $cmd]" + } elseif [string comp {} [info procs $cmd]] { + return "$cmd:\tinternal proc" + } else { + return "$cmd:\tinternal command" + } + } elseif [auto_execok $cmd] { + return [auto_execpath $cmd] + } else { + return "$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 {[string match windows $tcl_platform(platform)]} { + proc auto_execpath name { + global auto_execpath tcl_platform env + + if [info exists auto_execpath($name)] { + return $auto_execpath($name) + } + set auto_execpath($name) {} + if {[string comp relative [file pathtype $name]]} { + foreach ext {{} .exe .bat .cmd} { + if {[file exists ${name}${ext}] && \ + ![file isdirectory ${name}${ext}]} { + set auto_execpath($name) $name + } + } + return $auto_execpath($name) + } + if {[info exists env(PATH)]} { + set path $env(PATH) + } else { + if [info exists env(Path)] { set path $env(Path) } else { return {} } + } + foreach dir [split $path {;}] { + if {[string match {} $dir]} { set dir . } + foreach ext {{} .exe .bat .cmd} { + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + set auto_execpath($name) $file + break + } + } + } + return $auto_execpath($name) + } +} else { + proc auto_execpath name { + global auto_execpath env + + if [info exists auto_execpath($name)] { + return $auto_execpath($name) + } + set auto_execpath($name) {} + if {[string comp relative [file pathtype $name]]} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execpath($name) $name + } + return $auto_execpath($name) + } + foreach dir [split $env(PATH) :] { + if {[string match {} $dir]} { set dir . } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execpath($name) $file + break + } + } + return $auto_execpath($name) + } +} + +## dir - directory list +# ARGS: args - names/glob patterns of directories to list +# OPTS: -all - list hidden files as well (Unix dot files) +# -long - list in full format "permissions size date filename" +# -full - displays / after directories and link paths for links +# 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 { + error "Passed unknown arg $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 - + } 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 + } + } 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)] + set j [expr [tkcon eval 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] +} + + +## tclindex - creates the tclIndex file +# OPTS: -ext - extensions to auto index (defaults to *.tcl) +# 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] + } + if [string match {} $args] { + eval auto_mkindex [list [pwd]] $ext + } else { + foreach dir $args { + if [file isdir $dir] { eval auto_mkindex [list $dir] $ext } + } + } +} + +## lremove - remove items from a list +# OPTS: -all remove all instances of each item +# ARGS: l a list to remove items from +# is a list of items to remove +## +proc lremove {args} { + set all 0 + if [string match \-a* [lindex $args 0]] { + set all 1 + set args [lreplace $args 0 0] + } + set l [lindex $args 0] + eval append is [lreplace $args 0 0] + foreach i $is { + if {[set ix [lsearch -exact $l $i]] == -1} continue + set l [lreplace $l $ix $ix] + if $all { + while {[set ix [lsearch -exact $l $i]] != -1} { + set l [lreplace $l $i $i] + } + } + } + return $l +} + + +## Unknown changed to get output into tkCon window +# unknown: +# Invoked when a Tcl command is invoked that doesn't exist in the +# interpreter: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if {[array size unknown_pending] == 0} { + unset unknown_pending + } + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {[info level] == 1 && [string match {} [info script]] \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + if [auto_execok $name] { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec $args] + #return [uplevel exec >&@stdout <@stdin $args] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + ## + ## History substitution moved into tkConEvalCmd + ## + 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]" + } + } + } + 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} +} + +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] {

\ +

Getting Started: +TkCon resource file and command line options	Special Bindings	New Procedures in TkCon
`dump` procedure	`tkcon` procedure	`idebug` procedure	`observe` procedure