--- /dev/null
+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!
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: Special Bindings</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: Special Bindings</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#FFFF33><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="start.html">Getting Started</A></B></TD>
+<TD BGCOLOR=#CCFF99><B><A HREF="bindings.html">Special Bindings</A></B></TD>
+<TD><B><A HREF="procs.html">Procedures</A></B></TD>
+</TR>
+<TR>
+<TD><B><A HREF="dump.html"><CODE>dump</CODE></A></B></TD>
+<TD><B><A HREF="tkcon.html"><CODE>tkcon</CODE></A></B></TD>
+<TD><B><A HREF="idebug.html"><CODE>idebug</CODE></A></B></TD>
+<TD><B><A HREF="observe.html"><CODE>observe</CODE></A></B></TD>
+</TR>
+</TABLE>
+
+ <P>
+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.
+ <P>
+
+<DL compact>
+<DT> <B>Control-x</B> or <B>Cut</B> (on Sparc5 keyboards)
+<DD> Cut
+<DT> <B>Control-c</B> or <B>Copy</B> (on Sparc5 keyboards)
+<DD> Copy
+<DT> <B>Control-v</B> or <B>Paste</B> (on Sparc5 keyboards)
+<DD> Paste
+<DT> <B>Insert</B>
+<DD> Insert (duh).
+ <P>
+<DT> <B>Up</B>
+<DD> Goes up one level in the commands line history when cursor is on the
+prompt line, otherwise it moves through the buffer
+<DT> <B>Down</B>
+<DD> 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
+<DT> <B>Control-p</B>
+<DD> Goes up one level in the commands line history
+<DT> <B>Control-n</B>
+<DD> Goes down one level in the commands line history
+ <P>
+<DT> <B>Tab</B>
+<DD> Tries to expand file path names, then variable names, then proc names.
+<DT> <B>Escape</B>
+<DD> Tries to expand file path names.
+<DT> <B>Control-P</B>
+<DD> 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).
+<DT> <B>Control-V</B>
+<DD> Tries to expand variable names (those returned by [info vars]).
+It's search behavior is like that for procedure names.
+ <P>
+<DT> <B>Return</B> or <B>Enter</B>
+<DD> Evaluates the current command line if it is a complete command,
+otherwise it just goes to a new line
+<DT> <B>Control-a</B>
+<DD> Go to the beginning of the current command line
+<DT> <B>Control-l</B>
+<DD> Clear the entire console buffer
+<DT> <B>Control-r</B>
+<DD> Searches backwards in the history for a command starting with the
+current command line. Repeatable to search farther back.
+<DT> <B>Control-s</B>
+<DD> As above, but searches forward (only useful if you searched too far back).
+<DT> <B>Control-t</B>
+<DD> Transposes characters
+<DT> <B>Control-u</B>
+<DD> Clear the current command line
+<DT> <B>Control-z</B>
+<DD> Saves current command line in a buffer that can be retrieved with
+another <B>Control-z</B>. 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.
+ <P>
+<DT> <B>Control-Key-1</B>
+<DD> Attaches console to the console's slave interpreter
+<DT> <B>Control-Key-2</B>
+<DD> Attaches console to the console's master interpreter
+<DT> <B>Control-Key-3</B>
+<DD> Attaches console to main TkCon interpreter
+<DT> <B>Control-A</B>
+<DD> Pops up the "About" dialog
+<DT> <B>Control-N</B>
+<DD> Creates a new console. Each console has separate state, including
+it's own widget hierarchy (it's a slave interpreter).
+<DT> <B>Control-q</B>
+<DD> Close the current console OR Quit the program (depends on the value
+of TKCON(slaveexit)).
+<DT> <B>Control-w</B>
+<DD> Closes the current console. Closing the main console will exit the
+program (something has to control all the slaves...)
+</DL>
+
+TkCon also has <B>electric bracing</B> (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?).
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+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
+<s-imai@lsi.tmg.nec.co.jp>.
+
+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 <Control-1>).
+
+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 <Triple-1> 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 <pattern>'. (Thanks to steven@indra.com)
+
+Changed tkConExpand to stop at $ as well.
+
+Changed tkConTagProc binding from Console <KeyRelease> to PostCon <KeyPress>.
+It seems to miss a lot less now.
+
+---- July 3 1996 v0.49 ----
+
+Slight mod to <BackSpace>.
+
+Fixed <Delete> 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 <Control-n> bug (incr $tkCon(event) --> incr tkCon(event))
+
+---- June 8 1996 v0.35 ----
+
+Removed "Resource" from 'Edit' menu
+
+Rewrote 'clear' to accept percentage level
+
+Fixed <Control-s> 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
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: dump procedure</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: <CODE>dump</CODE> procedure</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#FFFF33><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="start.html">Getting Started</A></B></TD>
+<TD><B><A HREF="bindings.html">Special Bindings</A></B></TD>
+<TD><B><A HREF="procs.html">Procedures</A></B></TD>
+</TR>
+<TR>
+<TD BGCOLOR=#CCFF99><B><A HREF="dump.html"><CODE>dump</CODE></A></B></TD>
+<TD><B><A HREF="tkcon.html"><CODE>tkcon</CODE></A></B></TD>
+<TD><B><A HREF="idebug.html"><CODE>idebug</CODE></A></B></TD>
+<TD><B><A HREF="observe.html"><CODE>observe</CODE></A></B></TD>
+</TR>
+</TABLE>
+
+ <P>
+The <CODE>dump</CODE> 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:
+
+<BLOCKQUOTE>
+<code>dump</code> <b>method</b> <i>?-nocomplain? ?-filter pattern? ?--?
+pattern ?pattern ...?</i>
+</BLOCKQUOTE>
+
+The patterns represent glob-style patterns (as in <code>string match pattern
+$str</code>). <i>-nocomplain</i> will prevent <code>dump</code> from
+throwing an error if no items matched the pattern. <i>-filter</i> is
+interpreted as appropriate for the method. The various methods are:
+
+<DL>
+
+<DT> dump <b>command</b> <i>args</i>
+<DD> Outputs one or more commands.
+
+<DT> dump <b>procedure</b> <i>args</i>
+<DD> Outputs one or more procs in sourceable form.
+
+<DT> dump <b>variable</b> <i>args</i>
+<DD> Outputs the values of variables in sourceable form. Recognizes nested
+arrays. The <i>-filter</i> 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.
+
+<DT> dump <b>widget</b> <i>args</i>
+<DD> Outputs one or more widgets by giving their configuration options.
+The <i>-filter</i> pattern is used as to filter the config options and
+is interpreted as a case insensitive regexp pattern (defaults to {.*})
+
+</DL>
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: idebug procedure</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: <CODE>idebug</CODE> procedure</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#FFFF33><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="start.html">Getting Started</A></B></TD>
+<TD><B><A HREF="bindings.html">Special Bindings</A></B></TD>
+<TD><B><A HREF="procs.html">Procedures</A></B></TD>
+</TR>
+<TR>
+<TD><B><A HREF="dump.html"><CODE>dump</CODE></A></B></TD>
+<TD><B><A HREF="tkcon.html"><CODE>tkcon</CODE></A></B></TD>
+<TD BGCOLOR=#CCFF99><B><A HREF="idebug.html"><CODE>idebug</CODE></A></B></TD>
+<TD><B><A HREF="observe.html"><CODE>observe</CODE></A></B></TD>
+</TR>
+</TABLE>
+
+ <P>
+The <B>idebug</B> command provides an interactive debugging environment for
+procedures via TkCon. You can place <code>idebug break</code> commands
+into your procedure to create breakpoints. It will pop up the TkCon
+console and put you into a "debugging" mode. The <code>body, show &
+trace</code> methods are intended for internal use only.
+ <P>
+
+This procedure is experimental (to say the least). Comments are encouraged.
+
+<DL>
+
+<DT> <CODE>idebug body</CODE> <I>?level?</I>
+<DD> Prints out the body of the command (if it is a procedure) at the
+specified level. <i>level</i> defaults to the current level.
+
+<DT> <CODE>idebug break</CODE> <I>?id?</I>
+<DD> 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.
+
+<DT> <CODE>idebug {echo ?id?}</CODE> <I>?args?</I>
+<DD> Behaves just like <code>echo</code>, 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.
+
+<DT> <CODE>idebug id</CODE> <I>?id?</I>
+<DD> 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 *.
+
+<DT> <CODE>idebug off</CODE>
+<DD> Turns idebug off.
+
+<DT> <CODE>idebug on</CODE> <I>?id?</I>
+<DD> Turns idebug on. If <i>id</i> is specified, it sets the id to it.
+
+<DT> <CODE>idebug {puts ?id?}</CODE> <I>args</I>
+<DD> Behaves just like <code>puts</code>, 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.
+
+<DT> <CODE>idebug show</CODE> <I>type ?level? ?VERBOSE?</I>
+<DD> <i>type</i> 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.
+<i>level</i> defaults to the level in which this method was called.
+
+<DT> <CODE>idebug trace</CODE> <I>?level?</I>
+<DD> Prints out the stack trace from the specified level up to the top
+level. <i>level</i> defaults to the current level.
+
+</DL>
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: Documentation</TITLE>
+
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: Documentation (March 1999)</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#FFFF33><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<H4><A HREF="http://www.purl.org/net/hobbs/tcl/script/tkcon/tkcon.tar.gz">newest tkcon release</A> (tar,gzip'ed)</H4>
+
+<H4><A HREF="demopic.gif">Screenshot</A> (tar,gzip'ed)</H4>
+
+Please <B>read the following pages carefully</B> to fully understand the
+features AND limitations of TkCon. I'm always open to suggestions for
+improvement. Send them to my
+<A HREF="mailto:jeff.hobbs@acm.org">suggestion box</A>.
+ <P>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="start.html">Getting Started:</A></B><BR>
+<SMALL>TkCon resource file and command line options</SMALL></TD>
+<TD><B><A HREF="bindings.html">Special Bindings</A></B></TD>
+<TD><B><A HREF="procs.html">New Procedures in TkCon</A></B></TD>
+</TR>
+<TR>
+<TD><B><A HREF="dump.html"><CODE>dump</CODE> procedure</A></B></TD>
+<TD><B><A HREF="tkcon.html"><CODE>tkcon</CODE> procedure</A></B></TD>
+<TD><B><A HREF="idebug.html"><CODE>idebug</CODE> procedure</A></B></TD>
+<TD><B><A HREF="observe.html"><CODE>observe</CODE> procedure</A></B></TD>
+</TR>
+</TABLE>
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+ * 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 <jeff.hobbs@acm.org>. 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.
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: Limitations</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: Limitations</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD BGCOLOR=#FFFF33><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<H3>Limitations:</H3>
+
+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.
+ <P>
+
+Since TkCon is built for cross-platform capability, <font color=#FF0000>in
+Unix/Windows environments it does not have tty/shell behavior</font>. This
+means programs like <CODE>vi</CODE> and <CODE>less</CODE> (those that rely
+on tty/shell settings) will not function appropriately (currently they may
+hang TkCon). Programs like <CODE>ls</CODE> and <CODE>more</CODE> will just
+spit output to the TkCon screen without any special control or formatting
+(note that <CODE>ls</CODE> 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 <CODE>stdin</CODE> input.
+ <P>
+
+When connecting to non-Tcl Tk interpreters (ie - PerlTk, SchemeTk, ...),
+you must use the syntax of the target environment. See my
+<A HREF="nontcl.html">notes on using other Tk-embedded languages</A> for
+more info.
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon for Non-Tcl Users</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon for Non-Tcl Users</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2 BGCOLOR=#FFFF33><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<I>This document is for those users who are trying to use TkCon with a
+non-Tcl based Tk language (ie - SchemeTk, PerlTk, PythonTk...).</I>
+ <P>
+
+TkCon requires <A HREF="http://www.scriptics.com/">Tcl 7.6 / Tk 4.2</A> 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.
+ <P>
+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.
+ <P>
+
+<H3>Special Language Notes:</H3>
+
+<H4>Perl Tk</H4>
+
+Read the man page on Perl/Tk's send command. You have to define Tk::Receive
+before it will work.
+<A HREF="mailto:lusol@turkey.cc.lehigh.edu">Stephen Lidie
+(lusol@Turkey.CC.Lehigh.EDU)</A> contributed
+a <A HREF="perl.txt">companion Perl/Tk program</A> that does the trick with
+some extras.
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: observe procedure</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: <CODE>observe</CODE> procedure</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#FFFF33><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="start.html">Getting Started</A></B></TD>
+<TD><B><A HREF="bindings.html">Special Bindings</A></B></TD>
+<TD><B><A HREF="procs.html">Procedures</A></B></TD>
+</TR>
+<TR>
+<TD><B><A HREF="dump.html"><CODE>dump</CODE></A></B></TD>
+<TD><B><A HREF="tkcon.html"><CODE>tkcon</CODE></A></B></TD>
+<TD><B><A HREF="idebug.html"><CODE>idebug</CODE></A></B></TD>
+<TD BGCOLOR=#CCFF99><B><A HREF="observe.html"><CODE>observe</CODE></A></B></TD>
+</TR>
+</TABLE>
+
+ <P>
+This command provides runtime debugging output for variables and commands
+without the need to edit your code. For variables, the underlying mechanism
+uses <code>trace</code> and <code>dump var</code>. For commands, it renames
+the observed procedure and uses a special wrapper procedure. <b><font
+color="#FF0000">WARNING:</font></b> using this procedure after checkpointing
+state will result in major problems if you clean state because the renamed
+(true) commands will be lost.
+ <P>
+
+This procedure is experimental. Comments are encouraged.
+
+<DL>
+
+<DT> <CODE>observe command</CODE> <I>cmdname ?maxlevel?</I>
+<DD> This will create a wrapper command which prints out (using
+<code>dump</code>) the call stack to the console. <i>maxlevel</i>
+represents the maximum number of levels of the call stack which will be
+printed (defaults to 4).
+
+<DT> <CODE>observe cdelete</CODE> <I>cmdname</I>
+<DD> Removes the wrapper around an observed command.
+
+<DT> <CODE>observe cinfo</CODE> <I>cmdname</I>
+<DD> Prints out useless info.
+
+<DT> <CODE>observe variable</CODE> <I>varname operation ?args?</I>
+<DD> Currently a wrapper around trace that uses <code>dump</code> to
+print out the value of the named variable whenever the specified operation
+on that variable occurs (must be read, write or unset).
+
+<DT> <CODE>observe vdelete</CODE> <I>varname operation</I>
+<DD> Deletes the trace wrapper around the named variable.
+
+<DT> <CODE>observe vinfo</CODE> <I>varname</I>
+<DD> Prints out trace info about the named variable.
+
+</DL>
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+#!/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
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>Tcl Plugin Stripped TkCon Demo</TITLE>
+</HEAD>
+
+<BODY>
+<H1>Tcl Plugin Stripped TkCon Demo</H1>
+<HR>
+
+<A HREF="/tcl/script/tkcon/">Full TkCon Distribution</A>
+ <P>
+
+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.
+
+<P>
+<embed src="/tcl/script/tkcon/tkcon.tcl" width=600 height=350>
+</P>
+
+Have a look at some of the features: (culled from the
+<A HREF="/tcl/script/tkcon/docs/">full TkCon documentation</A>)
+<UL>
+<LI> <B>Variable / Path / Procedure Name Expansion.</B> Type in
+<CODE>set tc</CODE> at the prompt. Hit <I><Control-Shift-V></I>.
+<CODE>set tcl_</CODE> should now be visible.
+Hit <I><Control-Shift-V></I> 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.
+
+<LI> <B>Command Highlighting.</B> Note that <CODE>set</CODE> should be in
+green, denoting it is a recognized command in that interpreter.
+
+<LI> <B>Electric Character Matching.</B> Watch while you type the
+following: <CODE>proc foo { a b } { puts [list $a $b] }</CODE>. Did you
+notice the blink matching of the braces? Yes, it's smart.
+
+<LI> <B>Command History.</B> Use the Up/Down arrows or
+<I><Control-p></I>/<I><Control-n></I> to peruse the command
+history. <I><Control-r></I>/<I><Control-s></I> Actually
+does command history matching (like tcsh or other advanced Unix shells).
+
+<LI> <B>Useful Colorization.</B> Having defined <CODE>foo</CODE> above, type
+in <CODE>foo hey</CODE>. Note that the error comes back in red. Go up one
+in the command history and add <CODE> you</CODE> and see that regular
+stdout output comes through in blue (the colors are configurable).
+
+<LI> <B>Cut/Copy/Paste.</B> You should be able to do that between outside
+windows and TkCon. The default keys are
+<I><Control-x></I>/<I><Control-c></I>/<I><Control-v></I>.
+
+</UL>
+
+<HR>
+
+<ADDRESS>
+Contact <A HREF="mailto:jeff.hobbs@acm.org">jeff.hobbs@acm.org</A>
+with questions or updated info.
+</ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: Procedures</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: Procedures</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#FFFF33><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="start.html">Getting Started</A></B></TD>
+<TD><B><A HREF="bindings.html">Special Bindings</A></B></TD>
+<TD BGCOLOR=#CCFF99><B><A HREF="procs.html">Procedures</A></B></TD>
+</TR>
+<TR>
+<TD><B><A HREF="dump.html"><CODE>dump</CODE></A></B></TD>
+<TD><B><A HREF="tkcon.html"><CODE>tkcon</CODE></A></B></TD>
+<TD><B><A HREF="idebug.html"><CODE>idebug</CODE></A></B></TD>
+<TD><B><A HREF="observe.html"><CODE>observe</CODE></A></B></TD>
+</TR>
+</TABLE>
+
+ <P>
+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:
+
+<DL COMPACT>
+
+<DT> <B>alias</B> <I>?sourceCmd targetCmd ?arg arg ...??</I>
+<DD> 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).
+<font color=#FF0000>Don't delete those</font>.
+
+<DT> <B>clear</B> <I>?percentage?</I>
+<DD> 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).
+
+<DT> <B>dir</B> <i>?-all? ?-full? ?-long? ?pattern pattern ...?</i>
+<DD> Cheap way to get directory listings. Uses glob style pattern matching.
+
+<DT> <B>dump</B> <I>type ?-nocomplain? ?-filter pattern? ?--?
+pattern ?pattern ...?</I>
+<DD> The <CODE>dump</CODE> command provides a way for the user to spit out
+state information about the interpreter in a Tcl readable (and human
+readable) form.
+See <a href="dump.html">further <B>dump</B> docs</a> for details.
+
+<DT> <B>echo</B> <I>?arg arg ...?</I>
+<DD> Concatenates the args and spits the result to the console (stdout).
+
+<DT> <B>edit</B> <I>?-type type? ?-find str? ?-attach interp?</I> arg
+<font size=-1 color=#990033>NEW in v1.4, still under construction</font>
+<DD> Opens an editor with the data from <I>arg</I>. The optional <I>type</I>
+argument can be one of: <I>proc</I>, <I>var</I> or <I>file</I>. For
+proc or var, the <I>arg</I> may be a pattern.
+
+<DT> <B>idebug</B> <I>command ?args?</I>
+<DD> Interactive debugging command.
+See <a href="idebug.html">further <B>idebug</B> docs</a> for details.
+
+<DT> <B>lremove</B> <I>?-all? ?-regexp -glob? list items</I>
+<DD> Removes one or more items from a list and returns the new list. If
+<I>-all</I> is specified, it removes all instances of each item in the
+list. If <I>-regexp</I> or <I>-glob</I> is specified, it interprets each
+item in the items list as a regexp or glob pattern to match against.
+
+<DT> <B>less</B>
+<DD> Aliased to <B>edit</B>.
+
+<DT> <B>ls</B>
+<DD> Aliased to <B>dir -full</B>.
+
+<DT> <B>more</B>
+<DD> Aliased to <B>edit</B>.
+
+<DT> <B>observe</B> <I>type ?args?</I>
+<DD> This command provides passive runtime debugging output for variables
+and commands.
+See <a href="observe.html">further <B>observe</B> docs</a> for details.
+
+<DT> <B>puts</B> (same options as always)
+<DD> Redefined to put the output into TkCon
+
+<DT> <B>tkcon</B> <I>method ?args?</I>
+<DD> Multi-purpose command.
+See <a href="tkcon.html">further <B>tkcon</B> docs</a> for details.
+
+<DT> <B>tclindex</B> <I>?-extensions patternlist? ?-index TCL_BOOLEAN?
+?-package TCL_BOOLEAN? ?dir1 dir2 ...?</I>
+<DD> 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.
+
+<DT> <B>unalias</B> <I>cmd</I>
+<DD> unaliases command
+
+<DT> <B>what</B> <i>string</i>
+<DD> The <CODE>what</CODE> command will identify the word given in
+<i>string</i> 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
+<CODE>dump</CODE> and <CODE>which</CODE>.
+
+<DT> <B>which</B> <i>command</i>
+<DD> 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.
+
+</DL>
+
+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).
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: Purpose & Features</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: Purpose & Features</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD BGCOLOR=#FFFF33><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<H3>Purpose:</H3>
+
+TkCon is a replacement for the standard console that comes with Tk (on
+Windows/Mac, but also works on Unix). The console itself provides
+<i>many</i> 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).
+ <P>
+See <A HREF="limits.html">Limitations</A> for a good idea of what
+TkCon <B>can't</B> do for you.
+
+<H3>Features:</H3>
+
+Just in case you don't run across them while playing, here are some of the
+extras in TkCon:
+<UL>
+<LI> Command history
+<LI> Path (Unix style) / Proc / Variable name expansion
+<LI> Multiple consoles, each with its own state (via multiple interpreters)
+<LI> Captures <CODE>stdout</CODE> and <CODE>stderr</CODE> to console window
+<LI> Electric character matching (a la emacs)
+<LI> Electric proc highlighting
+<LI> Enhanced history searching
+<LI> Configurable
+<LI> Cut / Copy / Paste between windows
+<LI> Communication between consoles and other Tk interpreters (including
+non-tcl ones)
+<LI> Works on all Tk platforms
+</UL>
+
+Read the <A HREF="index.html">documentation</A> for how to take advantage
+of these features.
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: Getting Started</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: Getting Started</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#FFFF33><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#CCFF99><B><A HREF="start.html">Getting Started</A></B></TD>
+<TD><B><A HREF="bindings.html">Special Bindings</A></B></TD>
+<TD><B><A HREF="procs.html">Procedures</A></B></TD>
+</TR>
+<TR>
+<TD><B><A HREF="dump.html"><CODE>dump</CODE></A></B></TD>
+<TD><B><A HREF="tkcon.html"><CODE>tkcon</CODE></A></B></TD>
+<TD><B><A HREF="idebug.html"><CODE>idebug</CODE></A></B></TD>
+<TD><B><A HREF="observe.html"><CODE>observe</CODE></A></B></TD>
+</TR>
+</TABLE>
+
+<H3>Resource File:</H3>
+
+TkCon will search for a resource file in "<CODE>$env(HOME)/.tkconrc</CODE>"
+(Unix), "<CODE>$env(HOME)/tkcon.cfg</CODE>" (Windows) or
+"<CODE>$env(PREF_FOLDER)/tkcon.cfg</CODE>" (Macintosh). On DOS machines,
+"<CODE>$env(HOME)</CODE>" usually refers to "<CODE>C:\</CODE>". TkCon
+never sources the "<CODE>~/.wishrc</CODE>" file. The resource file is
+sourced by each new instance of the console. An example resource file is
+provided below.
+
+<H3>Command Line Arguments</H3>
+
+Except for <CODE>-rcfile</CODE>, command line arguments are handled after
+the TkCon resource file is sourced, but before the slave interpreter or the
+TkCon user interface is initialized. <CODE>-rcfile</CODE> 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
+<CODE>tkcon main set argv {}; tkcon main set argc 0</CODE>.
+ <P>
+For these options, any unique substring is allowed.
+
+<DL>
+
+<DT> <CODE>-argv</CODE> (also <CODE>--</CODE>)
+<DD> Causes TkCon to stop evaluating arguments and set the remaining args to
+be argv/argc (with <CODE>--</CODE> prepended). This carries over for any
+further consoles. This is meant only for wrapping TkCon around programs
+that require their own arguments.
+
+<DT> <CODE>-color,*</CODE> <I>color</I>
+<DD> Sets the requested color type to the specified color for tkcon.
+See the <B>Variables</B> section for the various color,* types.
+
+<DT> <CODE>-eval</CODE> (also <CODE>-main</CODE> or <CODE>-e</CODE>)
+<DD> 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 <CODE>-eval</CODE> switches will be recognized (in order).
+
+<DT> <CODE>-exec</CODE> <I>slavename</I>
+<DD> 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.
+
+<DT> <CODE>-font</CODE> <I>font</I>
+<DD> Sets the font that tkcon uses for its text windows. If this isn't
+a fixed width font, tkcon will override it.
+
+<DT> <CODE>-nontcl</CODE> <I>TCL_BOOLEAN</I>
+<DD> Sets <CODE>TKCON(nontcl)</CODE> to <I>TCL_BOOLEAN</I>. Needed when
+attaching to non-Tcl interpreters.
+
+<DT> <CODE>-package</CODE> <I>package_name</I> (also <CODE>-load</CODE>)
+<DD> Packages to automatically load into the slave interpreters (ie - "Tk").
+
+<DT> <CODE>-rcfile</CODE> <I>filename</I>
+<DD> Specify an alternate tkcon resource file name.
+
+<DT> <CODE>-root</CODE> <I>widgetname</I>
+<DD> Makes the named widget the root name of all consoles (ie - .tkcon).
+
+<DT> <CODE>-slave</CODE> <I>tcl_script</I>
+<DD> A tcl script to eval in each slave interpreter. This will append
+the one specified in the tkcon resource file, if any.
+
+</DL>
+
+Some examples of tkcon command line startup situations:
+<DL>
+
+<DT> <CODE>megawish tkcon.tcl -exec "" -root .tkcon mainfile.tcl</CODE>
+<DD> Use tkcon as a console for your megawish application. You can avoid
+starting the line with <CODE>megawish</CODE> if that is the default wish
+that tkcon would use. The <CODE>-root</CODE> ensures that tkcon will not
+conflict with the
+
+<DT> <CODE>tkcon.tcl -font "Courier 12" -load Tk</CODE>
+<DD> Use the courier font for tkcon and always load Tk in slave
+interpreters at startup.
+
+<DT> <CODE>tkcon.tcl -rcfile ~/.wishrc -color,bg white</CODE>
+<DD> Use the <CODE>~/.wishrc</CODE> file as the resource file, and
+a white background for tkcon's text widgets.
+
+</DL>
+
+<H3>Variables:</H3>
+
+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 <CODE>TKCON</CODE>. You can
+'<CODE>tkcon set TKCON</CODE>' when the program is running to check its
+state. Here is an explanation of certain variables you might change or use:
+
+<DL>
+
+<DT> <CODE>color,bg</CODE>
+<DD> The background color for tkcon text widgets.
+Defaults to the operating system default (determined at startup).
+
+<DT> <CODE>color,blink</CODE>
+<DD> The background color of the electric brace highlighting, if on.
+Defaults to <font color=#FFFF00>yellow</font>.
+
+<DT> <CODE>color,cursor</CODE>
+<DD> The background color for the insertion cursor in tkcon.
+Defaults to <font color=#000000>black</font>.
+
+<DT> <CODE>color,disabled</CODE>
+<DD> The foreground color for disabled menu items.
+Defaults to <font color=#4D4D4D>dark grey</font>.
+
+<DT> <CODE>color,proc</CODE>
+<DD> The foreground color of a recognized proc, if command highlighting is on.
+Defaults to <font color=#008800>dark green</font>.
+
+<DT> <CODE>color,var</CODE>
+<DD> The background color of a recognized var, if command highlighting is on.
+Defaults to <font color=#FFC0D0>pink</font>.
+
+<DT> <CODE>color,prompt</CODE>
+<DD> The foreground color of the prompt as output in the console.
+Defaults to <font color=#8F4433>brown</font>.
+
+<DT> <CODE>color,stdin</CODE>
+<DD> The foreground color of the stdin for the console.
+Defaults to <font color=#000000>black</font>.
+
+<DT> <CODE>color,stdout</CODE>
+<DD> The foreground color of the stdout as output in the console.
+Defaults to <font color=#0000FF>blue</font>.
+
+<DT> <CODE>color,stderr</CODE>
+<DD> The foreground color of stderr as output in the console.
+Defaults to <font color=#FF0000>red</font>.
+ <P>
+
+<DT> <CODE>autoload</CODE>
+<DD> Packages to automatically load into the slave interpreter (ie - 'Tk').
+This is a list. Defaults to {} (none).
+
+<DT> <CODE>blinktime</CODE>
+<DD> The amount of time (in millisecs) that braced sections should
+<I>blink</I> for. Defaults to 500 (.5 secs), must be at least 100.
+
+<DT> <CODE>blinkrange</CODE>
+<DD> 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).
+
+<DT> <CODE>buffer</CODE>
+<DD> The size of the console scroll buffer (in lines).
+Defaults to 512.
+
+<DT> <CODE>calcmode</CODE>
+<DD> Whether to allow <CODE>expr</CODE> commands to be run at the command
+line without prefixing them with <CODE>expr</CODE> (just a convenience).
+
+<DT> <CODE>cols</CODE>
+<DD> Number of columns for the console to start out with. Defaults to 80.
+
+<DT> <CODE>dead</CODE>
+<DD> What to do with dead connected interpreters. If <CODE>dead</CODE>
+is <i>leave</i>, TkCon automatically exits the dead interpreter. If
+<CODE>dead</CODE> is <i>ignore</i> then it remains attached waiting for
+the interpreter to reappear. Otherwise TkCon will prompt you.
+
+<DT> <CODE>font</CODE>
+<DD> Font to use for tkcon text widgets (also specified with -font).
+Defaults to the system default, or a fixed width equivalent.
+
+<DT> <CODE>history</CODE>
+<DD> The size of the history list to keep. Defaults to 48.
+
+<DT> <CODE>hoterrors</CODE>
+<DD> 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.
+
+<DT> <CODE>library</CODE>
+<DD> The path to any tcl library directories (these are appended to the
+auto_path when the after the resource file is loaded in).
+
+<DT> <CODE>lightbrace</CODE>
+<DD> Whether to use the brace highlighting feature or not
+(respectively 1 or 0, defaults to 1).
+
+<DT> <CODE>lightcmd</CODE>
+<DD> Whether to use the command highlighting feature or not
+(respectively 1 or 0, defaults to 1).
+
+<DT> <CODE>maineval</CODE>
+<DD> A tcl script to execute in the main interpreter after the slave
+interpreter is created and the user interface is initialized.
+
+<DT> <CODE>nontcl</CODE>
+<DD> 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 <A HREF="nontcl.html">notes for non-Tcl
+based Tk interpreters</A>.
+
+<DT> <CODE>prompt1</CODE>
+<DD> Like tcl_prompt1, except it doesn't require you use '<CODE>puts</CODE>'.
+No equivalent for tcl_prompt2 is available (it's unnecessary IMHO).
+<BR>Defaults to {([file tail [pwd]]) [history nextid] % }.
+
+<DT> <CODE>rcfile</CODE>
+<DD> Name of the resource file. <CODE>$env(HOME)</CODE> is prepended to
+this. Defaults to <CODE>.tkconrc</CODE> on Unix and <CODE>tkcon.cfg</CODE>
+otherwise.
+
+<DT> <CODE>rows</CODE>
+<DD> Number of rows for the console to start out with. Defaults to 20.
+
+<DT> <CODE>scollypos</CODE>
+<DD> Y scrollbar position. Valid values are <CODE>left</CODE> or
+<CODE>right</CODE>. Defaults to <CODE>left</CODE>.
+
+<DT> <CODE>showmenu</CODE>
+<DD> Show the menubar on startup (1 or 0, defaults to 1).
+
+<DT> <CODE>showmultiple</CODE>
+<DD> Show multiple matches for path/proc/var name expansion
+(1 or 0, defaults to 1).
+
+<DT> <CODE>slaveeval</CODE>
+<DD> 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:
+<PRE> set TKCON(slaveeval) {
+ proc foo args { puts $args }
+ lappend auto_path .
+ }</PRE>
+
+<DT> <CODE>slaveexit</CODE>
+<DD> Allows the prevention of <CODE>exit</CODE> in slaves from exitting
+the entire application. If it is equal to <CODE>exit</CODE>, exit will
+exit as usual, otherwise it will just close down that interpreter (and
+any children). Defaults to <VAR>close</VAR>.
+
+<DT> <CODE>subhistory</CODE>
+<DD> 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.
+</DL>
+
+ <P>
+
+An <b>example TkCon resource file</b> might look like:
+
+<PRE>######################################################
+## 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
+######################################################</PRE>
+
+ <p>
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: tkcon procedure</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: <CODE>tkcon</CODE> procedure</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD BGCOLOR=#FFFF33><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="start.html">Getting Started</A></B></TD>
+<TD><B><A HREF="bindings.html">Special Bindings</A></B></TD>
+<TD><B><A HREF="procs.html">Procedures</A></B></TD>
+</TR>
+<TR>
+<TD><B><A HREF="dump.html"><CODE>dump</CODE></A></B></TD>
+<TD BGCOLOR=#CCFF99><B><A HREF="tkcon.html"><CODE>tkcon</CODE></A></B></TD>
+<TD><B><A HREF="idebug.html"><CODE>idebug</CODE></A></B></TD>
+<TD><B><A HREF="observe.html"><CODE>observe</CODE></A></B></TD>
+</TR>
+</TABLE>
+
+ <P>
+This provides lots of useful control over a console:
+
+<DL>
+
+<DT> <CODE>tkcon attach</CODE> <I>interpreter</I>
+<DD> Attaches TkCon to the named interpreter. The name must be that
+returned by <CODE>[tk appname]</CODE> or a valid path to a slave
+interpreter. It's best to use this via the <CODE>Console->Attach
+Console</CODE> menu.
+
+<DT> <CODE>tkcon buffer</CODE> ?<I>size</I>?
+<DD> 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).
+
+<DT> <CODE>tkcon bgerror</CODE> ?<I>msg errorInfo</I>?
+<DD> Does bgerror stuff in the TkCon master interpreter.
+
+<DT> <CODE>tkcon close</CODE> or <CODE>tkcon destroy</CODE>
+<DD> Destroys this TkCon widget.
+
+<DT> <CODE>tkcon console</CODE> <I>args</I>
+<DD> Passes the args to the TkCon text widget (the console).
+
+<DT> <CODE>tkcon error</CODE>
+<DD> Pops up a dialog that gives the user a full trace of the last error
+received in the TkCon console.
+
+<DT> <CODE>tkcon find</CODE> <I>string ?-case TCL_BOOLEAN
+-regexp TCL_BOOLEAN?</I>
+<DD> Highlights all instances of <I>string</I> in the console. If the string
+is empty, it clears any previous highlighting.
+
+<DT> <CODE>tkcon font</CODE> ?<I>fontname</I>?
+<DD> Sets or returns the font used by tkcon text widgets.
+
+<DT> <CODE>tkcon gets</CODE> ?<I>varname</I>?
+<DD> Behaves like the traditional Tcl <code>gets</code>, but uses the
+TkCon console instead of <code>stdin</code>.
+
+<DT> <CODE>tkcon hide</CODE>
+<DD> Withdraw the TkCon display from the screen (make sure you have
+a way to get it back).
+
+<DT> <CODE>tkcon history</CODE> ?<i>-newline</i>?
+<DD> Displays the TkCon history in sourceable form. If <i>-newline</i> is
+specified, it separates each command by an extra newline.
+
+<DT> <CODE>tkcon iconify</CODE>
+<DD> Iconifies the TkCon display.
+
+<DT> <CODE>tkcon load</CODE> <I>filename</I>
+<DD> Sources named file into the slave interpreter. If no filename is
+given, it will attempt to call <CODE>tk_getOpenFile</CODE> to pop up the
+file select box.
+
+<DT> <CODE>tkcon main</CODE> ?<I>arg arg ...</I>?
+<DD> Passes the args to the main TkCon interpreter to be evaluated and
+returns the result.
+
+<DT> <CODE>tkcon master</CODE> <I>args</I>
+<DD> Passes the args to the master interpreter to be evaluated and
+returns the result.
+
+<DT> <CODE>tkcon new</CODE>
+<DD> Creates a new TkCon widget.
+
+<DT> <CODE>tkcon save</CODE> ?<I>filename</I> ?<I>type</I>??
+<DD> Saves the console buffer to the given filename. If no filename is
+given, it will attempt to call <CODE>tk_getSaveFile</CODE> 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.
+
+<DT> <CODE>tkcon set</CODE> <I>var ?value?</I>
+<DD> Queries or sets a master interpreter variable.
+
+<DT> <CODE>tkcon append</CODE> <I>var ?value?</I>
+<DD> Like set, but uses <CODE>append</CODE> on the variable.
+
+<DT> <CODE>tkcon lappend</CODE> <I>var ?value?</I>
+<DD> Like set, but uses <CODE>lappend</CODE> on the variable.
+
+<DT> <CODE>tkcon show</CODE> or <CODE>tkcon deiconify</CODE>
+<DD> Redisplays TkCon on the screen.
+
+<DT> <CODE>tkcon slave</CODE> ?<I>slavename ?arg arg ...?</I>?
+<DD> 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 <CODE>[tk appname]</CODE>
+of that interpreter.
+
+<DT> <CODE>tkcon title</CODE> ?<I>title</I>?
+<DD> Sets or returns the title for TkCon.
+
+<DT> <CODE>tkcon version</CODE>
+<DD> Returns of version of TkCon.
+
+</DL>
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+<HTML>
+<HEAD>
+<TITLE>TkCon: To Do Ideas</TITLE>
+</HEAD>
+
+<BODY BGCOLOR=#FFFFFF>
+<H1>TkCon: To Do Ideas</H1>
+
+<TABLE COLS=4 BORDER=0 CELLPADDING=1 CELLSPACING=3 BGCOLOR=#CCCCCC>
+<TR>
+<TD><B><A HREF="index.html">TkCon Docs</A></B></TD>
+<TD><B><A HREF="purpose.html">Purpose & Features</A></B></TD>
+<TD><B><A HREF="limits.html">Limitations</A></B></TD>
+<TD BGCOLOR=#FFFF33><B><A HREF="todo.html">To Do</A></B></TD>
+</TR>
+<TD><B><A HREF="changes.txt">Changes</A></B></TD>
+<TD><B><A HREF="license.terms">License Terms</A></B></TD>
+<TD COLSPAN=2><B><A HREF="nontcl.html">Using TkCon with other Tk Languages</A></B></TD>
+</TR>
+</TABLE>
+
+<H3>Future Ideas</H3>
+
+<UL>
+<LI> Add encoding auto-conversion to exec commands
+<LI> keep history file, also keep history of sourced files
+<LI> <PRE>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
+}</PRE>
+
+<LI> Add socket level communication model
+<LI> Enhance the true debugging capabilities - I'm looking at
+tcl-debug and into what I can adopt from the tkInspect philosophy.
+<LI> I'm taking ideas...
+</UL>
+
+<H3>Known Bugs/Quirks</H3>
+
+<UL>
+<LI> Command highlighting isn't perfect because I try to make it too
+efficient.
+<LI> All interpreters have the same current working directory. This is
+a limitation of tcl.
+<LI> You can't 'attach' on machines where <CODE>send</CODE> does not exist.
+<A HREF="http://www.osf.org/~loverso/">John Loverso</A> has a comm.tcl
+replacement.
+In any case, you can still attach to internal interpreters and namespaces.
+<LI> Need to clean up checkpointed states when the associated interp dies.
+Works with slaves, but not foreign interps.
+<LI> Can't identify non-Tcl or pre-Tk4 interpreters automagically...
+<LI> You tell me...
+</UL>
+
+<HR NOSHADE SIZE=1>
+<ADDRESS><FONT SIZE=2>©
+<A HREF="mailto:jeff.hobbs@acm.org">Jeffrey Hobbs</A></FONT></ADDRESS>
+
+</BODY>
+</HTML>
--- /dev/null
+##
+## 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 <window pathname> <options>
+##
+## 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)
+##
+## <<Console_ExpandFile>> <Key-Tab>
+## <<Console_ExpandProc>> <Control-Shift-Key-P>
+## <<Console_ExpandVar>> <Control-Shift-Key-V>
+## <<Console_Tab>> <Control-Key-i>
+## <<Console_Eval>> <Key-Return> <Key-KP_Enter>
+##
+## <<Console_Clear>> <Control-Key-l>
+## <<Console_KillLine>> <Control-Key-k>
+## <<Console_Transpose>> <Control-Key-t>
+## <<Console_ClearLine>> <Control-Key-u>
+## <<Console_SaveCommand>> <Control-Key-z>
+##
+## <<Console_Previous>> <Key-Up>
+## <<Console_Next>> <Key-Down>
+## <<Console_NextImmediate>> <Control-Key-n>
+## <<Console_PreviousImmediate>> <Control-Key-p>
+## <<Console_PreviousSearch>> <Control-Key-r>
+## <<Console_NextSearch>> <Control-Key-s>
+##
+## <<Console_Exit>> <Control-Key-q>
+## <<Console_New>> <Control-Key-N>
+## <<Console_Close>> <Control-Key-w>
+## <<Console_About>> <Control-Key-A>
+## <<Console_Help>> <Control-Key-H>
+## <<Console_Find>> <Control-Key-F>
+##
+## 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 <Destroy> "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 <Configure> {
+ 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] <Button-3> "tk_popup $w.pop %X %Y"
+
+ pack [menubutton $w.con -text "Console" -un 0 -menu $w.con.m] -side left
+ $w.pop add cascade -label "Console" -un 0 -menu $w.pop.con
+
+ pack [menubutton $w.edit -text "Edit" -un 0 -menu $w.edit.m] -side left
+ $w.pop add cascade -label "Edit" -un 0 -menu $w.pop.edit
+
+ pack [menubutton $w.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 <<Console_Close>>] -com [list destroy $W]
+ $m add command -label "Clear Console " -un 1 \
+ -acc [event info <<Console_Clear>>] -com [list Console_clear $W]
+ $m add separator
+ $m add command -label "Quit" -un 0 -acc [event info <<Console_Exit>>] \
+ -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 <<Cut>>] 0] \
+ -command [list ConsoleCut $text]
+ $m add command -label "Copy" -un 1 \
+ -acc [lindex [event info <<Copy>>] 0] \
+ -command [list ConsoleCopy $text]
+ $m add command -label "Paste" -un 0 \
+ -acc [lindex [event info <<Paste>>] 0] \
+ -command [list ConsolePaste $text]
+ $m add separator
+ $m add command -label "Find" -un 0 -acc [event info <<Console_Find>>] \
+ -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 <<Console_About>>] \
+ -command [list ConsoleAbout $W]
+ }
+
+ bind $W <<Console_Exit>> exit
+ #bind $W <<Console_New>> ConsoleNew
+ bind $W <<Console_Close>> [list destroy $W]
+ bind $W <<Console_About>> [list ConsoleAbout $W]
+ bind $W <<Console_Help>> [list ConsoleHelp $W]
+ bind $W <<Console_Find>> [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 <Return> [list $base.btn.fnd invoke]
+ bind $base.f.e <Escape> [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 !!, !<number>, 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] {<Control-Key-y> <Control-Key-w> \
+ <Meta-Key-w> <Control-Key-o> <Control-Key-v> <Control-Key-c> \
+ <Control-Key-x>}] {
+ bind Console $ev [bind Text $ev]
+}
+
+foreach {ev key} {
+ <<Console_Previous>> <Key-Up>
+ <<Console_Next>> <Key-Down>
+ <<Console_NextImmediate>> <Control-Key-n>
+ <<Console_PreviousImmediate>> <Control-Key-p>
+ <<Console_PreviousSearch>> <Control-Key-r>
+ <<Console_NextSearch>> <Control-Key-s>
+
+ <<Console_ExpandFile>> <Key-Tab>
+ <<Console_ExpandProc>> <Control-Shift-Key-P>
+ <<Console_ExpandVar>> <Control-Shift-Key-V>
+ <<Console_Tab>> <Control-Key-i>
+ <<Console_Eval>> <Key-Return>
+ <<Console_Eval>> <Key-KP_Enter>
+
+ <<Console_Clear>> <Control-Key-l>
+ <<Console_KillLine>> <Control-Key-k>
+ <<Console_Transpose>> <Control-Key-t>
+ <<Console_ClearLine>> <Control-Key-u>
+ <<Console_SaveCommand>> <Control-Key-z>
+
+ <<Console_Exit>> <Control-Key-q>
+ <<Console_New>> <Control-Key-N>
+ <<Console_Close>> <Control-Key-w>
+ <<Console_About>> <Control-Key-A>
+ <<Console_Help>> <Control-Key-H>
+ <<Console_Find>> <Control-Key-F>
+} {
+ event add $ev $key
+ bind Console $key {}
+}
+catch {unset ev key}
+
+## Redefine for Console what we need
+##
+event delete <<Paste>> <Control-V>
+ConsoleClipboardKeysyms <Copy> <Cut> <Paste>
+
+bind Console <Insert> {catch {ConsoleInsert %W [selection get -displayof %W]}}
+
+bind Console <Triple-1> {+
+catch {
+ eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
+ %W mark set insert sel.first
+}
+}
+
+bind Console <<Console_ExpandFile>> {
+ if [%W compare insert > limit] {Console:expand %W path}
+ break
+}
+bind Console <<Console_ExpandProc>> {
+ if [%W compare insert > limit] {Console:expand %W proc}
+}
+bind Console <<Console_ExpandVar>> {
+ if [%W compare insert > limit] {Console:expand %W var}
+}
+bind Console <<Console_Tab>> {
+ if [%W compare insert >= limit] {
+ ConsoleInsert %W \t
+ }
+}
+bind Console <<Console_Eval>> {
+ ConsoleEval %W
+}
+bind Console <Delete> {
+ if {[string comp {} [%W tag nextrange sel 1.0 end]] \
+ && [%W compare sel.first >= limit]} {
+ %W delete sel.first sel.last
+ } elseif {[%W compare insert >= limit]} {
+ %W delete insert
+ %W see insert
+ }
+}
+bind Console <BackSpace> {
+ if {[string comp {} [%W tag nextrange sel 1.0 end]] \
+ && [%W compare sel.first >= limit]} {
+ %W delete sel.first sel.last
+ } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
+ %W delete insert-1c
+ %W see insert
+ }
+}
+bind Console <Control-h> [bind Console <BackSpace>]
+
+bind Console <KeyPress> {
+ ConsoleInsert %W %A
+}
+
+bind Console <Control-a> {
+ if [%W compare {limit linestart} == {insert linestart}] {
+ tkTextSetCursor %W limit
+ } else {
+ tkTextSetCursor %W {insert linestart}
+ }
+}
+bind Console <Control-d> {
+ if [%W compare insert < limit] break
+ %W delete insert
+}
+bind Console <<Console_KillLine>> {
+ 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>> {
+ Console_clear [winfo parent %W]
+}
+bind Console <<Console_Previous>> {
+ if [%W compare {insert linestart} != {limit linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W -1]
+ } else {
+ Console_event [winfo parent %W] -1
+ }
+}
+bind Console <<Console_Next>> {
+ if [%W compare {insert linestart} != {end-1c linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W 1]
+ } else {
+ Console_event [winfo parent %W] 1
+ }
+}
+bind Console <<Console_NextImmediate>> {
+ Console_event [winfo parent %W] 1
+}
+bind Console <<Console_PreviousImmediate>> {
+ Console_event [winfo parent %W] -1
+}
+bind Console <<Console_PreviousSearch>> {
+ Console_event [winfo parent %W] -1 [ConsoleCmdGet %W]
+}
+bind Console <<Console_NextSearch>> {
+ Console_event [winfo parent %W] 1 [ConsoleCmdGet %W]
+}
+bind Console <<Console_Transpose>> {
+ ## Transpose current and previous chars
+ if [%W compare insert > limit] { tkTextTranspose %W }
+}
+bind Console <<Console_ClearLine>> {
+ ## Clear command line (Unix shell staple)
+ %W delete limit end
+}
+bind Console <<Console_SaveCommand>> {
+ ## Save command buffer (swaps with current command)
+ Console:savecommand %W
+}
+catch {bind Console <Key-Page_Up> { tkTextScrollPages %W -1 }}
+catch {bind Console <Key-Prior> { tkTextScrollPages %W -1 }}
+catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
+catch {bind Console <Key-Next> { tkTextScrollPages %W 1 }}
+bind Console <$META-d> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+}
+bind Console <$META-BackSpace> {
+ if [%W compare {insert -1c wordstart} >= limit] {
+ %W delete {insert -1c wordstart} insert
+ }
+}
+bind Console <$META-Delete> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+}
+bind Console <ButtonRelease-2> {
+ if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \
+ && ![catch {selection get -displayof %W} 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 <Key-parenright> {
+ if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \( \) limit }
+}
+bind PostCon <Key-bracketright> {
+ if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \[ \] limit }
+}
+bind PostCon <Key-braceright> {
+ if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \{ \} limit }
+}
+bind PostCon <Key-quotedbl> {
+ if [string comp \\ [%W get insert-2c]] { ConsoleMatchQuote %W limit }
+}
+
+bind PostCon <KeyPress> {
+ 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
--- /dev/null
+#!/bin/sh
+# \
+exec wish4.1 "$0" ${1+"$@"}
+
+#
+## stripped.tcl
+## Stripped down version of Tk Console Widget, part of the VerTcl system
+## Stripped to work with Netscape Tk Plugin.
+##
+## Copyright (c) 1995,1996 by Jeffrey Hobbs
+## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/
+## source standard_disclaimer.tcl
+
+if {[info tclversion] < 7.5} {
+ error "TkCon requires at least the stable version of tcl7.5/tk4.1"
+}
+
+## tkConInit - inits tkCon
+# ARGS: root - widget pathname of the tkCon console root
+# title - title for the console root and main (.) windows
+# Calls: tkConInitUI
+# Outputs: errors found in tkCon resource file
+##
+proc tkConInit {{title Main}} {
+ global tkCon tcl_platform env auto_path tcl_interactive
+
+ set tcl_interactive 1
+
+ array set tkCon {
+ color,blink yellow
+ color,proc darkgreen
+ color,prompt brown
+ color,stdin black
+ color,stdout blue
+ color,stderr red
+
+ blinktime 500
+ font fixed
+ lightbrace 1
+ lightcmd 1
+ prompt1 {[history nextid] % }
+ prompt2 {[history nextid] cont > }
+ showmultiple 1
+ slavescript {}
+
+ cmd {} cmdbuf {} cmdsave {} event 1 svnt 1 cols 80 rows 24
+
+ version {0.5x Stripped}
+ base .console
+ }
+
+ if [string comp $tcl_platform(platform) unix] {
+ array set tkCon {
+ font {Courier 12 {}}
+ }
+ }
+
+ tkConInitUI $title
+
+ interp alias {} clean {} tkConStateRevert tkCon
+ tkConStateCheckpoint tkCon
+}
+
+## tkConInitUI - inits UI portion (console) of tkCon
+## Creates all elements of the console window and sets up the text tags
+# ARGS: title - title for the console root and main (.) windows
+# Calls: tkConInitMenus, tkConPrompt
+##
+proc tkConInitUI {title} {
+ global tkCon
+
+ set root $tkCon(base)
+ if [string match $root .] { set w {} } else { set w [frame $root] }
+
+ set tkCon(console) [text $w.text -font $tkCon(font) -wrap char \
+ -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin)]
+ bindtags $w.text "$w.text PreCon Console PostCon $root all"
+ set tkCon(scrolly) [scrollbar $w.sy \
+ -command "$w.text yview" -takefocus 0 -bd 1]
+
+ pack $w.sy -side left -fill y
+ set tkCon(scrollypos) left
+ pack $w.text -fill both -expand 1
+
+ $w.text insert insert "$title console display active\n" stdout
+ tkConPrompt $w.text
+
+ foreach col {prompt stdout stderr stdin proc} {
+ $w.text tag configure $col -foreground $tkCon(color,$col)
+ }
+ $w.text tag configure blink -background $tkCon(color,blink)
+
+ pack $root -fill both -expand 1
+ focus $w.text
+}
+
+## tkConEval - evaluates commands input into console window
+## This is the first stage of the evaluating commands in the console.
+## They need to be broken up into consituent commands (by tkConCmdSep) in
+## case a multiple commands were pasted in, then each is eval'ed (by
+## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed.
+# ARGS: w - console text widget
+# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd
+##
+proc tkConEval {w} {
+ global tkCon
+ tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd)
+ $w mark set insert end-1c
+ $w insert end \n
+ if [llength $cmds] {
+ foreach cmd $cmds {tkConEvalCmd $w $cmd}
+ $w insert insert $tkCon(cmd) {}
+ } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} {
+ tkConEvalCmd $w $tkCon(cmd)
+ }
+ $w see insert
+}
+
+## tkConEvalCmd - evaluates a single command, adding it to history
+# ARGS: w - console text widget
+# cmd - the command to evaluate
+# Calls: tkConPrompt
+# Outputs: result of command to stdout (or stderr if error occured)
+# Returns: next event number
+##
+proc tkConEvalCmd {w cmd} {
+ global tkCon
+ $w mark set output end
+ if [catch {uplevel \#0 history add [list $cmd] exec} result] {
+ $w insert output $result\n stderr
+ } elseif [string comp {} $result] {
+ $w insert output $result\n stdout
+ }
+ tkConPrompt $w
+ set tkCon(svnt) [set tkCon(event) [history nextid]]
+}
+
+## tkConCmdGet - gets the current command from the console widget
+# ARGS: w - console text widget
+# Returns: text which compromises current command line
+##
+proc tkConCmdGet w {
+ if [string match {} [set ix [$w tag nextrange prompt limit end]]] {
+ $w tag add stdin limit end-1c
+ return [$w get limit end-1c]
+ }
+}
+
+## tkConCmdSep - separates multiple commands into a list and remainder
+# ARGS: cmd - (possible) multiple command to separate
+# list - varname for the list of commands that were separated.
+# rmd - varname of any remainder (like an incomplete final command).
+# If there is only one command, it's placed in this var.
+# Returns: constituent command info in varnames specified by list & rmd.
+##
+proc tkConCmdSep {cmd ls rmd} {
+ upvar $ls cmds $rmd tmp
+ set tmp {}
+ set cmds {}
+ foreach cmd [split [set cmd] \n] {
+ if [string comp {} $tmp] {
+ append tmp \n$cmd
+ } else {
+ append tmp $cmd
+ }
+ if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} {
+ lappend cmds $tmp
+ set tmp {}
+ }
+ }
+ if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} {
+ set tmp [lindex $cmds end]
+ set cmds [lreplace $cmds end end]
+ }
+}
+
+## tkConPrompt - displays the prompt in the console widget
+# ARGS: w - console text widget
+# Outputs: prompt (specified in tkCon(prompt1)) to console
+##
+proc tkConPrompt w {
+ global tkCon env
+ set i [$w index end-1c]
+ $w insert end [subst $tkCon(prompt1)] prompt
+ $w mark set output $i
+ $w mark set limit insert
+ $w mark gravity limit left
+}
+
+## tkConStateCheckpoint - checkpoints the current state of the system
+## This allows you to return to this state with tkConStateRevert
+# ARGS: ary an array into which several elements are stored:
+# commands - the currently defined commands
+# variables - the current global vars
+# This is the array you would pass to tkConRevertState
+##
+proc tkConStateCheckpoint {ary} {
+ global tkCon
+ upvar $ary a
+ set a(commands) [uplevel \#0 info commands *]
+ set a(variables) [uplevel \#0 info vars *]
+ return
+}
+
+## tkConStateCompare - compare two states and output difference
+# ARGS: ary1 an array with checkpointed state
+# ary2 a second array with checkpointed state
+# Outputs:
+##
+proc tkConStateCompare {ary1 ary2} {
+ upvar $ary1 a1 $ary2 a2
+ puts "Commands unique to $ary1:\n[lremove $a1(commands) $a2(commands)]"
+ puts "Commands unique to $ary2:\n[lremove $a2(commands) $a1(commands)]"
+ puts "Variables unique to $ary1:\n[lremove $a1(variables) $a2(variables)]"
+ puts "Variables unique to $ary2:\n[lremove $a2(variables) $a1(variables)]"
+}
+
+## tkConStateRevert - reverts interpreter to a previous state
+# ARGS: ary an array with checkpointed state
+##
+proc tkConStateRevert {ary} {
+ upvar $ary a
+ tkConStateCheckpoint tmp
+ foreach i [lremove $tmp(commands) $a(commands)] { catch "rename $i {}" }
+ foreach i [lremove $tmp(variables) $a(variables)] { uplevel \#0 unset $i }
+}
+
+##
+## Some procedures to make up for lack of built-in shell commands
+##
+
+## puts
+## This allows me to capture all stdout/stderr to the console window
+# ARGS: same as usual
+# Outputs: the string with a color-coded text tag
+##
+catch {rename puts tcl_puts}
+proc puts args {
+ set len [llength $args]
+ if {$len==1} {
+ eval tkcon console insert output $args stdout {\n} stdout
+ tkcon console see output
+ } elseif {$len==2 &&
+ [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} {
+ if [string comp $tmp -nonewline] {
+ eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp
+ } else {
+ eval tkcon console insert output [lreplace $args 0 0] stdout
+ }
+ tkcon console see output
+ } elseif {$len==3 &&
+ [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} {
+ if [string comp [lreplace $args 1 2] -nonewline] {
+ eval tkcon console insert output [lrange $args 1 1] $tmp
+ } else {
+ eval tkcon console insert output [lreplace $args 0 1] $tmp
+ }
+ tkcon console see output
+ } else {
+ eval tcl_puts $args
+ }
+}
+
+## alias - akin to the csh alias command
+## If called with no args, then it prints out all current aliases
+## If called with one arg, returns the alias of that arg (or {} if none)
+# ARGS: newcmd - (optional) command to bind alias to
+# args - command and args being aliased
+##
+proc alias {{newcmd {}} args} {
+ if [string match $newcmd {}] {
+ set res {}
+ foreach a [interp aliases] {
+ lappend res [list $a: [interp alias {} $a]]
+ }
+ return [join $res \n]
+ } elseif {[string match {} $args]} {
+ interp alias {} $newcmd
+ } else {
+ eval interp alias {{}} $newcmd {{}} $args
+ }
+}
+
+## unalias - unaliases an alias'ed command
+# ARGS: cmd - command to unbind as an alias
+##
+proc unalias {cmd} {
+ interp alias {} $cmd {}
+}
+
+## tkcon - command that allows control over the console
+# ARGS: totally variable, see internal comments
+##
+proc tkcon {args} {
+ global tkCon
+ switch -- [lindex $args 0] {
+ clean {
+ ## 'cleans' the interpreter - reverting to original tkCon state
+ tkConStateRevert tkCon
+ }
+ console {
+ ## Passes the args to the text widget of the console.
+ eval $tkCon(console) [lreplace $args 0 0]
+ }
+ font {
+ ## "tkcon font ?fontname?". Sets the font of the console
+ if [string comp {} [lindex $args 1]] {
+ return [$tkCon(console) config -font [lindex $args 1]]
+ } else {
+ return [$tkCon(console) config -font]
+ }
+ }
+ version {
+ return $tkCon(version)
+ }
+ default {
+ ## tries to determine if the command exists, otherwise throws error
+ set cmd [lindex $args 0]
+ set cmd tkCon[string toup [string index $cmd 0]][string range $cmd 1 end]
+ if [string match $cmd [info command $cmd]] {
+ eval $cmd [lreplace $args 0 0]
+ } else {
+ error "bad option \"[lindex $args 0]\": must be attach,\
+ clean, console, font"
+ }
+ }
+ }
+}
+
+## clear - clears the buffer of the console (not the history though)
+## This is executed in the parent interpreter
+##
+proc clear {{pcnt 100}} {
+ if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
+ error "invalid percentage to clear: must be 1-100 (100 default)"
+ } elseif {$pcnt == 100} {
+ tkcon console delete 1.0 end
+ } else {
+ set tmp [expr $pcnt/100.0*[tkcon console index end]]
+ tkcon console delete 1.0 "$tmp linestart"
+ }
+}
+
+## dump - outputs variables/procedure/widget info in source'able form.
+## Accepts glob style pattern matching for the names
+# ARGS: type - type of thing to dump: must be variable, procedure, widget
+# OPTS: -nocomplain don't complain if no vars match something
+# Returns: the values of the variables in a 'source'able form
+##
+proc dump {type args} {
+ set whine 1
+ set code ok
+ if [string match \-n* [lindex $args 0]] {
+ set whine 0
+ set args [lreplace $args 0 0]
+ }
+ if {$whine && [string match {} $args]} {
+ error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?"
+ }
+ set res {}
+ switch -glob -- $type {
+ v* {
+ # variable
+ # outputs variables value(s), whether array or simple.
+ foreach arg $args {
+ if {[string match {} [set vars [uplevel info vars [list $arg]]]]} {
+ if {[uplevel info exists $arg]} {
+ set vars $arg
+ } elseif $whine {
+ append res "\#\# No known variable $arg\n"
+ set code error
+ continue
+ } else continue
+ }
+ foreach var [lsort $vars] {
+ upvar $var v
+ if {[array exists v]} {
+ append res "array set $var \{\n"
+ foreach i [lsort [array names v]] {
+ upvar 0 v\($i\) w
+ if {[array exists w]} {
+ append res " [list $i {NESTED VAR ERROR}]\n"
+ if $whine { set code error }
+ } else {
+ append res " [list $i $v($i)]\n"
+ }
+ }
+ append res "\}\n"
+ } else {
+ append res [list set $var $v]\n
+ }
+ }
+ }
+ }
+ p* {
+ # procedure
+ foreach arg $args {
+ if {[string comp {} [set ps [info proc $arg]]]} {
+ foreach p [lsort $ps] {
+ set as {}
+ foreach a [info args $p] {
+ if {[info default $p $a tmp]} {
+ lappend as [list $a $tmp]
+ } else {
+ lappend as $a
+ }
+ }
+ append res [list proc $p $as [info body $p]]\n
+ }
+ } elseif $whine {
+ append res "\#\# No known proc $arg\n"
+ }
+ }
+ }
+ w* {
+ # widget
+ }
+ default {
+ return -code error "bad [lindex [info level 0] 0] option\
+ \"[lindex $args 0]\":\ must be procedure, variable, widget"
+ }
+ }
+ return -code $code [string trimr $res \n]
+}
+
+## which - tells you where a command is found
+# ARGS: cmd - command name
+# Returns: where command is found (internal / external / unknown)
+##
+proc which cmd {
+ if [string comp {} [info commands $cmd]] {
+ if {[lsearch -exact [interp aliases] $cmd] > -1} {
+ return "$cmd:\taliased to [alias $cmd]"
+ } elseif [string comp {} [info procs $cmd]] {
+ return "$cmd:\tinternal proc"
+ } else {
+ return "$cmd:\tinternal command"
+ }
+ } else {
+ return "$cmd:\tunknown command"
+ }
+}
+
+## lremove - remove items from a list
+# OPTS: -all remove all instances of each item
+# ARGS: l a list to remove items from
+# is a list of items to remove
+##
+proc lremove {args} {
+ set all 0
+ if [string match \-a* [lindex $args 0]] {
+ set all 1
+ set args [lreplace $args 0 0]
+ }
+ set l [lindex $args 0]
+ eval append is [lreplace $args 0 0]
+ foreach i $is {
+ if {[set ix [lsearch -exact $l $i]] == -1} continue
+ set l [lreplace $l $ix $ix]
+ if $all {
+ while {[set ix [lsearch -exact $l $i]] != -1} {
+ set l [lreplace $l $i $i]
+ }
+ }
+ }
+ return $l
+}
+
+
+## Unknown changed to get output into tkCon window
+## See $tcl_library/init.tcl for an explanation
+##
+proc unknown args {
+ global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon
+ global errorCode errorInfo
+
+ # Save the values of errorCode and errorInfo variables, since they
+ # may get modified if caught errors occur below. The variables will
+ # be restored just before re-executing the missing command.
+
+ set savedErrorCode $errorCode
+ set savedErrorInfo $errorInfo
+ set name [lindex $args 0]
+ if ![info exists auto_noload] {
+ #
+ # Make sure we're not trying to load the same proc twice.
+ #
+ if [info exists unknown_pending($name)] {
+ unset unknown_pending($name)
+ if {[array size unknown_pending] == 0} {
+ unset unknown_pending
+ }
+ return -code error "self-referential recursion in \"unknown\" for command \"$name\"";
+ }
+ set unknown_pending($name) pending;
+ set ret [catch {auto_load $name} msg]
+ unset unknown_pending($name);
+ if {$ret != 0} {
+ return -code $ret -errorcode $errorCode \
+ "error while autoloading \"$name\": $msg"
+ }
+ if ![array size unknown_pending] {
+ unset unknown_pending
+ }
+ if $msg {
+ set errorCode $savedErrorCode
+ set errorInfo $savedErrorInfo
+ set code [catch {uplevel $args} msg]
+ if {$code == 1} {
+ #
+ # Strip the last five lines off the error stack (they're
+ # from the "uplevel" command).
+ #
+
+ set new [split $errorInfo \n]
+ set new [join [lrange $new 0 [expr [llength $new] - 6]] \n]
+ return -code error -errorcode $errorCode \
+ -errorinfo $new $msg
+ } else {
+ return -code $code $msg
+ }
+ }
+ }
+ if {[info level] == 1 && [string match {} [info script]] \
+ && [info exists tcl_interactive] && $tcl_interactive} {
+ if ![info exists auto_noexec] {
+ if [auto_execok $name] {
+ set errorCode $savedErrorCode
+ set errorInfo $savedErrorInfo
+ return [uplevel exec $args]
+ #return [uplevel exec >&@stdout <@stdin $args]
+ }
+ }
+ set errorCode $savedErrorCode
+ set errorInfo $savedErrorInfo
+ if {[string match $name !!]} {
+ catch {set tkCon(cmd) [history event]}
+ return [uplevel {history redo}]
+ } elseif [regexp {^!(.+)$} $name dummy event] {
+ catch {set tkCon(cmd) [history event $event]}
+ return [uplevel [list history redo $event]]
+ } elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] {
+ catch {set tkCon(cmd) [history substitute $old $new]}
+ return [uplevel [list history substitute $old $new]]
+ }
+ set cmds [info commands $name*]
+ if {[llength $cmds] == 1} {
+ return [uplevel [lreplace $args 0 0 $cmds]]
+ } elseif {[llength $cmds]} {
+ if {$name == ""} {
+ return -code error "empty command name \"\""
+ } else {
+ return -code error \
+ "ambiguous command name \"$name\": [lsort $cmds]"
+ }
+ }
+ }
+ return -code error "invalid command name \"$name\""
+}
+
+
+# tkConClipboardKeysyms --
+# This procedure is invoked to identify the keys that correspond to
+# the "copy", "cut", and "paste" functions for the clipboard.
+#
+# Arguments:
+# copy - Name of the key (keysym name plus modifiers, if any,
+# such as "Meta-y") used for the copy operation.
+# cut - Name of the key used for the cut operation.
+# paste - Name of the key used for the paste operation.
+
+proc tkConCut w {
+ if [string match $w [selection own -displayof $w]] {
+ clipboard clear -displayof $w
+ catch {
+ clipboard append -displayof $w [selection get -displayof $w]
+ if [$w compare sel.first >= limit] {$w delete sel.first sel.last}
+ }
+ }
+}
+proc tkConCopy w {
+ if [string match $w [selection own -displayof $w]] {
+ clipboard clear -displayof $w
+ catch {clipboard append -displayof $w [selection get -displayof $w]}
+ }
+}
+
+proc tkConPaste w {
+ if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] {
+ if [$w compare insert < limit] {$w mark set insert end}
+ $w insert insert $tmp
+ $w see insert
+ if [string match *\n* $tmp] {tkConEval $w}
+ }
+}
+
+proc tkConClipboardKeysyms {copy cut paste} {
+ bind Console <$copy> {tkConCopy %W}
+ bind Console <$cut> {tkConCut %W}
+ bind Console <$paste> {tkConPaste %W}
+}
+
+## Get all Text bindings into Console
+##
+foreach ev [lremove [bind Text] {<Control-Key-y> <Control-Key-w> \
+ <Meta-Key-w> <Control-Key-o>}] {
+ bind Console $ev [bind Text $ev]
+}
+unset ev
+
+## Redefine for Console what we need
+##
+tkConClipboardKeysyms F16 F20 F18
+tkConClipboardKeysyms Control-c Control-x Control-v
+
+bind Console <Insert> {catch {tkConInsert %W [selection get -displayof %W]}}
+
+bind Console <Up> {
+ if [%W compare {insert linestart} != {limit linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W -1]
+ } else {
+ if {$tkCon(event) == [history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ }
+ if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] {
+ incr tkCon(event)
+ } else {
+ %W delete limit end
+ %W insert limit $tkCon(tmp)
+ %W see end
+ }
+ }
+}
+bind Console <Down> {
+ if [%W compare {insert linestart} != {end-1c linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W 1]
+ } else {
+ if {$tkCon(event) < [history nextid]} {
+ %W delete limit end
+ if {[incr tkCon(event)] == [history nextid]} {
+ %W insert limit $tkCon(cmdbuf)
+ } else {
+ %W insert limit [history event $tkCon(event)]
+ }
+ %W see end
+ }
+ }
+}
+bind Console <Control-P> {
+ if [%W compare insert > limit] {tkConExpand %W proc}
+}
+bind Console <Control-V> {
+ if [%W compare insert > limit] {tkConExpand %W var}
+}
+bind Console <Control-i> {
+ if [%W compare insert >= limit] {
+ tkConInsert %W \t
+ }
+}
+bind Console <Return> {
+ tkConEval %W
+}
+bind Console <KP_Enter> [bind Console <Return>]
+bind Console <Delete> {
+ if {[string comp {} [%W tag nextrange sel 1.0 end]] \
+ && [%W compare sel.first >= limit]} {
+ %W delete sel.first sel.last
+ } elseif [%W compare insert >= limit] {
+ %W delete insert
+ %W see insert
+ }
+}
+bind Console <BackSpace> {
+ if {[string comp {} [%W tag nextrange sel 1.0 end]] \
+ && [%W compare sel.first >= limit]} {
+ %W delete sel.first sel.last
+ } elseif {[%W compare insert != 1.0] && [%W compare insert-1c >= limit]} {
+ %W delete insert-1c
+ %W see insert
+ }
+}
+bind Console <Control-h> [bind Console <BackSpace>]
+
+bind Console <KeyPress> {
+ tkConInsert %W %A
+}
+
+bind Console <Control-a> {
+ if [%W compare {limit linestart} == {insert linestart}] {
+ tkTextSetCursor %W limit
+ } else {
+ tkTextSetCursor %W {insert linestart}
+ }
+}
+bind Console <Control-d> {
+ if [%W compare insert < limit] break
+ %W delete insert
+}
+bind Console <Control-k> {
+ if [%W compare insert < limit] break
+ if [%W compare insert == {insert lineend}] {
+ %W delete insert
+ } else {
+ %W delete insert {insert lineend}
+ }
+}
+bind Console <Control-l> {
+ ## Clear console buffer, without losing current command line input
+ set tkCon(tmp) [tkConCmdGet %W]
+ clear
+ tkConPrompt
+ tkConInsert %W $tkCon(tmp)
+}
+bind Console <Control-n> {
+ ## Goto next command in history
+ if {$tkCon(event) < [history nextid]} {
+ %W delete limit end
+ if {[incr tkCon(event)] == [history nextid]} {
+ %W insert limit $tkCon(cmdbuf)
+ } else {
+ %W insert limit [history event $tkCon(event)]
+ }
+ %W see end
+ }
+}
+bind Console <Control-p> {
+ ## Goto previous command in history
+ if {$tkCon(event) == [history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ }
+ if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] {
+ incr tkCon(event)
+ } else {
+ %W delete limit end
+ %W insert limit $tkCon(tmp)
+ %W see end
+ }
+}
+bind Console <Control-r> {
+ ## Search history reverse
+ if {$tkCon(svnt) == [history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ }
+ set tkCon(tmp1) [string len $tkCon(cmdbuf)]
+ incr tkCon(tmp1) -1
+ while 1 {
+ if {[catch {history event [incr tkCon(svnt) -1]} tkCon(tmp)]} {
+ incr tkCon(svnt)
+ break
+ } elseif {![string comp $tkCon(cmdbuf) \
+ [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
+ %W delete limit end
+ %W insert limit $tkCon(tmp)
+ break
+ }
+ }
+ %W see end
+}
+bind Console <Control-s> {
+ ## Search history forward
+ set tkCon(tmp1) [string len $tkCon(cmdbuf)]
+ incr tkCon(tmp1) -1
+ while {$tkCon(svnt) < [history nextid]} {
+ if {[incr tkCon(svnt)] == [history nextid]} {
+ %W delete limit end
+ %W insert limit $tkCon(cmdbuf)
+ break
+ } elseif {![catch {history event $tkCon(svnt)} tkCon(tmp)]
+ && ![string comp $tkCon(cmdbuf) \
+ [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
+ %W delete limit end
+ %W insert limit $tkCon(tmp)
+ break
+ }
+ }
+ %W see end
+}
+bind Console <Control-t> {
+ ## Transpose current and previous chars
+ if [%W compare insert > limit] {
+ tkTextTranspose %W
+ }
+}
+bind Console <Control-u> {
+ ## Clear command line (Unix shell staple)
+ %W delete limit end
+}
+bind Console <Control-z> {
+ ## Save command buffer
+ set tkCon(tmp) $tkCon(cmdsave)
+ set tkCon(cmdsave) [tkConCmdGet %W]
+ if {[string match {} $tkCon(cmdsave)]} {
+ set tkCon(cmdsave) $tkCon(tmp)
+ } else {
+ %W delete limit end-1c
+ }
+ tkConInsert %W $tkCon(tmp)
+ %W see end
+}
+catch {bind Console <Key-Page_Up> { tkTextScrollPages %W -1 }}
+catch {bind Console <Key-Prior> { tkTextScrollPages %W -1 }}
+catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
+catch {bind Console <Key-Next> { tkTextScrollPages %W 1 }}
+bind Console <Meta-d> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+}
+bind Console <Meta-BackSpace> {
+ if [%W compare {insert -1c wordstart} >= limit] {
+ %W delete {insert -1c wordstart} insert
+ }
+}
+bind Console <Meta-Delete> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+}
+bind Console <ButtonRelease-2> {
+ if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \
+ && ![catch {selection get -displayof %W} tkCon(tmp)]} {
+ if [%W compare @%x,%y < limit] {
+ %W insert end $tkCon(tmp)
+ } else {
+ %W insert @%x,%y $tkCon(tmp)
+ }
+ if [string match *\n* $tkCon(tmp)] {tkConEval %W}
+ }
+}
+
+##
+## End weird bindings
+##
+
+##
+## PostCon bindings, for doing special things based on certain keys
+##
+bind PostCon <Key-parenright> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchPair %W \( \)
+ }
+}
+bind PostCon <Key-bracketright> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchPair %W \[ \]
+ }
+}
+bind PostCon <Key-braceright> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchPair %W \{ \}
+ }
+}
+bind PostCon <Key-quotedbl> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchQuote %W
+ }
+}
+
+bind PostCon <KeyPress> {
+ if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W }
+}
+
+## tkConTagProc - tags a procedure in the console if it's recognized
+## This procedure is not perfect. However, making it perfect wastes
+## too much CPU time... Also it should check the existence of a command
+## in whatever is the connected slave, not the master interpreter.
+##
+proc tkConTagProc w {
+ set i [$w index "insert-1c wordstart"]
+ set j [$w index "insert-1c wordend"]
+ if {[string comp {} [info command [list [$w get $i $j]]]]} {
+ $w tag add proc $i $j
+ } else {
+ $w tag remove proc $i $j
+ }
+}
+
+
+## tkConMatchPair - blinks a matching pair of characters
+## c2 is assumed to be at the text index 'insert'.
+## This proc is really loopy and took me an hour to figure out given
+## all possible combinations with escaping except for escaped \'s.
+## It doesn't take into account possible commenting... Oh well. If
+## anyone has something better, I'd like to see/use it. This is really
+## only efficient for small contexts.
+# ARGS: w - console text widget
+# c1 - first char of pair
+# c2 - second char of pair
+# Calls: tkConBlink
+##
+proc tkConMatchPair {w c1 c2} {
+ if [string comp {} [set ix [$w search -back $c1 insert limit]]] {
+ while {[string match {\\} [$w get $ix-1c]] &&
+ [string comp {} [set ix [$w search -back $c1 $ix-1c limit]]]} {}
+ set i1 insert-1c
+ while {[string comp {} $ix]} {
+ set i0 $ix
+ set j 0
+ while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} {
+ append i0 +1c
+ if {[string match {\\} [$w get $i0-2c]]} continue
+ incr j
+ }
+ if {!$j} break
+ set i1 $ix
+ while {$j &&
+ [string comp {} [set ix [$w search -back $c1 $ix limit]]]} {
+ if {[string match {\\} [$w get $ix-1c]]} continue
+ incr j -1
+ }
+ }
+ if [string match {} $ix] { set ix [$w index limit] }
+ } else { set ix [$w index limit] }
+ tkConBlink $w $ix [$w index insert]
+}
+
+## tkConMatchQuote - blinks between matching quotes.
+## Blinks just the quote if it's unmatched, otherwise blinks quoted string
+## The quote to match is assumed to be at the text index 'insert'.
+# ARGS: w - console text widget
+# Calls: tkConBlink
+##
+proc tkConMatchQuote w {
+ set i insert-1c
+ set j 0
+ while {[string comp {} [set i [$w search -back \" $i limit]]]} {
+ if {[string match {\\} [$w get $i-1c]]} continue
+ if {!$j} {set i0 $i}
+ incr j
+ }
+ if [expr $j%2] {
+ tkConBlink $w $i0 [$w index insert]
+ } else {
+ tkConBlink $w [$w index insert-1c] [$w index insert]
+ }
+}
+
+## tkConBlink - blinks between 2 indices for a specified duration.
+# ARGS: w - console text widget
+# i1 - start index to blink region
+# i2 - end index of blink region
+# dur - duration in usecs to blink for
+# Outputs: blinks selected characters in $w
+##
+proc tkConBlink {w i1 i2} {
+ global tkCon
+ $w tag add blink $i1 $i2
+ after $tkCon(blinktime) $w tag remove blink $i1 $i2
+ return
+}
+
+
+## tkConInsert
+## Insert a string into a text at the point of the insertion cursor.
+## If there is a selection in the text, and it covers the point of the
+## insertion cursor, then delete the selection before inserting.
+# ARGS: w - text window in which to insert the string
+# s - string to insert (usually just a single char)
+# Outputs: $s to text widget
+##
+proc tkConInsert {w s} {
+ if {[string match {} $s] || [string match disabled [$w cget -state]]} {
+ return
+ }
+ if [$w comp insert < limit] {
+ $w mark set insert end
+ }
+ catch {
+ if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} {
+ $w delete sel.first sel.last
+ }
+ }
+ $w insert insert $s
+ $w see insert
+}
+
+## tkConExpand -
+# ARGS: w - text widget in which to expand str
+# type - type of expansion (path / proc / variable)
+# Calls: tkConExpand(Pathname|Procname|Variable)
+# Outputs: The string to match is expanded to the longest possible match.
+# If tkCon(showmultiple) is non-zero and the user longest match
+# equaled the string to expand, then all possible matches are
+# output to stdout. Triggers bell if no matches are found.
+# Returns: number of matches found
+##
+proc tkConExpand {w type} {
+ set exp "\[^\\]\[ \t\n\r\[\{\"\$]"
+ set tmp [$w search -back -regexp $exp insert-1c limit-1c]
+ if [string compare {} $tmp] {append tmp +2c} else {set tmp limit}
+ if [$w compare $tmp >= insert] return
+ set str [$w get $tmp insert]
+ switch -glob $type {
+ pr* {set res [tkConExpandProcname $str]}
+ v* {set res [tkConExpandVariable $str]}
+ default {set res {}}
+ }
+ set len [llength $res]
+ if $len {
+ $w delete $tmp insert
+ $w insert $tmp [lindex $res 0]
+ if {$len > 1} {
+ global tkCon
+ if {$tkCon(showmultiple) && [string match [lindex $res 0] $str]} {
+ puts stdout [lreplace $res 0 0]
+ }
+ }
+ }
+ return [incr len -1]
+}
+
+## tkConExpandProcname - expand a tcl proc name based on $str
+# ARGS: str - partial proc name to expand
+# Calls: tkConExpandBestMatch
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+##
+proc tkConExpandProcname str {
+ set match [info commands $str*]
+ if {[llength $match] > 1} {
+ regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str
+ set match [linsert $match 0 $str]
+ } else {
+ regsub -all { } $match {\\ } match
+ }
+ return $match
+}
+
+## tkConExpandVariable - expand a tcl variable name based on $str
+# ARGS: str - partial tcl var name to expand
+# Calls: tkConExpandBestMatch
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+##
+proc tkConExpandVariable str {
+ if [regexp {([^\(]*)\((.*)} $str junk ary str] {
+ set match [uplevel \#0 array names $ary $str*]
+ if {[llength $match] > 1} {
+ set vars $ary\([tkConExpandBestMatch $match $str]
+ foreach var $match {lappend vars $ary\($var\)}
+ return $vars
+ } else {set match $ary\($match\)}
+ } else {
+ set match [uplevel \#0 info vars $str*]
+ if {[llength $match] > 1} {
+ regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str
+ set match [linsert $match 0 $str]
+ } else {
+ regsub -all { } $match {\\ } match
+ }
+ }
+ return $match
+}
+
+## tkConExpandBestMatch - finds the best unique match in a list of names
+## The extra $e in this argument allows us to limit the innermost loop a
+## little further. This improves speed as $l becomes large or $e becomes long.
+# ARGS: l - list to find best unique match in
+# e - currently best known unique match
+# Returns: longest unique match in the list
+##
+proc tkConExpandBestMatch {l {e {}}} {
+ set ec [lindex $l 0]
+ if {[llength $l]>1} {
+ set e [string length $e]; incr e -1
+ set ei [string length $ec]; incr ei -1
+ foreach l $l {
+ while {$ei>=$e && [string first $ec $l]} {
+ set ec [string range $ec 0 [incr ei -1]]
+ }
+ }
+ }
+ return $ec
+}
+
+
+## Initialize only if we haven't yet
+##
+if [catch {winfo exists $tkCon(base)}] tkConInit
--- /dev/null
+#!/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 <steven@indra.com>
+## Jan Nijtmans <nijtmans@nici.kun.nl>
+## 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 <Configure> {
+ scan [wm geometry [winfo toplevel %W]] "%%dx%%d" tkCon(cols) tkCon(rows)
+ }
+
+ wm title $root "tkCon $tkCon(version) $title"
+ wm deiconify $root
+ focus $w.text
+}
+
+## 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] <Button-3> "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 <Control-q> exit
+ bind all <Control-N> tkConNew
+ bind all <Control-w> tkConDestroy
+ bind all <Control-A> tkConAbout
+ bind all <Control-H> tkConHelp
+ bind all <Control-Key-1> {
+ tkConAttach {}
+ tkConPrompt \n [tkConCmdGet $tkCon(console)]
+ }
+ bind all <Control-Key-2> {
+ if [string comp {} $tkCon(name)] {
+ tkConAttach $tkCon(name)
+ } else {
+ tkConAttach Main
+ }
+ tkConPrompt \n [tkConCmdGet $tkCon(console)]
+ }
+ bind all <Control-Key-3> {
+ 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 !!, !<number>, 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] {<Control-Key-y> <Control-Key-w> \
+ <Meta-Key-w> <Control-Key-o>}] {
+ bind Console $ev [bind Text $ev]
+}
+unset ev
+
+## Redefine for Console what we need
+##
+tkConClipboardKeysyms F16 F20 F18
+tkConClipboardKeysyms Control-c Control-x Control-v
+
+bind Console <Insert> {catch {tkConInsert %W [selection get -displayof %W]}}
+
+bind Console <Up> {
+ if [%W compare {insert linestart} != {limit linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W -1]
+ } else {
+ if {$tkCon(event) == [tkConEvalSlave history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ }
+ if [catch {tkConEvalSlave \
+ history event [incr tkCon(event) -1]} tkCon(tmp)] {
+ incr tkCon(event)
+ } else {
+ %W delete limit end
+ %W insert limit $tkCon(tmp)
+ %W see end
+ }
+ }
+}
+bind Console <Down> {
+ if [%W compare {insert linestart} != {end-1c linestart}] {
+ tkTextSetCursor %W [tkTextUpDownLine %W 1]
+ } else {
+ if {$tkCon(event) < [tkConEvalSlave history nextid]} {
+ %W delete limit end
+ if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} {
+ %W insert limit $tkCon(cmdbuf)
+ } else {
+ %W insert limit [tkConEvalSlave history event $tkCon(event)]
+ }
+ %W see end
+ }
+ }
+}
+bind Console <Tab> {
+ if [%W compare insert > limit] {tkConExpand %W path}
+}
+bind Console <Control-P> {
+ if [%W compare insert > limit] {tkConExpand %W proc}
+}
+bind Console <Control-V> {
+ if [%W compare insert > limit] {tkConExpand %W var}
+}
+bind Console <Control-i> {
+ if [%W compare insert >= limit] {
+ tkConInsert %W \t
+ }
+}
+bind Console <Return> {
+ tkConEval %W
+}
+bind Console <KP_Enter> [bind Console <Return>]
+bind Console <Delete> {
+ if {[string comp {} [%W tag nextrange sel 1.0 end]] \
+ && [%W compare sel.first >= limit]} {
+ %W delete sel.first sel.last
+ } elseif [%W compare insert >= limit] {
+ %W delete insert
+ %W see insert
+ }
+}
+bind Console <BackSpace> {
+ if {[string comp {} [%W tag nextrange sel 1.0 end]] \
+ && [%W compare sel.first >= limit]} {
+ %W delete sel.first sel.last
+ } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
+ %W delete insert-1c
+ %W see insert
+ }
+}
+bind Console <Control-h> [bind Console <BackSpace>]
+
+bind Console <KeyPress> {
+ tkConInsert %W %A
+}
+
+bind Console <Control-a> {
+ if [%W compare {limit linestart} == {insert linestart}] {
+ tkTextSetCursor %W limit
+ } else {
+ tkTextSetCursor %W {insert linestart}
+ }
+}
+bind Console <Control-d> {
+ if [%W compare insert < limit] break
+ %W delete insert
+}
+bind Console <Control-k> {
+ if [%W compare insert < limit] break
+ if [%W compare insert == {insert lineend}] {
+ %W delete insert
+ } else {
+ %W delete insert {insert lineend}
+ }
+}
+bind Console <Control-l> {
+ ## Clear console buffer, without losing current command line input
+ set tkCon(tmp) [tkConCmdGet %W]
+ clear
+ tkConPrompt {} $tkCon(tmp)
+}
+bind Console <Control-n> {
+ ## Goto next command in history
+ if {$tkCon(event) < [tkConEvalSlave history nextid]} {
+ %W delete limit end
+ if {[incr tkCon(event)] == [tkConEvalSlave history nextid]} {
+ %W insert limit $tkCon(cmdbuf)
+ } else {
+ %W insert limit [tkConEvalSlave history event $tkCon(event)]
+ }
+ %W see end
+ }
+}
+bind Console <Control-p> {
+ ## Goto previous command in history
+ if {$tkCon(event) == [tkConEvalSlave history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ }
+ if [catch {tkConEvalSlave history event [incr tkCon(event) -1]} tkCon(tmp)] {
+ incr tkCon(event)
+ } else {
+ %W delete limit end
+ %W insert limit $tkCon(tmp)
+ %W see end
+ }
+}
+bind Console <Control-r> {
+ ## Search history reverse
+ if {$tkCon(svnt) == [tkConEvalSlave history nextid]} {
+ set tkCon(cmdbuf) [tkConCmdGet %W]
+ }
+ set tkCon(tmp1) [string len $tkCon(cmdbuf)]
+ incr tkCon(tmp1) -1
+ while 1 {
+ if {[catch {tkConEvalSlave \
+ history event [incr tkCon(svnt) -1]} tkCon(tmp)]} {
+ incr tkCon(svnt)
+ break
+ } elseif {![string comp $tkCon(cmdbuf) \
+ [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
+ %W delete limit end
+ %W insert limit $tkCon(tmp)
+ break
+ }
+ }
+ %W see end
+}
+bind Console <Control-s> {
+ ## Search history forward
+ set tkCon(tmp1) [string len $tkCon(cmdbuf)]
+ incr tkCon(tmp1) -1
+ while {$tkCon(svnt) < [tkConEvalSlave history nextid]} {
+ if {[incr tkCon(svnt)] == [tkConEvalSlave history nextid]} {
+ %W delete limit end
+ %W insert limit $tkCon(cmdbuf)
+ break
+ } elseif {![catch {tkConEvalSlave history event $tkCon(svnt)} tkCon(tmp)] \
+ && ![string comp $tkCon(cmdbuf) \
+ [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} {
+ %W delete limit end
+ %W insert limit $tkCon(tmp)
+ break
+ }
+ }
+ %W see end
+}
+bind Console <Control-t> {
+ ## Transpose current and previous chars
+ if [%W compare insert > limit] {
+ tkTextTranspose %W
+ }
+}
+bind Console <Control-u> {
+ ## Clear command line (Unix shell staple)
+ %W delete limit end
+}
+bind Console <Control-z> {
+ ## Save command buffer
+ set tkCon(tmp) $tkCon(cmdsave)
+ set tkCon(cmdsave) [tkConCmdGet %W]
+ if {[string match {} $tkCon(cmdsave)]} {
+ set tkCon(cmdsave) $tkCon(tmp)
+ } else {
+ %W delete limit end-1c
+ }
+ tkConInsert %W $tkCon(tmp)
+ %W see end
+}
+catch {bind Console <Key-Page_Up> { tkTextScrollPages %W -1 }}
+catch {bind Console <Key-Prior> { tkTextScrollPages %W -1 }}
+catch {bind Console <Key-Page_Down> { tkTextScrollPages %W 1 }}
+catch {bind Console <Key-Next> { tkTextScrollPages %W 1 }}
+bind Console <Meta-d> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+}
+bind Console <Meta-BackSpace> {
+ if [%W compare {insert -1c wordstart} >= limit] {
+ %W delete {insert -1c wordstart} insert
+ }
+}
+bind Console <Meta-Delete> {
+ if [%W compare insert >= limit] {
+ %W delete insert {insert wordend}
+ }
+}
+bind Console <ButtonRelease-2> {
+ if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \
+ && ![catch {selection get -displayof %W} tkCon(tmp)]} {
+ if [%W compare @%x,%y < limit] {
+ %W insert end $tkCon(tmp)
+ } else {
+ %W insert @%x,%y $tkCon(tmp)
+ }
+ if [string match *\n* $tkCon(tmp)] {tkConEval %W}
+ }
+}
+
+##
+## End weird bindings
+##
+
+##
+## Bindings for doing special things based on certain keys
+##
+bind PostCon <Key-parenright> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchPair %W \( \) limit
+ }
+}
+bind PostCon <Key-bracketright> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchPair %W \[ \] limit
+ }
+}
+bind PostCon <Key-braceright> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchPair %W \{ \} limit
+ }
+}
+bind PostCon <Key-quotedbl> {
+ if {$tkCon(lightbrace) && $tkCon(blinktime)>99 &&
+ [string comp \\ [%W get insert-2c]]} {
+ tkConMatchQuote %W limit
+ }
+}
+
+bind PostCon <KeyPress> {
+ if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W }
+}
+
+## tkConTagProc - tags a procedure in the console if it's recognized
+## This procedure is not perfect. However, making it perfect wastes
+## too much CPU time... Also it should check the existence of a command
+## in whatever is the connected slave, not the master interpreter.
+##
+proc tkConTagProc w {
+ set i [$w index "insert-1c wordstart"]
+ set j [$w index "insert-1c wordend"]
+ if {[string comp {} \
+ [tkConEvalAttached 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 {lim 1.0}} {
+ if [string comp {} [set ix [$w search -back $c1 insert $lim]]] {
+ while {[string match {\\} [$w get $ix-1c]] &&
+ [string comp {} [set ix [$w search -back $c1 $ix-1c $lim]]]} {}
+ set i1 insert-1c
+ while {[string comp {} $ix]} {
+ set i0 $ix
+ set j 0
+ while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} {
+ append i0 +1c
+ if {[string match {\\} [$w get $i0-2c]]} continue
+ incr j
+ }
+ if {!$j} break
+ set i1 $ix
+ while {$j &&
+ [string comp {} [set ix [$w search -back $c1 $ix $lim]]]} {
+ if {[string match {\\} [$w get $ix-1c]]} continue
+ incr j -1
+ }
+ }
+ if [string match {} $ix] { set ix [$w index $lim] }
+ } else { set ix [$w index $lim] }
+ tkConBlink $w $ix [$w index insert]
+}
+
+## tkConMatchQuote - blinks between matching quotes.
+## 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 {lim 1.0}} {
+ set i insert-1c
+ set j 0
+ while {[string comp {} [set i [$w search -back \" $i $lim]]]} {
+ if {[string match {\\} [$w get $i-1c]]} continue
+ if {!$j} {set i0 $i}
+ incr j
+ }
+ if [expr $j%2] {
+ tkConBlink $w $i0 [$w index insert]
+ } else {
+ tkConBlink $w [$w index insert-1c] [$w index insert]
+ }
+}
+
+## tkConBlink - blinks between 2 indices for a specified duration.
+# 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 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 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 limit]
+ if [string compare {} $tmp] {append tmp +2c} else {set tmp limit}
+ if [$w compare $tmp >= insert] return
+ set str [$w get $tmp insert]
+ switch -glob $type {
+ pa* { set res [tkConExpandPathname $str] }
+ pr* { set res [tkConExpandProcname $str] }
+ v* { set res [tkConExpandVariable $str] }
+ default {set res {}}
+ }
+ set len [llength $res]
+ if $len {
+ $w delete $tmp insert
+ $w insert $tmp [lindex $res 0]
+ if {$len > 1} {
+ global tkCon
+ if {$tkCon(showmultiple) && [string match [lindex $res 0] $str]} {
+ puts stdout [lreplace $res 0 0]
+ }
+ }
+ } else bell
+ return [incr len -1]
+}
+
+## tkConExpandPathname - expand a file pathname based on $str
+## This is based on UNIX file name conventions
+# ARGS: str - partial file pathname to expand
+# Calls: tkConExpandBestMatch
+# Returns: list containing longest unique match followed by all the
+# possible further matches
+##
+proc tkConExpandPathname str {
+ set pwd [tkConEvalAttached pwd]
+ if [catch {tkConEvalAttached cd [file dir $str]} err] {
+ return -code error $err
+ }
+ if [catch {lsort [tkConEvalAttached glob [file tail $str]*]} m] {
+ set match {}
+ } else {
+ if {[llength $m] > 1} {
+ set tmp [tkConExpandBestMatch $m [file tail $str]]
+ if [string match ?*/* $str] {
+ set tmp [file dir $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 dir $str]/$match
+ } elseif [string match /* $str] {
+ set match /$match
+ }
+ regsub -all { } $match {\\ } match
+ ## Why is this one needed and the ones below aren't!!
+ set match [list $match]
+ }
+ }
+ tkConEvalAttached cd $pwd
+ return $match
+}
+
+## 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 [tkConEvalAttached info commands $str*]
+ if {[llength $match] > 1} {
+ regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str
+ set match [linsert $match 0 $str]
+ } else {
+ regsub -all { } $match {\\ } match
+ }
+ return $match
+}
+
+## 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] {
+ ## Looks like they're trying to expand an array.
+ set match [tkConEvalAttached array names $ary $str*]
+ if {[llength $match] > 1} {
+ set vars $ary\([tkConExpandBestMatch $match $str]
+ foreach var $match {lappend vars $ary\($var\)}
+ return $vars
+ } else {set match $ary\($match\)}
+ ## Space transformation avoided for array names.
+ } else {
+ set match [tkConEvalAttached info vars $str*]
+ if {[llength $match] > 1} {
+ regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str
+ set match [linsert $match 0 $str]
+ } else {
+ regsub -all { } $match {\\ } match
+ }
+ }
+ return $match
+}
+
+## tkConExpandBestMatch2 - 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 {}.
+# ARGS: l - list to find best unique match in
+# Returns: longest unique match in the list
+##
+proc tkConExpandBestMatch2 {l {e {}}} {
+ set ec [lindex $l 0]
+ if {[llength $l]>1} {
+ set ei [string length $ec]; incr ei -1
+ foreach l $l {
+ while {$ei>0 && [string first $ec $l]} {
+ set ec [string range $ec 0 [incr ei -1]]
+ }
+ }
+ }
+ return $ec
+}
+
+## 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(root)}] tkConInit
projects / tkcon / commitdiff
