From: Jeff Hobbs Date: Tue, 19 Sep 2000 18:24:43 +0000 (+0000) Subject: Initial revision X-Git-Tag: tkcon-0-52~1 X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=7788220c5d036354c81bce7384c4078dadf97a42;p=tkcon Initial revision --- 7788220c5d036354c81bce7384c4078dadf97a42 diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..7f076ee --- /dev/null +++ b/README.txt @@ -0,0 +1,42 @@ +WHAT: Enhanced Tk Console for all Tk platforms + +WHERE: http://www.purl.org/net/hobbs/tcl/script/tkcon/ + http://www.hobbs.wservice.com/tcl/script/tkcon/ + http://www.neosoft.com/tcl/ (somewhere in the devel area) + +REQUIREMENTS: Tcl 7.6 / Tk 4.2 (as least the stable versions) + Tested through Tcl/Tk8.4. + TkCon is all Tcl/Tk code, no compiling required + +TkCon is a replacement for the standard console that comes with Tk (on +Windows/Mac, but also works on Unix). TkCon provides many more features +than the standard console and works on all platforms where Tcl/Tk is +available. It is meant primarily to aid one when working with the little +details inside tcl and tk and to give Unix users the GUI console provided +by default in the Mac and Windows Tk. + +FEATURES: + Command history + Path (Unix style) / Proc / Variable name expansion + Multiple consoles, each with its own state (via multiple interpreters) + Captures stdout and stderr to console window (puts overridden) + Hot errors (click on error result to see stack trace) + Electric character matching (a la emacs) + Electric proc highlighting + Enhanced history searching + Configurable + Cut / Copy / Paste between windows (interoperates with native platform) + Communication between consoles and other Tk interpreters + (including non-tcl ones) + Works on all Tk platforms + +CONTACT: Jeffrey Hobbs, jeff.hobbs at acm.org + +GETTING STARTED: + +TkCon is a single drop-in file. On Windows, I place this on the desktop +and double-click on it instead of wish/tclsh. On Unix, I place it in a +known bin directory and run this instead of wish. I don't have a Mac... + +Documentation can be reading by starting with index.html in the docs/ +subdirectory. Happying Tcl'ing! diff --git a/docs/bindings.html b/docs/bindings.html new file mode 100755 index 0000000..9f168b0 --- /dev/null +++ b/docs/bindings.html @@ -0,0 +1,130 @@ + + +TkCon: Special Bindings + + + +

TkCon: Special Bindings

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

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

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

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

+ +

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

+ +

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

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

+ + + diff --git a/docs/changes.txt b/docs/changes.txt new file mode 100755 index 0000000..d1f96ab --- /dev/null +++ b/docs/changes.txt @@ -0,0 +1,811 @@ +ENHANCED TK CONSOLE changes +------------------------------------------------------------------------- +Changes file begun Tue May 7 19:09:51 PDT 1996 +Newest changes at top of file. Release dates between '----'s. +Changes for a particular version are BELOW the release date line. + +Attribution for code is specified after change, a preceding slash +indicates an idea/bug report attribution fixed by myself. Where +no attribution is made, assume (Hobbs). +------------------------------------------------------------------------- + +---- March 31 1999 v1.6 ---- + +Changed tkConInsert to not use catch (avoids any error generation). + +Changed if check on auto_load in tcl_unknown to an llength on the +args (from [info tclversion]) as 8.0p0 also used just one arg. + +Added -exec command line arg, so that users could do the -exec "" +trick (causes tkcon to skip multi-interpreter model) and makes it +easier to drop tkcon as a console on extended wish executables. + +Changed handling of fixed font for all tkcon text widgets, adding +new -font option, TKCON(font) var, and redoing 'tkcon font'. + +Added color,(disabled|cursor|bg) variables as per Becker's +recommendations, allowing for old defaults. + +Changed multiple instances of string comparisons with llength, +where appropriate. + +Changed dump proc to not try and auto_load a proc arg and improved +recognition of procs in namespaces. + +Added new 'what' proc to environment that tells you what a string +is recognized as. Now used in various other procs. + +Improved hot errors to not pop up edit dialog when the mouse moved. + +---- March 5 1999 v1.5 ---- + +Expanded tkConSave to support use in 'edit'. + +Added tkConGarbageCollect proc for periodic cleanup tasks +(currently, cleaning up error tags in the console widget), +with new gc-delay TKCON var. + +Revised error handling (errors are now hot in the console). + +Changed tkConExpandPathname to recognise that NT for 8.1+ is +case-sensitive, and to not change case for other Windows configs +when no further expansion was made. + +Made changes to tkConEvalOther and the aliasing of tkConEvalAttached +for "Main" for more accurate evaluation. + +Changed the conditional 'update' in tkcon_puts (that overrides the +core puts) to 'update idletasks'. This prevents problems with +using puts in fileevent triggers and such. + +Added check to prevent lower-casing during pathname expansion when +no further expansion can be made on a string. + +New auto-buffer (default 512 lines, set in TKCON(buffer)) for the +console widget. Set this ridiculously high if you liked the +text widget holding all that data. New tkcon buffer method to +go with it. + +Rewrote edit command. Previous version was mostly bogus when used +outside the original slave. + +Change tkcon error to use updated 'edit' command. + +Massaged tkConEvalOther & tkConInterpEval. + +Fixed problem with Show Last Error where a TkCon generated error +was always appearing (from Package Submenu) and moved it above +the packages submenu. + +Removed auto_execok from the slaveprocs list. + +Removed slaveappalias as it didn't work correctly. Made 'edit' +a slavealias, with tkConAttach used to determine where it was +called from + +Changed some regexps around to pass tclCheck's mistaken warnings +(tclCheck's bad matching, not bad regexps). + +Changed dump to not try widgets before commands, as otherwise +it won't automatically complain. + +Fixed pathname completion to only beep when trying to expand on a +non-existent subdirectory (instead of throwing no-directory error). + +Fixed a few notes that TclPro's checker picked up (only one actual +bug in the all switch of 'edit', otherwise it was mostly blowing +wind...). (lvirden) + +---- February 17 1999 v1.4 ---- + +Changed "changes" file to "changes.txt". + +Added edit/more/less proc that allows for the viewing/editing +and returning back to the slave of vars/procs or files. + +Modified history to not got below 0. + +lremove extended with -pattern arg. + +Added code in tcl_unknown to ask about loading Tk when someone tries +a Tk command without Tk being loaded. + +Had to change regexps because \E in Tcl8.1a2 was removed in 8.1b1 (arg!). + +Added "Make Xauth Secure" button for Unix. (heiko.federhenn@stest.ch) + +Fixed tkConInitInterp (used by "Send TkCon Commands") to reattach to +the named namespace when appropriate. + +Fixed bug in popup-menu for Tk8 (bound to wrong toplevel). + +Fixed bug in tcl_unknown confusing auto_load between 8.0 and 7.x. + +Made Interp->Package menu more dynamic, so it recognizes changes in +auto_path and updates itself when Interp is torn-off. + +Removed list from $new in exec redirect for tcl_unknown. (found by Imai) + +Changed package menu to handle multiple package versions. + +Added bogus package require statement to master and slaves to ensure +that pkgIndex.tcl files were properly loaded into interps. + +If "Main" is passed to tkConAttachNamespace, it is interpreted as "::". + +Changed "Attach Namespace" menu to provide a listbox popup when +more than $TKCON(maxmenu) namespaces are present. + +---- June 1998 v1.3 ---- + +fixed long-standing expr bug (missing '$') in tkConSafeBind - found +by TclPro! + +took out the use of tkcon_gets because it only worked for global vars. + +---- March 1998 v1.2 unreleased ---- + +updated regexps in some places to support 8.1 regexps. + +dump now outputs only non-default options for widgets. (ridgway) + +Sorted output list for multiple tab matched items. + +Several minor changes for the plugin (user should see no difference). + +Known problems with dump command understanding namespaces have been +fixed, but only for the 8.0 only version. + +Changed tkConTagProc to recognize ';' as not part of a proc name. + +Changed tkConNew to reuse slave numbers. + +Fixed problem with TKCON(exec) == {} (needed uplevel #0 instead of eval). + +On Mac, tries to source itself using -rsrc (8.0). (nijtmans) + +Changed to use 8.0 menu scheme if possible. (nijtmans) + +Changed tkConInitSlave and tkConNew to only set argv0 in new slave if it +exists (it won't in the plugin). (demailly) + +Changed tkConInit to only checkpoint state once if the slave interp +and main interp are the same (TKCON(exec) == {}). + +---- 08 October 1997 v1.1 ---- + +For Tk8, made TkCon use a fixed font {Courier, size 10} if the current +font is not of fixed type. + +Startup errors should now be found in the TkCon last error function. + +Changed the Triple-1 binding to not include last newline. + +Added fix to make sure that double-evaluation of the command line +didn't occur (might occur for commands that used vwait or something). + +TKCON(errorInfo) is now set with all the errors that occur during start-up, +so that you don't lose stack trace information. + +---- July 03 1997 v1.03 ---- + +Updated namespace eval stuff for Tk8.0b2. + +rewrote tkConSepCmd. + +ls is now "dir -full" by default. + +changed the puts renaming from tcl_puts to tkcon_tcl_puts (so that it +specifies what renamed it). + +added variable highlighting to command highlighting as a background (so +that a command and var can be seen for the same word). + +increased default history size to 48. + +Fixed problem where aliased exit couldn't take extra args. + +replaced old [tkcon gets] with a new UI version to be used with the new +tkcon_gets that, like tkcon_puts, replaces the Tcl gets with a version that +doesn't rely on stdin being present. [tkcon gets] now accepts no args. + **** POTENTIAL INCOMPATIBILITY **** + +---- June 10 1997 v1.02 ---- + +Changed calculator mode commands to be put in the history (but the +output still looks like an error). + +Fixed bug where "source" was assumed to work for primary interp, +causing failure to load in Tk plugin. + +Fixed problem with the id'ing of the primary TkCon interpreter that would +affect attaching to like named interps. + +---- June 8 1997 v1.01 ---- + +minor streamlining in tkConEvalCmd. + +added file menu and separated some items from console menu. + +added support for connecting directly to a namespace (itcl or Tcl8). + +Fixed several potential problems where args to tkConEvalAttached where +not properly protected from eval. + +added slaveexit variable to allow for exit in slaves to be non-destructive, +which is the new default. + +enhanced Tab binding, made Escape the default pathname-only expansion. + +enhanced dump and which commands. + +Removed auto_execok redefinition for Tcl7.5-. TkCon is now intended to +only run in Tcl7.6+ interpreters (though attaching to 7.5- is still OK). + +Added Load/Save menus and expanded Save functionality. + +---- June 1 1997 v1.00 ---- + +TkCon now use virtual events for bindings (REQUIRES TK4.2+) and changed +Console to TkConsole (to not conflict with new Console megawidget). + +Updated tcl_unknown to match Tcl8's unknown. + +Changed handling of preferences directory for macintosh. + **** POTENTIAL INCOMPATIBILITY **** + +Changed tkCon global var to TKCON. + **** POTENTIAL INCOMPATIBILITY **** + +Changed colors to use absolute #RRGGBB format for color-name disadvantaged +systems. + +Removed use of tkCon(font) variable. + **** POTENTIAL INCOMPATIBILITY **** + +Fixed procname expansion to work on/in namespaces. + +Fixed pathname expansion to expand on a directory. + +Fixed all if's to use {}s (better for Tcl8). + +Fixed potential paste problems, it now tries to get the general selection +first, then the CLIPBOARD selection. + +Fixed problem with 'puts' being renamed too early. + +Added calcmode variable to allow typing expr commands write at the tkCon +command line without always saying expr (handled in tkConEvalCmd). + +---- no official release v0.72 ---- + +Changed tkConAbout to use text widget so info could be selected. + +Fixed problem with pathname expansion on windows due to case insensitivity. +(how can anyone work with such an insensitive OS?) + +Fixed off-by-one error in history substitution reported by +. + +Fixed error in the handling of packages with a space in the name. + +Removed general return of output from rcfile, now only errors are returned. + +New tkConEvent proc to handle event movement, fixed search event problem +where cached event would become incorrect. + +new blinkrange variable to change electric bracing style. + +---- December 20th 1996 v0.71 ---- + +changed to not use upvar for nested arrays (bad for Tcl8). + +catch package require statement for detecting loadable libraries. + +---- November 15th 1996 v0.70 ---- + +Fixed problem with virtual event C/C/P bindings. (reported by +robin@jessikat.demon.co.uk) + +---- November 15th 1996 v0.69 ---- + +Added auto_execok to tkCon(slaveprocs), fixes "unknown" command bug. + +Fix for 'event' to work with plugin. (nijtmans) + +Added '--' and '-filter' options to 'dump'. + +---- November 13th 1996 v0.68 ---- + +Added $tk_library to auto_path for safe slaves loading Tk. (nijtmans) + +Made "r" the default mode for tkConSafeOpen. (nijtmans) + +Changed global delcarations in tkConInit to avoid conflicts with +Nijtmans' plus patch. + +---- November 11th 1996 v0.67 ---- + +Fixed weird backslashing in tkConSafeWindow + +---- November 8th 1996 v0.66 ---- + +Further changes for Tk plugin compatibility. (nijtmans) + +---- November 7th 1996 v0.65 ---- + +Started to add to plugin compatible code. (nijtmans) + +Reworked tkConFind* to accept optional args. + +Added History menu which display last ten commands in history. + +Removed 'auto_execpath' and changed for new version of 'auto_execok' (in +'which' and 'unknown'), which will be redefined when TkCon is run in Tcl7.5. + +The attached environment is now checkpointed at startup (by default +this is the slave). + +Fixed 'dump var' to use list when printing out nested array elements + +Added 'update' to puts, as well as better error reporting for tcl_puts. +(nijtmans) + +Improved bracing around elseif statements. + +Removed 'warn' alias from distribution. Seemed superfluous. + +Added support for requiring Tk in Tcl8+. + +Made TkCon use tkCon(cols) and tkCon(rows) for startup text size. + +---- September 30th 1996 v0.64 ---- + +Changed the way 'idebug' integrates with TkCon. + +Changed to require Tk of version [expr $tcl_version-3.4]. + +Fixed bug in observe_var (upvar shouldn't have had the \#0). + +Made Interp->Inspect menu disappear if TkConInspect package was not present. + +Made package handling only enabled for Tcl7.5+ interps and reworked +how packages were recognized. + +! Removed virtual events from Console bindings so that they don't screw +! up the Console bindings (temporary fix). + +Changed how initially loaded packages were detected. (nijtmans) + +Made all globals visible in tkConInit. (/nijtmans) + +---- September 23rd 1996 v0.63 ---- + +Changed 'tkConFindBox' to not screw up search string. + +---- September 20th 1996 v0.62 ---- + +Added option for automagically ignoring dead interpreter problems. (wart) + +Fixed bug for reattaching to default slave via menu. (wart) + +Changed how 'observe' spit out trace info for commands. + +Modified 'idebug' internals. + +Made 'idebug' create its own tkCon(exec) slave for maintaining history. + +Fixed long-standing bug in 'lremove' for -all switch. + +Made tkCon(SCRIPT) follow links to the true source script. + +Added 'idebug puts' and 'idebug echo' methods. + +Fixed 'idebug break' to not work at level 0. + +Removed line that could improperly set $name and placed a 'catch' +around the 'interp alias' for 'ls' in tkConInitInterp. + +tkConInit(Slave|Interp) now just 'catch'es the renaming of puts. + +Added 'tkcon set' and 'tkcon upvar' methods. (nijtmans) + +---- September 17th 1996 v0.61 ---- + +Added 'idebug' interactive debugging proc based off Stephen Uhler's all-Tcl +debugger (Oct'95 _Linux_Journal_). Should work w/ or w/o TkCon. + +Added back accidental removal of 'ls' alias in slaves. + +---- September 15th 1996 v0.60 ---- + +Added 'tkcon find str' method and find box to TkCon. + +Added 'observe{_var}' command for simple tracing of vars/cmds with +output in the TkCon console window. + +Reworked tkConFillAppsMenu to be more efficient and correct. + +Added 'echo' as an internal proc and included it in tkCon(slaveprocs). + +Removed tkCon(prompt2). + +Changed tkCon(lightcmd) default to 1 from 0. + +Improved 'tkcon error' to allow it to check the errorInfo of other apps. + +'dump var' now outputs nested array values. (loverso) + +Changed tkCon(Load|Save) to use the new Tk4.2 dialogs if available. + +Fixed tkConPrompt problem where marks were set incorrectly sometimes +when it was called by an event (such as ). + +Added bgerror to slaves and 'tkcon bgerror' method. (nijtmans) + +Added tcl_unknown along with other minor mods to get TkCon to work better +with IncrTcl. (nijtmans) + +Made binding not include the prompt. + +Add null Console bindings for the tkCon(root) bindings to avoid them +getting generated spuriously. (Hobbs / Wart) + +Added -argv/-- command line option. This has very limited use, but is very +good for wrapping TkCon around an existing application which has it's own +command line args. It resets $argv in the main interpreter to what remains +on the command line and TkCon ignores argv. This carries over to any "New +Consoles". + +Reintroduced state procedures, placed them in Interp menu. These should +only be used if you really understand what they do. + +Added 'dump command' method. Usefulness over 'dump proc' is minimal. + +Tightened up the command line args, dropped several optional switches. + +Placed all the Console bindings into tkConBindings, which is called +in tkConInitUI. + +Added 'tkConInitInterp' which places the tkCon shell commands (already +available in any tkCon slave) in the interpreter. It also rewires +puts to send the result back to tkCon. + +Fixed dead attachment problem where attaching to another interp after +being connected to a dead interp would munge the new interp's name. (H / Wart) + +Added 'tkConEvalOther' which evals in the named interpreter. + +Removed 'tkConCheckPackages'. Package handling is now separated into the +autoloading part in tkConInit and into tkConInterpMenu which determines +available static libraries and packages for an interpreter. Menus redesigned. + +Changed 'tkcon eval' to 'tkcon master' since eval gave the wrong connotation. + +Made '-nontcl' option take a TCL_BOOLEAN argument. + +Made 'which' return unknown commands as an error. + +Added button into the help window to send the help URL to netscape. + +Made history substitution spit out a correctly translated command if +evaluation doesn't return an error. + +Changed history search to use the same event id as regular command line +history. + +Added tkCon(meta) variable which varies the Meta definition based on the +platform (Unix == Meta; Win == Alt; Mac == Command) + +Added 'dump widget' method. Spits out current widget state as returned +by '.widget configure'. + +Changed 'dump proc' and 'which' to try and auto_load an unknown procedure. + +Added 'tkcon history' command to return a source'able history stack. + +Fixed off-by-one error in tkConExpand (caused expansion to not work unless +you were expanding the last thing on the line and also not if a special +char was the first on the line). + +Fixed TkCon package handling to work properly for IncrTcl. (nijtmans) + +---- July 31 1996 v0.52 ---- + +Reversed changes file to have newest at top. + +Added 'tkcon version' command. + +Fixed scoping problem when attaching to the master interpreter of a +particular console. + +Rewrote the expansion routines to handle spaces in names better (no longer +requires the user to use grouping as it puts in '\ ' for spaces). + +Fixed off-by-one bug in tkConExpandBestMatch(2). + +Rewired attachments so that when 'send' is used to attach to an app and an +error occurs, TkCon determines whether the app still exists to prevent +multiple errors from arising due to a dead attachment. If this occurs, it +prompts the user on whether to return to the primary slave or to check +periodically for the attached interpreter to come back. tkConEvalSend was +added to facilitate this. + +Command highlighting is now only attempted when a non-empty character is +inserted into the command line (%A != {}). + +Added Ctrl-2 accelerator to get attach to master interpreter of a console +and Ctrl-3 to get to attach to the Main interpreter. + +Made the attachment to Main set the tkCon(app) to Main (to get around the +menu -value {} bug) and also set tkConEvalAttached alias to 'tkConMain eval'. + +Rewrote tkConPrompt to accept "pre" and "post" args to place before and +after the prompt is printed. pre is tagged stdout, post is tagged stdin. + +Rewrote 'dump var' to recognize nested arrays, but not output them +(it's too complicated to do that in source'able form), as well as +recognize empty arrays. + +Rewrote tkConEvalCmd to keep track of errorInfo when errors occur. + +Added 'tkcon error' to display the last errorInfo. + +Changed dumpproc and dumpvar to dump (proc|var) ... + +Added -root argument to set the tkCon(root) variable explicitly. + +Changed the -(slave)eval args to append to rather than set their vars +so that they can be specified multiple times on the command line. + +Added a limit argument to tkConMatch{Quote,Pair}. + +Rewrote dumpvar to recognize a single array value name (ie: a(b)). + +Renamed default non-Unix resource filename from from tkcon.bat to tkcon.cfg. + +No longer 'catch' the renaming of puts in a slave, because we'd want to +know if that threw an error, although it never should... + +---- July 14 1996 v0.51 ---- + +Removed tkConUsage since it was never called. + +Changed tkCon(Load|Save) to use tkFileSelect, if it exists. + +Added -load and -pkg equivalents for -package. + +Added Ctrl-Key-1 binding to reattach to primary slave. + +TkCon now will create itself in a different toplevel if there are already +children of . when tkConInit is called. + +Changed tkConInitSlave not to overwrite tcl_puts in a slave if it exists. + +Created tkCon(slaveprocs) to identify what procs get dumped into a +slave each time and tkCon(slavealias) to identify what will be +aliased back into the main interpreter. + +---- July 4 1996 v0.50 ---- + +Number of history events to keep now set by tkCon(history). + +'unknown' reworked (yet again) to properly handle itself in either the slave +or another interpreter. History substition was moved into tkConEvalCmd and +made an option (via tkCon(subhistory)). + +Inlined _dir into dir/ls. It doesn't save any cycles, but it removes +the need to manage _dir. + +Fixed 'dir/ls -f' to denote executable files with a *. + +Fixed dir/ls to not die on 'dir -f '. (Thanks to steven@indra.com) + +Changed tkConExpand to stop at $ as well. + +Changed tkConTagProc binding from Console to PostCon . +It seems to miss a lot less now. + +---- July 3 1996 v0.49 ---- + +Slight mod to . + +Fixed binding to not allow deletions of pre-Prompt text when a +selection is made. + +Fixed tkConEvalCmd to properly send commands to foreign interpreters even +if $tkCon(nontcl) was set. + +Made tkConEvalAttached be some type of alias at all times. + +Changed 'slavescript' to 'slaveeval' and added an 'eval' option. + +---- June 25 1996 v0.48 ---- + +Fixed 'alias' problem with multiple args. + +Updated binding system to automatically set Console bindings to equivalent +Text bindings, then redefine what we want. + +Updated tkConTagProc to eval in attached slaves. This can make it +really slow when attached to foreign interpreters. + +---- June 25 1996 v0.47 ---- + +Fixed tkConExpandBest* to be more accurate ([string first] is only valid +for us when it returns 0). + +Updated tkConExpandPathname to work better for attached interpreters. + +Renamed tkExpand* to tkConExpand* (they'd become too TkCon oriented). + +Changed tkConEvalCmd to 'list' instead of 'concat' command for attached +interpreters, and to ignore the whole thing if [string match {} $cmd]. + +Removed many bindings that were exactly duplicated by "Text" binding. + +Added tkCon(blinktime) option to allow user to specify blink duration. +Value must be at least 100 (millisecs). + +Removed tkConUpDownLine. It never varied from tkTextUpDownLine. + +Improved package loading to handle bad pkgIndex.tcl entries. + +---- June 21 1996 v0.46 ---- + +Improved package loading to be correct. + +Made 'dir' more Mac/Windows friendly (I hope). + +---- June 21 1996 v0.45 (skipped v0.44) ---- + +Added "Non-Tcl Attachments" preference to disallow sends to interpreters +which may not understand Tcl (ie - SchemeTk, PerlTk). + +Rewrote tkConCheckPackages to allow calling it without a widget reference. + +Updated tkConEvalCmd. + +Added tkConEvalAttached to evaluate more things in the right place. + +Rewrote tkConAttach to allow for attaching directly to slave interpreters +(no send required). "Attach Console" menu now lists all slave interpreters +by slave path (with Tk interp name in ()s), separate from foreign interps. + +Add tkConInitSlave to create a TkCon slave. + +Renamed tkExpand* to tclExpand*. + +Updated 'dir' for better output. + +Added command line argument support, rearranged tkConInit to support it. + +---- June 18 1996 v0.43 ---- + +Fixed 'unknown' to work in both slave and master interpreter. + +Modified 'dir' to be dumpproc'ed into slave. + +Rewrote 'clear' to be dumpproc'ed as well. + +Fixed 'puts' bug for slaves. + +---- June 17 1996 v0.42 ---- + +Added extra loop to tkConCheckPackages to account for packages that may +auto-load Tk itself (like Tix or Tksteal). + +---- June 15 1996 v0.41 ---- + +Added 'warn' as an alias back into the main interpreter. + +Fixed documentation leftovers (and updated upgrade.html) to include the +move of the 'main' and 'slave' commands into 'tkcon'. + +Fixed problem in 'clear' command + +---- June 14 1996 v0.40 Released ---- + +OK, I need to add some MAJOR changes here... + +Added package handling. + +Moved to two-level interpreter model (master control/slave execution). + +---- June 13 1996 v0.38 ---- + +Fixed auto_execpath to work on windows + +---- June 11 1996 v0.37 ---- + +Improved 'tkConResource' to get the right script name on all platforms +under all manner of circumstances + +Improved sourcing of tkCon resource file to not throw bogus errors + +---- Jun 10 1996 v0.36 ---- + +Fixed bug (incr $tkCon(event) --> incr tkCon(event)) + +---- June 8 1996 v0.35 ---- + +Removed "Resource" from 'Edit' menu + +Rewrote 'clear' to accept percentage level + +Fixed forward history search bug + +---- June 6 1996 v0.34 ---- + +Added 'clean' alias to revert a slave to its "pristine" state + +Added tkConState* procs to monitor state and be able to revert it + +Enhanced 'which' and added an 'auto_execpath' proc. + +Removed all known global uses of 'tmp*' variables. + +Fixed problem in tkExpandPathname that munged pathnames with spaces. + +Fixed problem in many places where spaces in directories and command names +might get things confused. + +Fixed problem with non-interactive slaves. + +Commented out binding that recreates a deleted console window. + +Add tclindex command. + +Added support for -full to ls/dir. + +Added command buffer save and command buffer search bindings. + +Added Prefs menu. + +Changed File menu name to Console. + +Removed 'Load/Save File' command from File menu (to easy to source) and +added 'save' command. + +Changed dumpvar to use "array set ..." when outputting array values. + +Changed tkCon to use tkcon.rc on non-unix machines. + +Revamped tkConInit and source file to make sure nothing specific to tkCon +was set until an Init proc was called. + +---- May 10 1996 Made 0.27 Available to the public ---- + +---- May 8 1996 Released 0.26 Third semi-public release ---- + +tkConNew now returns the name of the newly created interpreter. + +Added 'main' and 'slave' inter-console communication commands. Also, +all slave interpreters become commands in all slave consoles (make sure +not to name procs "slave#") when created. tkConOtherInterp proc added +to handle the communication. + +Moved tkConDestroy and tkConNew into new proc tkConMainInit to prevent +resourcing problems with slave interpreters + +Fixed 'puts' bug by removing all 'uplevel subst ...' and placing an +'eval ...' at the beginning. + +---- May 7 1996 Released 0.25 Second semi-public release ---- + +Discovered bug in puts/output sequence - still searching + +Added unalias command, fixed alias command to not unalias commands if +not enough args were passed + +Updated 'unknown' to mirror current tcl7.5 'unknown' + +Changed var names inside some procs + +Added comments to most procs + +Fixed off-by-one bug in tkExpandPathname + +---- May 4 1996 Released 0.24 First semi-public release ---- + +Changes file begun Tue May 7 19:09:51 PDT 1996 diff --git a/docs/demopic.gif b/docs/demopic.gif new file mode 100755 index 0000000..83a9e3a Binary files /dev/null and b/docs/demopic.gif differ diff --git a/docs/dump.html b/docs/dump.html new file mode 100755 index 0000000..696a0f1 --- /dev/null +++ b/docs/dump.html @@ -0,0 +1,77 @@ + + +TkCon: dump procedure + + + +

TkCon: `dump` procedure

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

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

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

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

+ +

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

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

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

string match pattern
+$str

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

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

+ +

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

TkCon: `idebug` procedure

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

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

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

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

+ +

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

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

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

+ +

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

TkCon: Documentation (March 1999)

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

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

+ +

newest tkcon release (tar,gzip'ed)

+ +

Screenshot (tar,gzip'ed)

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

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

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

TkCon: Limitations

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

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

+ +

Limitations:

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

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

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

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

TkCon for Non-Tcl Users

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

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

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

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

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

+ +

Special Language Notes:

+ +

Perl Tk

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

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

TkCon: `observe` procedure

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

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

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

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

+ +

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

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

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

+ +

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

Tcl Plugin Stripped TkCon Demo

+ +Full TkCon Distribution +

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

+ +

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

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

+ +

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

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

TkCon: Procedures

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

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

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

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

+ +

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

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

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

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

TkCon: Purpose & Features

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

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

+ +

Purpose:

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

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

Features:

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

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

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

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

TkCon: Getting Started

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

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

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

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

+ +

Resource File:

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

Command Line Arguments

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

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

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

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

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

+ +

Variables:

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

color,bg +

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

color,blink +

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

color,cursor +

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

color,disabled +

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

color,proc +

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

color,var +

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

color,prompt +

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

color,stdin +

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

color,stdout +

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

color,stderr +

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

+ +

autoload +

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

blinktime +

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

blinkrange +

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

buffer +

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

calcmode +

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

cols +

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

dead +

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

font +

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

history +

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

hoterrors +

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

library +

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

lightbrace +

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

lightcmd +

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

maineval +

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

nontcl +

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

prompt1 +

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

rcfile +

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

rows +

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

scollypos +

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

showmenu +

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

showmultiple +

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

slaveeval +

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

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

+ +

slaveexit +

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

subhistory +

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

+ +

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

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

+ +

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

TkCon: `tkcon` procedure

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

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

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

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

+ +

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

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

+ +

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

TkCon: To Do Ideas

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

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

+ +

Future Ideas

+ +

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

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

+ +

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

+ +

Known Bugs/Quirks

+ +

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

+ +

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

+## +## <> +## <> +## <> +## <> +## <> +## +## <> +## <> +## <> +## <> +## <> +## <> +## +## <> +## <> +## <> +## <> +## <> +## <> +## +## METHODS +## These are the methods that the console megawidget recognizes. +## +## configure ?option? ?value option value ...? +## cget option +## Standard tk widget routines. +## +## load ?filename? +## Loads the named file into the current interpreter. +## If no file is specified, it pops up the file requester. +## +## save ?filename? +## Saves the console buffer to the named file. +## If no file is specified, it pops up the file requester. +## +## clear ?percentage? +## Clears a percentage of the console buffer (1-100). If no +## percentage is specified, the entire buffer is cleared. +## +## error +## Displays the last error in the interpreter in a dialog box. +## +## hide +## Withdraws the console from the screen +## +## history ?-newline? +## Prints out the history without numbers (basically providing a +## list of the commands you've used). +## +## show +## Deiconifies and raises the console +## +## subwidget widget +## Returns the true widget path of the specified widget. Valid +## widgets are console, scrolly, menubar. +## +## NAMESPACE & STATE +## The megawidget creates a global array with the classname, and a +## global array which is the name of each megawidget created. The latter +## array is deleted when the megawidget is destroyed. +## The procedure console and those beginning with Console are +## used. Also, when a widget is created, commands named .$widgetname +## and Console$widgetname are created. +## +## EXAMPLE USAGE: +## +## console .con -rows 24 -showmenu false +## +##------------------------------------------------------------------------ + +package require Tk + +proc megawidget {CLASS} { + upvar \#0 $CLASS class + + foreach o [array names class -*] { + foreach {name cname val} $class($o) { + if [string match -* $name] continue + option add *$CLASS.$name [uplevel \#0 [list subst $val]] widgetDefault + } + } + set class(class) $CLASS + + bind $CLASS "catch {${CLASS}_destroy %W}" + + ;proc $CLASS:eval {w method args} { + upvar \#0 $w data + set class [winfo class $w] + if [string match {} [set arg [info command ${class}_$method]]] { + set arg [info command ${class}_$method*] + } + set num [llength $arg] + if {$num==1} { + return [uplevel $arg [list $w] $args] + } elseif {$num} { + return -code error "ambiguous option \"$method\"" + } elseif {[catch {uplevel [list $data(cmd) $method] $args} err]} { + return -code error $err + } else { + return $err + } + } + + ;proc ${CLASS}_destroy w { + upvar \#0 $w data + catch { [winfo class $w]:destroy $w } + catch { rename $w {} } + catch { rename $data(cmd) {} } + catch { unset data } + } + + ;proc ${CLASS}_cget {w args} { + if {[llength $args] != 1} { + return -code error "wrong \# args: should be \"$w cget option\"" + } + upvar \#0 $w data [winfo class $w] class + if {[info exists class($args)] && [string match -* $class($args)]} { + set args $class($args) + } + if [string match {} [set arg [array names data $args]]] { + set arg [array names data ${args}*] + } + set num [llength $arg] + if {$num==1} { + return $data($arg) + } elseif {$num} { + return -code error "ambiguous option \"$args\"" + } elseif {[catch {$data(cmd) cget $args} err]} { + return -code error $err + } else { + return $err + } + } + + ;proc ${CLASS}_configure {w args} { + upvar \#0 $w data [winfo class $w] class + + set num [llength $args] + if {$num==1} { + if {[info exists class($args)] && [string match -* $class($args)]} { + set args $class($args) + } + if [string match {} [set arg [array names data $args]]] { + set arg [array names data ${args}*] + } + set num [llength $arg] + if {$num==1} { + return [list $arg $class($arg) $data($arg)] + } elseif {$num} { + return -code error "ambiguous option \"$args\"" + } elseif {[catch {$data(cmd) config $args} err]} { + return -code error $err + } else { + return $err + } + } elseif {$num} { + for {set i 0} {$i<$num} {incr i} { + set key [lindex $args $i] + if {[info exists class($key)] && [string match -* $class($key)]} { + set key $class($key) + } + if [string match {} [set arg [array names data $key]]] { + set arg [array names data $key*] + } + set val [lindex $args [incr i]] + set len [llength $arg] + if {$len==1} { + $class(class):configure $w $arg $val + } elseif {$len} { + return -code error "ambiguous option \"$args\"" + } elseif {[catch {$data(cmd) configure $key $val} err]} { + return -code error $err + } + } + return + } else { + set conf [$data(cmd) config] + foreach i [array names data -*] { + lappend conf "$i $class($i) [list $data($i)]" + } + return [lsort $conf] + } + } + + ;proc $CLASS:configure {w key value} { + puts "$w: $key configured to [list $value]" + } + + return $CLASS +} + +foreach pkg [info loaded {}] { + set file [lindex $pkg 0] + set name [lindex $pkg 1] + if {![catch {set version [package require $name]}]} { + if {[string match {} [package ifneeded $name $version]]} { + package ifneeded $name $version "load [list $file $name]" + } + } +} +catch {unset file name version} + +set Console(WWW) [info exists embed_args] + +array set Console { + -blinkcolor {blinkColor BlinkColor yellow} + -blinkrange {blinkRange BlinkRange 1} + -proccolor {procColor ProcColor darkgreen} + -promptcolor {promptColor PromptColor brown} + -stdincolor {stdinColor StdinColor black} + -stdoutcolor {stdoutColor StdoutColor blue} + -stderrcolor {stderrColor StderrColor red} + + -blinktime {blinkTime BlinkTime 500} + -cols {columns Columns 80} + -grabputs {grabPuts GrabPuts 0} + -lightbrace {lightBrace LightBrace 1} + -lightcmd {lightCmd LightCmd 1} + -rows {rows Rows 20} + -scrollypos {scrollYPos ScrollYPos right} + -showmultiple {showMultiple ShowMultiple 1} + -showmenu {showMenu ShowMenu 1} + -subhistory {subhistory SubHistory 1} + + active {} + version 1.2 + release {February 1997} + contact {jhobbs@cs.uoregon.edu} + docs {http://www.sunlabs.com/tcl/plugin/} + slavealias { console } + slaveprocs { alias dir dump lremove puts echo unknown tcl_unknown which } +} + +if [string compare unix $tcl_platform(platform)] { + set Console(-font) {font Font {Courier 14}} +} else { + set Console(-font) {font Font fixed} +} + +if $Console(WWW) { + set Console(-prompt) {prompt Prompt {\[history nextid\] % }} +} else { + set Console(-prompt) {prompt Prompt \ + {(\[file tail \[pwd\]\]) \[history nextid\] % }} +} + +megawidget Console + +## console - +# ARGS: w - widget pathname of the Console console +# args +# Calls: ConsoleInitUI +# Outputs: errors found in Console resource file +## +proc console {W args} { + set CLASS Console + upvar \#0 $W data $CLASS class + if {[winfo exists $W]} { + catch {eval destroy [winfo children $W]} + } else { + toplevel $W -class $CLASS + } + wm withdraw $W + wm title $W "Console $class(version)" + + ## User definable options + foreach o [array names class -*] { + if [string match -* $class($o)] continue + set data($o) [option get $W [lindex $class($o) 0] $CLASS] + } + + global auto_path tcl_pkgPath tcl_interactive + set tcl_interactive 1 + + ## Private variables + array set data { + appname {} cmdbuf {} cmdsave {} errorInfo {} + event 1 histid 0 find {} find,case 0 find,reg 0 + } + array set data [list class $CLASS cmd $CLASS$W \ + menubar $W.bar \ + console $W.text \ + scrolly $W.sy \ + ] + + rename $W $data(cmd) + if {[string comp {} $args] && \ + [catch {eval ${CLASS}_configure $W $args} err]} { + catch {destroy $W} + catch {unset data} + return -code error $err + } + ;proc $W args "eval $CLASS:eval [list $W] \$args" + + if {![info exists tcl_pkgPath]} { + set dir [file join [file dirname [info nameofexec]] lib] + if [string comp {} [info commands @scope]] { + set dir [file join $dir itcl] + } + catch {source [file join $dir pkgIndex.tcl]} + } + catch {tclPkgUnknown dummy-name dummy-version} + + ## Menus + frame $data(menubar) -relief raised -bd 2 + set c [text $data(console) -font $data(-font) -wrap char -setgrid 1 \ + -yscrollcomm [list $W.sy set] -foreground $data(-stdincolor) \ + -width $data(-cols) -height $data(-rows)] + bindtags $W [list $W all] + bindtags $c [list $c PreCon Console PostCon $W all] + scrollbar $data(scrolly) -takefocus 0 -bd 1 -command "$c yview" + + ConsoleInitMenus $W + + if $data(-showmenu) { pack $data(menubar) -fill x } + pack $data(scrolly) -side $data(-scrollypos) -fill y + pack $c -fill both -expand 1 + + Console:prompt $W "console display active\n" + + foreach col {prompt stdout stderr stdin proc} { + $c tag configure $col -foreground $data(-${col}color) + } + $c tag configure blink -background $data(-blinkcolor) + $c tag configure find -background $data(-blinkcolor) + + bind $c { + set W [winfo toplevel %W] + scan [wm geometry $W] "%%dx%%d" $W$-cols$ $W$-rows$ + } + wm deiconify $W + focus -force $c + + return $W +} + +;proc Console:configure { W key val } { + upvar \#0 $W data + global Console + + set truth {^(1|yes|true|on)$} + switch -- $key { + -blinkcolor { + $data(console) tag config blink -background $val + $data(console) tag config find -background $val + } + -proccolor { $data(console) tag config proc -foreground $val } + -promptcolor { $data(console) tag config prompt -foreground $val } + -stdincolor { + $data(console) tag config stdin -foreground $val + $data(console) config -foreground $val + } + -stdoutcolor { $data(console) tag config stdout -foreground $val } + -stderrcolor { $data(console) tag config stderr -foreground $val } + + -blinktime { + if ![regexp {[0-9]+} $val] { + return -code error "$key option requires an integer value" + } + } + -cols { + if [winfo exists $data(console)] { $data(console) config -width $val } + } + -font { $data(console) config -font $val } + -grabputs { + set val [regexp -nocase $truth $val] + if $val { + set Console(active) [linsert $Console(active) 0 $W] + } else { + set Console(active) [lremove -all $Console(active) $W] + } + } + -lightbrace { set val [regexp -nocase $truth $val] } + -lightcmd { set val [regexp -nocase $truth $val] } + -prompt { + if [catch {uplevel \#0 [list subst $val]} err] { + return -code error "\"$val\" threw an error:\n$err" + } + } + -rows { + if [winfo exists $data(console)] { $data(console) config -height $val } + } + -scrollypos { + if [regexp {^(left|right)$} $val junk val] { + if [winfo exists $data(scrolly)] { + pack config $data(scrolly) -side $val + } + } else { + return -code error "bad option \"$val\": must be left or right" + } + } + -showmultiple { set val [regexp -nocase $truth $val] } + -showmenu { + set val [regexp -nocase $truth $val] + if [winfo exists $data(menubar)] { + if $val { + pack $data(menubar) -fill x -before $data(console) \ + -before $data(scrolly) + } else { pack forget $data(menubar) } + } + } + -subhistory { set val [regexp -nocase $truth $val] } + } + set data($key) $val +} + +;proc Console:destroy W { + global Console + set Console(active) [lremove $Console(active) $W] +} + +## ConsoleEval - evaluates commands input into console window +## This is the first stage of the evaluating commands in the console. +## They need to be broken up into consituent commands (by ConsoleCmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## ConsoleEvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: ConsoleCmdGet, ConsoleCmdSep, ConsoleEvalCmd +## +;proc ConsoleEval {w} { + ConsoleCmdSep [ConsoleCmdGet $w] cmds cmd + $w mark set insert end-1c + $w insert end \n + if [llength $cmds] { + foreach c $cmds {ConsoleEvalCmd $w $c} + $w insert insert $cmd {} + } elseif {[info complete $cmd] && ![regexp {[^\\]\\$} $cmd]} { + ConsoleEvalCmd $w $cmd + } + $w see insert +} + +## ConsoleEvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: Console:prompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +;proc ConsoleEvalCmd {w cmd} { + ## HACK to get $W as we need it + set W [winfo parent $w] + upvar \#0 $W data + + $w mark set output end + if [string comp {} $cmd] { + set err 0 + if $data(-subhistory) { + set ev [ConsoleEvalSlave history nextid] + incr ev -1 + if {[string match !! $cmd]} { + set err [catch {ConsoleEvalSlave history event $ev} cmd] + if !$err {$w insert output $cmd\n stdin} + } elseif {[regexp {^!(.+)$} $cmd dummy event]} { + ## Check last event because history event is broken + set err [catch {ConsoleEvalSlave history event $ev} cmd] + if {!$err && ![string match ${event}* $cmd]} { + set err [catch {ConsoleEvalSlave history event $event} cmd] + } + if !$err {$w insert output $cmd\n stdin} + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { + if ![set err [catch {ConsoleEvalSlave history event $ev} cmd]] { + regsub -all -- $old $cmd $new cmd + $w insert output $cmd\n stdin + } + } + } + if $err { + $w insert output $cmd\n stderr + } else { + if [string match {} $data(appname)] { + if [catch {ConsoleEvalSlave eval $cmd} res] { + set data(errorInfo) [ConsoleEvalSlave set errorInfo] + set err 1 + } + } else { + if [catch [list ConsoleEvalAttached $cmd] res] { + if [catch {ConsoleEvalAttached set errorInfo} err] { + set data(errorInfo) {Error attempting to retrieve errorInfo} + } else { + set data(errorInfo) $err + } + set err 1 + } + } + ConsoleEvalSlave history add $cmd + if $err { + $w insert output $res\n stderr + } elseif {[string comp {} $res]} { + $w insert output $res\n stdout + } + } + } + Console:prompt $W + set data(event) [ConsoleEvalSlave history nextid] +} + +## ConsoleEvalSlave - evaluates the args in the associated slave +## args should be passed to this procedure like they would be at +## the command line (not like to 'eval'). +# ARGS: args - the command and args to evaluate +## +;proc ConsoleEvalSlave {args} { + uplevel \#0 $args +} + +## ConsoleEvalAttached +## +;proc ConsoleEvalAttached {args} { + eval uplevel \#0 $args +} + +## ConsoleCmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +;proc ConsoleCmdGet w { + if [string match {} [$w tag nextrange prompt limit end]] { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## ConsoleCmdSep - separates multiple commands into a list and remainder +# ARGS: cmd - (possible) multiple command to separate +# list - varname for the list of commands that were separated. +# rmd - varname of any remainder (like an incomplete final command). +# If there is only one command, it's placed in this var. +# Returns: constituent command info in varnames specified by list & rmd. +## +;proc ConsoleCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if [string comp {} $tmp] { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } + } + if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] + } +} + +## Console:prompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in data(-prompt)) to console +## +;proc Console:prompt {W {pre {}} {post {}} {prompt {}}} { + upvar \#0 $W data + + set w $data(console) + if [string comp {} $pre] { $w insert end $pre stdout } + set i [$w index end-1c] + if [string comp {} $data(appname)] { + $w insert end ">$data(appname)< " prompt + } + if [string comp {} $prompt] { + $w insert end $prompt prompt + } else { + $w insert end [ConsoleEvalSlave subst $data(-prompt)] prompt + } + $w mark set output $i + $w mark set insert end + $w mark set limit insert + $w mark gravity limit left + if [string comp {} $post] { $w insert end $post stdin } + $w see end +} + +## ConsoleAbout - gives about info for Console +## +;proc ConsoleAbout W { + global Console + + set w $W.about + if [winfo exists $w] { + wm deiconify $w + } else { + toplevel $w + wm title $w "About Console v$Console(version)" + button $w.b -text Dismiss -command [list wm withdraw $w] + text $w.text -height 8 -bd 1 -width 60 + pack $w.b -fill x -side bottom + pack $w.text -fill both -side left -expand 1 + $w.text tag config center -justify center + $w.text tag config title -justify center -font {Courier 18 bold} + $w.text insert 1.0 "About Console v$Console(version)\n\n" title \ + "Copyright 1995-1997 Jeffrey Hobbs, $Console(contact)\ + \nhttp://www.cs.uoregon.edu/~jhobbs/\ + \nRelease Date: v$Console(version), $Console(release)\ + \nDocumentation available at:\n$Console(docs)" center + } +} + +## ConsoleInitMenus - inits the menubar and popup for the console +# ARGS: W - console +## +;proc ConsoleInitMenus {W} { + upvar \#0 $W data + + set w $data(menubar) + set text $data(console) + + if [catch {menu $w.pop -tearoff 0}] { + label $w.label -text "Menus not available in plugin mode" + pack $w.label + return + } + bind [winfo toplevel $w] "tk_popup $w.pop %X %Y" + + pack [menubutton $w.con -text "Console" -un 0 -menu $w.con.m] -side left + $w.pop add cascade -label "Console" -un 0 -menu $w.pop.con + + pack [menubutton $w.edit -text "Edit" -un 0 -menu $w.edit.m] -side left + $w.pop add cascade -label "Edit" -un 0 -menu $w.pop.edit + + pack [menubutton $w.pref -text "Prefs" -un 0 -menu $w.pref.m] -side left + $w.pop add cascade -label "Prefs" -un 0 -menu $w.pop.pref + + pack [menubutton $w.hist -text "History" -un 0 -menu $w.hist.m] -side left + $w.pop add cascade -label "History" -un 0 -menu $w.pop.hist + + pack [menubutton $w.help -text "Help" -un 0 -menu $w.help.m] -side right + $w.pop add cascade -label "Help" -un 0 -menu $w.pop.help + + ## Console Menu + ## + foreach m [list [menu $w.con.m -disabledfore $data(-promptcolor)] \ + [menu $w.pop.con -disabledfore $data(-promptcolor)]] { + $m add command -label "Console $W" -state disabled + $m add command -label "Close Console " -un 0 \ + -acc [event info <>] -com [list destroy $W] + $m add command -label "Clear Console " -un 1 \ + -acc [event info <>] -com [list Console_clear $W] + $m add separator + $m add command -label "Quit" -un 0 -acc [event info <>] \ + -command exit + } + + ## Edit Menu + ## + foreach m [list [menu $w.edit.m] [menu $w.pop.edit]] { + $m add command -label "Cut" -un 1 \ + -acc [lindex [event info <>] 0] \ + -command [list ConsoleCut $text] + $m add command -label "Copy" -un 1 \ + -acc [lindex [event info <>] 0] \ + -command [list ConsoleCopy $text] + $m add command -label "Paste" -un 0 \ + -acc [lindex [event info <>] 0] \ + -command [list ConsolePaste $text] + $m add separator + $m add command -label "Find" -un 0 -acc [event info <>] \ + -command [list ConsoleFindBox $W] + } + + ## Prefs Menu + ## + foreach m [list [menu $w.pref.m] [menu $w.pop.pref]] { + $m add checkbutton -label "Brace Highlighting" -var $W$-lightbrace$ + $m add checkbutton -label "Command Highlighting" -var $W$-lightcmd$ + $m add checkbutton -label "History Substitution" -var $W$-subhistory$ + $m add checkbutton -label "Show Multiple Matches" -var $W$-showmultiple$ + $m add checkbutton -label "Show Menubar" -var $W$-showmenu$ \ + -command "Console:configure $W -showmenu \[set $W$-showmenu$\]" + $m add cascade -label Scrollbar -un 0 -menu $m.scroll + + ## Scrollbar Menu + ## + set m [menu $m.scroll -tearoff 0] + $m add radio -label "Left" -var $W$-scrollypos$ -value left \ + -command [list Console:configure $W -scrollypos left] + $m add radio -label "Right" -var $W$-scrollypos$ -value right \ + -command [list Console:configure $W -scrollypos right] + } + + ## History Menu + ## + foreach m [list $w.hist.m $w.pop.hist] { + menu $m -disabledfore $data(-promptcolor) \ + -postcommand [list ConsoleHistoryMenu $W $m] + } + + ## Help Menu + ## + foreach m [list [menu $w.help.m] [menu $w.pop.help]] { + $m config -disabledfore $data(-promptcolor) + $m add command -label "About " -un 0 -acc [event info <>] \ + -command [list ConsoleAbout $W] + } + + bind $W <> exit + #bind $W <> ConsoleNew + bind $W <> [list destroy $W] + bind $W <> [list ConsoleAbout $W] + bind $W <> [list ConsoleHelp $W] + bind $W <> [list ConsoleFindBox $W] + + ## Menu items need null PostCon bindings to avoid the TagProc + ## + foreach ev [bind $W] { + bind PostCon $ev { + # empty + } + } +} + +## ConsoleHistoryMenu - dynamically build the menu for attached interpreters +## +# ARGS: w - menu widget +## +;proc ConsoleHistoryMenu {W w} { + upvar \#0 $W data + + if ![winfo exists $w] return + set id [ConsoleEvalSlave history nextid] + if {$data(histid)==$id} return + set data(histid) $id + $w delete 0 end + set con $data(console) + while {($id>$data(histid)-10) && \ + ![catch {ConsoleEvalSlave history event [incr id -1]} tmp]} { + set lbl [lindex [split $tmp "\n"] 0] + if {[string len $lbl]>32} { set lbl [string range $tmp 0 30]... } + $w add command -label "$id: $lbl" -command " + $con delete limit end + $con insert limit [list $tmp] + $con see end + ConsoleEval $con + " + } +} + +## ConsoleFindBox - creates minimal dialog interface to ConsoleFind +# ARGS: w - text widget +# str - optional seed string for data(find) +## +;proc ConsoleFindBox {W {str {}}} { + upvar \#0 $W data + + set t $data(console) + set base $W.find + if ![winfo exists $base] { + toplevel $base + wm withdraw $base + wm title $base "Console Find" + + pack [frame $base.f] -fill x -expand 1 + label $base.f.l -text "Find:" + entry $base.f.e -textvar $W$find$ + pack [frame $base.opt] -fill x + checkbutton $base.opt.c -text "Case Sensitive" -variable $W$find,case$ + checkbutton $base.opt.r -text "Use Regexp" -variable $W$find,reg$ + pack $base.f.l -side left + pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1 + pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x + pack [frame $base.btn] -fill both + button $base.btn.fnd -text "Find" -width 6 + button $base.btn.clr -text "Clear" -width 6 + button $base.btn.dis -text "Dismiss" -width 6 + eval pack [winfo children $base.btn] -padx 4 -pady 2 -side left -fill both + + focus $base.f.e + + bind $base.f.e [list $base.btn.fnd invoke] + bind $base.f.e [list $base.btn.dis invoke] + } + $base.btn.fnd config -command "Console_find $W \$data(find) \ + -case \$data(find,case) -reg \$data(find,reg)" + $base.btn.clr config -command " + $t tag remove find 1.0 end + set data(find) {} + " + $base.btn.dis config -command " + $t tag remove find 1.0 end + wm withdraw $base + " + if [string comp {} $str] { + set data(find) $str + $base.btn.fnd invoke + } + + if {[string comp normal [wm state $base]]} { + wm deiconify $base + } else { raise $base } + $base.f.e select range 0 end +} + +## Console_find - searches in text widget for $str and highlights it +## If $str is empty, it just deletes any highlighting +# ARGS: W - console widget +# str - string to search for +# -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0 +# -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0 +## +;proc ConsoleFind {W str args} { + upvar \#0 $W data + set t $data(console) + $t tag remove find 1.0 end + set truth {^(1|yes|true|on)$} + set opts {} + foreach {key val} $args { + switch -glob -- $key { + -c* { if [regexp -nocase $truth $val] { set case 1 } } + -r* { if [regexp -nocase $truth $val] { lappend opts -regexp } } + default { return -code error "Unknown option $key" } + } + } + if ![info exists case] { lappend opts -nocase } + if [string match {} $str] return + $t mark set findmark 1.0 + while {[string comp {} [set ix [eval $t search $opts -count numc -- \ + [list $str] findmark end]]]} { + $t tag add find $ix ${ix}+${numc}c + $t mark set findmark ${ix}+1c + } + catch {$t see find.first} + return [expr [llength [$t tag ranges find]]/2] +} + +## Console:savecommand - saves a command in a buffer for later retrieval +# +## +;proc Console:savecommand {w} { + upvar \#0 [winfo parent $w] data + + set tmp $data(cmdsave) + set data(cmdsave) [ConsoleCmdGet $w] + if {[string match {} $data(cmdsave)]} { + set data(cmdsave) $tmp + } else { + $w delete limit end-1c + } + $w insert limit $tmp + $w see end +} + +## Console_load - sources a file into the console +# ARGS: fn - (optional) filename to source in +# Returns: selected filename ({} if nothing was selected) +## +;proc Console_load {W {fn {}}} { + if {[string match {} $fn] && + ([catch {tk_getOpenFile} fn] || [string match {} $fn])} return + ConsoleEvalAttached [list source $fn] +} + +## Console_save - saves the console buffer to a file +## This does not eval in a slave because it's not necessary +# ARGS: w - console text widget +# fn - (optional) filename to save to +## +;proc Console_save {W {fn {}}} { + upvar \#0 $W data + + if {[string match {} $fn] && + ([catch {tk_getSaveFile} fn] || [string match {} $fn])} return + if [catch {open $fn w} fid] { + return -code error "Save Error: Unable to open '$fn' for writing\n$fid" + } + puts $fid [$data(console) get 1.0 end-1c] + close $fid +} + +## clear - clears the buffer of the console (not the history though) +## +;proc Console_clear {W {pcnt 100}} { + upvar \#0 $W data + + set data(tmp) [ConsoleCmdGet $data(console)] + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + return -code error \ + "invalid percentage to clear: must be 1-100 (100 default)" + } elseif {$pcnt == 100} { + $data(console) delete 1.0 end + } else { + set tmp [expr $pcnt/100.0*[$data(console) index end]] + $data(console) delete 1.0 "$tmp linestart" + } + Console:prompt $W {} $data(tmp) +} + +;proc Console_error {W} { + ## Outputs stack caused by last error. + upvar \#0 $W data + set info $data(errorInfo) + if [string match {} $info] { set info {errorInfo empty} } + catch {destroy $W.error} + set w [toplevel $W.error] + wm title $w "Console Last Error" + button $w.close -text Dismiss -command [list destroy $w] + scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview] + text $w.text -font $data(-font) -yscrollcommand [list $w.sy set] + pack $w.close -side bottom -fill x + pack $w.sy -side right -fill y + pack $w.text -fill both -expand 1 + $w.text insert 1.0 $info + $w.text config -state disabled +} + +## Console_event - searches for history based on a string +## Search forward (next) if $int>0, otherwise search back (prev) +# ARGS: W - console widget +## +;proc Console_event {W int {str {}}} { + upvar \#0 $W data + + if !$int return + set w $data(console) + + set nextid [ConsoleEvalSlave history nextid] + if [string comp {} $str] { + ## String is not empty, do an event search + set event $data(event) + if {$int < 0 && $event == $nextid} { set data(cmdbuf) $str } + set len [string len $data(cmdbuf)] + incr len -1 + if {$int > 0} { + ## Search history forward + while {$event < $nextid} { + if {[incr event] == $nextid} { + $w delete limit end + $w insert limit $data(cmdbuf) + break + } elseif {![catch {ConsoleEvalSlave history event $event} res] \ + && ![string comp $data(cmdbuf) [string range $res 0 $len]]} { + $w delete limit end + $w insert limit $res + break + } + } + set data(event) $event + } else { + ## Search history reverse + while {![catch {ConsoleEvalSlave history event [incr event -1]} res]} { + if {![string comp $data(cmdbuf) [string range $res 0 $len]]} { + $w delete limit end + $w insert limit $res + set data(event) $event + break + } + } + } + } else { + ## String is empty, just get next/prev event + if {$int > 0} { + ## Goto next command in history + if {$data(event) < $nextid} { + $w delete limit end + if {[incr data(event)] == $nextid} { + $w insert limit $data(cmdbuf) + } else { + $w insert limit [ConsoleEvalSlave history event $data(event)] + } + } + } else { + ## Goto previous command in history + if {$data(event) == $nextid} { set data(cmdbuf) [ConsoleCmdGet $w] } + if [catch {ConsoleEvalSlave history event [incr data(event) -1]} res] { + incr data(event) + } else { + $w delete limit end + $w insert limit $res + } + } + } + $w mark set insert end + $w see end +} + +;proc Console_history {W args} { + set sub {\2} + if [string match -n* $args] { append sub "\n" } + set h [ConsoleEvalSlave history] + regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h + return $h +} + +;proc Console_hide {W} { + wm withdraw $W +} + +;proc Console_show {W} { + wm deiconify $W + raise $W +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## puts +## This allows me to capture all stdout/stderr to the console window +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +if ![catch {rename puts tcl_puts}] { + ;proc puts args { + global Console + set w [lindex $Console(active) 0].text + if {[llength $Console(active)] && [winfo exists $w]} { + set len [llength $args] + if {$len==1} { + eval $w insert output $args stdout {\n} stdout + $w see output + } elseif {$len==2 && \ + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if [string comp $tmp -nonewline] { + eval $w insert output [lreplace $args 0 0] $tmp {\n} $tmp + } else { + eval $w insert output [lreplace $args 0 0] stdout + } + $w see output + } elseif {$len==3 && \ + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if [string comp [lreplace $args 1 2] -nonewline] { + eval $w insert output [lrange $args 1 1] $tmp + } else { + eval $w insert output [lreplace $args 0 1] $tmp + } + $w see output + } else { + global errorCode errorInfo + if [catch "tcl_puts $args" msg] { + regsub tcl_puts $msg puts msg + regsub -all tcl_puts $errorInfo puts errorInfo + error $msg + } + return $msg + } + if $len update + } else { + global errorCode errorInfo + if [catch "tcl_puts $args" msg] { + regsub tcl_puts $msg puts msg + regsub -all tcl_puts $errorInfo puts errorInfo + error $msg + } + return $msg + } + } +} + +## echo +## Relaxes the one string restriction of 'puts' +# ARGS: any number of strings to output to stdout +## +proc echo args { puts [concat $args] } + +## alias - akin to the csh alias command +## If called with no args, then it dumps out all current aliases +## If called with one arg, returns the alias of that arg (or {} if none) +# ARGS: newcmd - (optional) command to bind alias to +# args - command and args being aliased +## +proc alias {{newcmd {}} args} { + if [string match {} $newcmd] { + set res {} + foreach a [interp aliases] { + lappend res [list $a -> [interp alias {} $a]] + } + return [join $res \n] + } elseif {[string match {} $args]} { + interp alias {} $newcmd + } else { + eval interp alias [list {} $newcmd {}] $args + } +} + +## dump - outputs variables/procedure/widget info in source'able form. +## Accepts glob style pattern matching for the names +# ARGS: type - type of thing to dump: must be variable, procedure, widget +# OPTS: -nocomplain +# don't complain if no vars match something +# -filter pattern +# specifies a glob filter pattern to be used by the variable +# method as an array filter pattern (it filters down for +# nested elements) and in the widget method as a config +# option filter pattern +# -- forcibly ends options recognition +# Returns: the values of the requested items in a 'source'able form +## +proc dump {type args} { + set whine 1 + set code ok + while {[string match -* $args]} { + switch -glob -- [lindex $args 0] { + -n* { set whine 0; set args [lreplace $args 0 0] } + -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] } + -- { set args [lreplace $args 0 0]; break } + default { return -code error "unknown option \"[lindex $args 0]\"" } + } + } + if {$whine && [string match {} $args]} { + return -code error "wrong \# args: [lindex [info level 0] 0]\ + ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?" + } + set res {} + switch -glob -- $type { + c* { + # command + # outpus commands by figuring out, as well as possible, what it is + # this does not attempt to auto-load anything + foreach arg $args { + if [string comp {} [set cmds [info comm $arg]]] { + foreach cmd [lsort $cmds] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + append res "\#\# ALIAS: $cmd => [interp alias {} $cmd]\n" + } elseif {[string comp {} [info procs $cmd]]} { + if {[catch {dump p -- $cmd} msg] && $whine} { set code error } + append res $msg\n + } else { + append res "\#\# COMMAND: $cmd\n" + } + } + } elseif $whine { + append res "\#\# No known command $arg\n" + set code error + } + } + } + v* { + # variable + # outputs variables value(s), whether array or simple. + if ![info exists fltr] { set fltr * } + foreach arg $args { + if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { + if {[uplevel info exists $arg]} { + set vars $arg + } elseif $whine { + append res "\#\# No known variable $arg\n" + set code error + continue + } else continue + } + foreach var [lsort $vars] { + upvar $var v + if {[array exists v]} { + set nest {} + append res "array set $var \{\n" + foreach i [lsort [array names v $fltr]] { + upvar 0 v$$i$ __ary + if {[array exists __ary]} { + append nest "\#\# NESTED ARRAY ELEMENT: $i\n" + append nest "upvar 0 [list $var$$i$] __ary;\ + [dump v -filter $fltr __ary]\n" + } else { + append res " [list $i]\t[list $v($i)]\n" + } + } + append res "\}\n$nest" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if {[string comp {} [set ps [info proc $arg]]] || + ([auto_load $arg] && + [string comp {} [set ps [info proc $arg]]])} { + foreach p [lsort $ps] { + set as {} + foreach a [info args $p] { + if {[info default $p $a tmp]} { + lappend as [list $a $tmp] + } else { + lappend as $a + } + } + append res [list proc $p $as [info body $p]]\n + } + } elseif $whine { + append res "\#\# No known proc $arg\n" + set code error + } + } + } + w* { + # widget + ## The user should have Tk loaded + if [string match {} [info command winfo]] { + return -code error "winfo not present, cannot dump widgets" + } + if ![info exists fltr] { set fltr .* } + foreach arg $args { + if [string comp {} [set ws [info command $arg]]] { + foreach w [lsort $ws] { + if [winfo exists $w] { + if [catch {$w configure} cfg] { + append res "\#\# Widget $w does not support configure method" + set code error + } else { + append res "\#\# [winfo class $w] $w\n$w configure" + foreach c $cfg { + if {[llength $c] != 5} continue + if {[regexp -nocase -- $fltr $c]} { + append res " \\\n\t[list [lindex $c 0] [lindex $c 4]]" + } + } + append res \n + } + } + } + } elseif $whine { + append res "\#\# No known widget $arg\n" + set code error + } + } + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"$type\":\ must be procedure, variable, widget" + } + } + return -code $code [string trimr $res \n] +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + if {[string comp {} [info commands $cmd]] || + ([auto_load $cmd] && [string comp {} [info commands $cmd]])} { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + return "$cmd:\taliased to [alias $cmd]" + } elseif {[string comp {} [info procs $cmd]]} { + return "$cmd:\tinternal proc" + } else { + return "$cmd:\tinternal command" + } + } elseif {[string comp {} [auto_execok $cmd]]} { + return [auto_execok $cmd] + } else { + return -code error "$cmd:\tunknown command" + } +} + +## dir - directory list +# ARGS: args - names/glob patterns of directories to list +# OPTS: -all - list hidden files as well (Unix dot files) +# -long - list in full format "permissions size date filename" +# -full - displays / after directories and link paths for links +# Returns: a directory listing +## +proc dir {args} { + array set s { + all 0 full 0 long 0 + 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx + } + while {[string match \-* [lindex $args 0]]} { + set str [lindex $args 0] + set args [lreplace $args 0 0] + switch -glob -- $str { + -a* {set s(all) 1} -f* {set s(full) 1} + -l* {set s(long) 1} -- break + default { + return -code error \ + "unknown option \"$str\", should be one of: -all, -full, -long" + } + } + } + set sep [string trim [file join . .] .] + if [string match {} $args] { set args . } + foreach arg $args { + if {[file isdir $arg]} { + set arg [string trimr $arg $sep]$sep + if $s(all) { + lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] + } else { + lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] + } + } else { + lappend out [list [file dirname $arg]$sep \ + [lsort [glob -nocomplain -- $arg]]] + } + } + if $s(long) { + set old [clock scan {1 year ago}] + set fmt "%s%9d %s %s\n" + foreach o $out { + set d [lindex $o 0] + append res $d:\n + foreach f [lindex $o 1] { + file lstat $f st + set f [file tail $f] + if $s(full) { + switch -glob $st(type) { + d* { append f $sep } + l* { append f "@ -> [file readlink $d$sep$f]" } + default { if [file exec $d$sep$f] { append f * } } + } + } + if [string match file $st(type)] { + set mode - + } else { + set mode [string index $st(type) 0] + } + foreach j [split [format %o [expr $st(mode)&0777]] {}] { + append mode $s($j) + } + if {$st(mtime)>$old} { + set cfmt {%b %d %H:%M} + } else { + set cfmt {%b %d %Y} + } + append res [format $fmt $mode $st(size) \ + [clock format $st(mtime) -format $cfmt] $f] + } + append res \n + } + } else { + foreach o $out { + set d [lindex $o 0] + append res $d:\n + set i 0 + foreach f [lindex $o 1] { + if {[string len [file tail $f]] > $i} { + set i [string len [file tail $f]] + } + } + set i [expr $i+2+$s(full)] + ## This gets the number of cols in the Console console widget + set j [expr 64/$i] + set k 0 + foreach f [lindex $o 1] { + set f [file tail $f] + if $s(full) { + switch -glob [file type $d$sep$f] { + d* { append f $sep } + l* { append f @ } + default { if [file exec $d$sep$f] { append f * } } + } + } + append res [format "%-${i}s" $f] + if {[incr k]%$j == 0} {set res [string trimr $res]\n} + } + append res \n\n + } + } + return [string trimr $res] +} +interp alias {} ls {} dir + +## lremove - remove items from a list +# OPTS: -all remove all instances of each item +# ARGS: l a list to remove items from +# args items to remove +## +proc lremove {args} { + set all 0 + if [string match \-a* [lindex $args 0]] { + set all 1 + set args [lreplace $args 0 0] + } + set l [lindex $args 0] + eval append is [lreplace $args 0 0] + foreach i $is { + if {[set ix [lsearch -exact $l $i]] == -1} continue + set l [lreplace $l $ix $ix] + if $all { + while {[set ix [lsearch -exact $l $i]] != -1} { + set l [lreplace $l $ix $ix] + } + } + } + return $l +} + +## Unknown changed to get output into Console window +# unknown: +# Invoked automatically whenever an unknown command is encountered. +# Works through a list of "unknown handlers" that have been registered +# to deal with unknown commands. Extensions can integrate their own +# handlers into the "unknown" facility via "unknown_handle". +# +# If a handler exists that recognizes the command, then it will +# take care of the command action and return a valid result or a +# Tcl error. Otherwise, it should return "-code continue" (=2) +# and responsibility for the command is passed to the next handler. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc unknown args { + global unknown_handler_order unknown_handlers errorInfo errorCode + + # + # Be careful to save error info now, and restore it later + # for each handler. Some handlers generate their own errors + # and disrupt handling. + # + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + + if {![info exists unknown_handler_order] || ![info exists unknown_handlers]} { + set unknown_handlers(tcl) tcl_unknown + set unknown_handler_order tcl + } + + foreach handler $unknown_handler_order { + set status [catch {uplevel $unknown_handlers($handler) $args} result] + + if {$status == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code $status -errorcode $errorCode \ + -errorinfo $new $result + + } elseif {$status != 4} { + return -code $status $result + } + + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + } + + set name [lindex $args 0] + return -code error "invalid command name \"$name\"" +} + +# tcl_unknown: +# Invoked when a Tcl command is invoked that doesn't exist in the +# interpreter: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc tcl_unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive Console + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if {[array size unknown_pending] == 0} { + unset unknown_pending + } + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if $ret { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {[info level] == 1 && [string match {} [info script]] \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + set new [auto_execok $name] + if {$new != ""} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec [list $new] [lrange $args 1 end]] + #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + ## + ## History substitution moved into ConsoleEvalCmd + ## + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds]} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code continue +} + +switch -glob $tcl_platform(platform) { + win* { set META Alt } + mac* { set META Command } + default { set META Meta } +} + +# ConsoleClipboardKeysyms -- +# This procedure is invoked to identify the keys that correspond to +# the "copy", "cut", and "paste" functions for the clipboard. +# +# Arguments: +# copy - Name of the key (keysym name plus modifiers, if any, +# such as "Meta-y") used for the copy operation. +# cut - Name of the key used for the cut operation. +# paste - Name of the key used for the paste operation. + +;proc ConsoleClipboardKeysyms {copy cut paste} { + bind Console <$copy> {ConsoleCopy %W} + bind Console <$cut> {ConsoleCut %W} + bind Console <$paste> {ConsolePaste %W} +} + +;proc ConsoleCut w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch { + clipboard append -displayof $w [selection get -displayof $w] + if [$w compare sel.first >= limit] {$w delete sel.first sel.last} + } + } +} +;proc ConsoleCopy w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch {clipboard append -displayof $w [selection get -displayof $w]} + } +} + +;proc ConsolePaste w { + if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] { + if [$w compare insert < limit] {$w mark set insert end} + $w insert insert $tmp + $w see insert + if [string match *\n* $tmp] {ConsoleEval $w} + } +} + +## Get all Text bindings into Console except Unix cut/copy/paste +## and newline insertion +foreach ev [lremove [bind Text] {

\ +

\ + }] { + bind Console $ev [bind Text $ev] +} + +foreach {ev key} { + <> + <> + <> + <> + <> + <> + + <> + <> + <> + <> + <> + <> + + <> + <> + <> + <> + <> + + <> + <> + <> + <> + <> + <> +} { + event add $ev $key + bind Console $key {} +} +catch {unset ev key} + +## Redefine for Console what we need +## +event delete <> +ConsoleClipboardKeysyms + +bind Console {catch {ConsoleInsert %W [selection get -displayof %W]}} + +bind Console {+ +catch { + eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] + %W mark set insert sel.first +} +} + +bind Console <> { + if [%W compare insert > limit] {Console:expand %W path} + break +} +bind Console <> { + if [%W compare insert > limit] {Console:expand %W proc} +} +bind Console <> { + if [%W compare insert > limit] {Console:expand %W var} +} +bind Console <> { + if [%W compare insert >= limit] { + ConsoleInsert %W \t + } +} +bind Console <> { + ConsoleEval %W +} +bind Console { + if {[string comp {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert >= limit]} { + %W delete insert + %W see insert + } +} +bind Console { + if {[string comp {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} { + %W delete insert-1c + %W see insert + } +} +bind Console [bind Console ] + +bind Console { + ConsoleInsert %W %A +} + +bind Console { + if [%W compare {limit linestart} == {insert linestart}] { + tkTextSetCursor %W limit + } else { + tkTextSetCursor %W {insert linestart} + } +} +bind Console { + if [%W compare insert < limit] break + %W delete insert +} +bind Console <> { + if [%W compare insert < limit] break + if [%W compare insert == {insert lineend}] { + %W delete insert + } else { + %W delete insert {insert lineend} + } +} +bind Console <> { + Console_clear [winfo parent %W] +} +bind Console <> { + if [%W compare {insert linestart} != {limit linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W -1] + } else { + Console_event [winfo parent %W] -1 + } +} +bind Console <> { + if [%W compare {insert linestart} != {end-1c linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W 1] + } else { + Console_event [winfo parent %W] 1 + } +} +bind Console <> { + Console_event [winfo parent %W] 1 +} +bind Console <> { + Console_event [winfo parent %W] -1 +} +bind Console <> { + Console_event [winfo parent %W] -1 [ConsoleCmdGet %W] +} +bind Console <> { + Console_event [winfo parent %W] 1 [ConsoleCmdGet %W] +} +bind Console <> { + ## Transpose current and previous chars + if [%W compare insert > limit] { tkTextTranspose %W } +} +bind Console <> { + ## Clear command line (Unix shell staple) + %W delete limit end +} +bind Console <> { + ## Save command buffer (swaps with current command) + Console:savecommand %W +} +catch {bind Console { tkTextScrollPages %W -1 }} +catch {bind Console { tkTextScrollPages %W -1 }} +catch {bind Console { tkTextScrollPages %W 1 }} +catch {bind Console { tkTextScrollPages %W 1 }} +bind Console <$META-d> { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } +} +bind Console <$META-BackSpace> { + if [%W compare {insert -1c wordstart} >= limit] { + %W delete {insert -1c wordstart} insert + } +} +bind Console <$META-Delete> { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } +} +bind Console { + if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \ + && ![catch {selection get -displayof %W} tkPriv(junk)]} { + if [%W compare @%x,%y < limit] { + %W insert end $tkPriv(junk) + } else { + %W insert @%x,%y $tkPriv(junk) + } + if [string match *\n* $tkPriv(junk)] {ConsoleEval %W} + } +} + +## +## End Console bindings +## + +## +## Bindings for doing special things based on certain keys +## +bind PostCon { + if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W  limit } +} +bind PostCon { + if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \[ \] limit } +} +bind PostCon { + if [string comp \\ [%W get insert-2c]] { ConsoleMatchPair %W \{ \} limit } +} +bind PostCon { + if [string comp \\ [%W get insert-2c]] { ConsoleMatchQuote %W limit } +} + +bind PostCon { + if [string comp {} %A] { ConsoleTagProc %W } +} + + +## ConsoleTagProc - tags a procedure in the console if it's recognized +## This procedure is not perfect. However, making it perfect wastes +## too much CPU time... Also it should check the existence of a command +## in whatever is the connected slave, not the master interpreter. +## +;proc ConsoleTagProc w { + upvar \#0 [winfo parent $w] data + if !$data(-lightcmd) return + set i [$w index "insert-1c wordstart"] + set j [$w index "insert-1c wordend"] + if {[string comp {} \ + [ConsoleEvalAttached info command [list [$w get $i $j]]]]} { + $w tag add proc $i $j + } else { + $w tag remove proc $i $j + } +} + +## ConsoleMatchPair - blinks a matching pair of characters +## c2 is assumed to be at the text index 'insert'. +## This proc is really loopy and took me an hour to figure out given +## all possible combinations with escaping except for escaped \'s. +## It doesn't take into account possible commenting... Oh well. If +## anyone has something better, I'd like to see/use it. This is really +## only efficient for small contexts. +# ARGS: w - console text widget +# c1 - first char of pair +# c2 - second char of pair +# Calls: Console:blink +## +;proc ConsoleMatchPair {w c1 c2 {lim 1.0}} { + upvar \#0 [winfo parent $w] data + if {!$data(-lightbrace) || $data(-blinktime)<100} return + if [string comp {} [set ix [$w search -back $c1 insert $lim]]] { + while {[string match {\\} [$w get $ix-1c]] && + [string comp {} [set ix [$w search -back $c1 $ix-1c $lim]]]} {} + set i1 insert-1c + while {[string comp {} $ix]} { + set i0 $ix + set j 0 + while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} { + append i0 +1c + if {[string match {\\} [$w get $i0-2c]]} continue + incr j + } + if {!$j} break + set i1 $ix + while {$j && [string comp {} [set ix [$w search -back $c1 $ix $lim]]]} { + if {[string match {\\} [$w get $ix-1c]]} continue + incr j -1 + } + } + if [string match {} $ix] { set ix [$w index $lim] } + } else { set ix [$w index $lim] } + if $data(-blinkrange) { + Console:blink $w $data(-blinktime) $ix [$w index insert] + } else { + Console:blink $w $data(-blinktime) $ix $ix+1c \ + [$w index insert-1c] [$w index insert] + } +} + +## ConsoleMatchQuote - blinks between matching quotes. +## Blinks just the quote if it's unmatched, otherwise blinks quoted string +## The quote to match is assumed to be at the text index 'insert'. +# ARGS: w - console text widget +# Calls: Console:blink +## +;proc ConsoleMatchQuote {w {lim 1.0}} { + upvar \#0 [winfo parent $w] data + if {!$data(-lightbrace) || $data(-blinktime)<100} return + set i insert-1c + set j 0 + while {[string comp {} [set i [$w search -back \" $i $lim]]]} { + if {[string match {\\} [$w get $i-1c]]} continue + if {!$j} {set i0 $i} + incr j + } + if [expr $j%2] { + if $data(-blinkrange) { + Console:blink $w $data(-blinktime) $i0 [$w index insert] + } else { + Console:blink $w $data(-blinktime) $i0 $i0+1c \ + [$w index insert-1c] [$w index insert] + } + } else { + Console:blink $w $data(-blinktime) [$w index insert-1c] [$w index insert] + } +} + +## Console:blink - blinks between 2 indices for a specified duration. +# ARGS: w - console text widget +# delay - millisecs to blink for +# args - indices of regions to blink +# Outputs: blinks selected characters in $w +## +;proc Console:blink {w delay args} { + eval $w tag add blink $args + after $delay eval $w tag remove blink $args + return +} + + +## ConsoleInsert +## Insert a string into a text console at the point of the insertion cursor. +## If there is a selection in the text, and it covers the point of the +## insertion cursor, then delete the selection before inserting. +# ARGS: w - text window in which to insert the string +# s - string to insert (usually just a single char) +# Outputs: $s to text widget +## +;proc ConsoleInsert {w s} { + if {[string match {} $s] || [string match disabled [$w cget -state]]} { + return + } + if [$w comp insert < limit] { + $w mark set insert end + } + catch { + if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert +} + +## Console:expand - +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# Calls: ConsoleExpand(Pathname|Procname|Variable) +# Outputs: The string to match is expanded to the longest possible match. +# If data(-showmultiple) is non-zero and the user longest match +# equaled the string to expand, then all possible matches are +# output to stdout. Triggers bell if no matches are found. +# Returns: number of matches found +## +;proc Console:expand {w type} { + set exp "\[^\\]\[ \t\n\r\[\{\"\$]" + set tmp [$w search -back -regexp $exp insert-1c limit-1c] + if [string compare {} $tmp] {append tmp +2c} else {set tmp limit} + if [$w compare $tmp >= insert] return + set str [$w get $tmp insert] + switch -glob $type { + pa* { set res [ConsoleExpandPathname $str] } + pr* { set res [ConsoleExpandProcname $str] } + v* { set res [ConsoleExpandVariable $str] } + default {set res {}} + } + set len [llength $res] + if $len { + $w delete $tmp insert + $w insert $tmp [lindex $res 0] + if {$len > 1} { + upvar \#0 [winfo parent $w] data + if {$data(-showmultiple) && ![string comp [lindex $res 0] $str]} { + puts stdout [lreplace $res 0 0] + } + } + } else bell + return [incr len -1] +} + +## ConsoleExpandPathname - expand a file pathname based on $str +## This is based on UNIX file name conventions +# ARGS: str - partial file pathname to expand +# Calls: ConsoleExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +;proc ConsoleExpandPathname str { + set pwd [ConsoleEvalAttached pwd] + if [catch {ConsoleEvalAttached [list cd [file dirname $str]]} err] { + return -code error $err + } + if [catch {lsort [ConsoleEvalAttached glob [file tail $str]*]} m] { + set match {} + } else { + if {[llength $m] > 1} { + set tmp [ConsoleExpandBestMatch $m [file tail $str]] + if [string match ?*/* $str] { + set tmp [file dirname $str]/$tmp + } elseif {[string match /* $str]} { + set tmp /$tmp + } + regsub -all { } $tmp {\\ } tmp + set match [linsert $m 0 $tmp] + } else { + ## This may look goofy, but it handles spaces in path names + eval append match $m + if [file isdir $match] {append match /} + if [string match ?*/* $str] { + set match [file dirname $str]/$match + } elseif {[string match /* $str]} { + set match /$match + } + regsub -all { } $match {\\ } match + ## Why is this one needed and the ones below aren't!! + set match [list $match] + } + } + ConsoleEvalAttached [list cd $pwd] + return $match +} + +## ConsoleExpandProcname - expand a tcl proc name based on $str +# ARGS: str - partial proc name to expand +# Calls: ConsoleExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +;proc ConsoleExpandProcname str { + set match [ConsoleEvalAttached info commands $str*] + if {[llength $match] > 1} { + regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + return $match +} + +## ConsoleExpandVariable - expand a tcl variable name based on $str +# ARGS: str - partial tcl var name to expand +# Calls: ConsoleExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +;proc ConsoleExpandVariable str { + if [regexp {([^$]*)\((.*)} $str junk ary str] { + ## Looks like they're trying to expand an array. + set match [ConsoleEvalAttached array names $ary $str*] + if {[llength $match] > 1} { + set vars $ary\([ConsoleExpandBestMatch $match $str] + foreach var $match {lappend vars $ary\($var$} + return $vars + } else {set match $ary$$match$} + ## Space transformation avoided for array names. + } else { + set match [ConsoleEvalAttached info vars $str*] + if {[llength $match] > 1} { + regsub -all { } [ConsoleExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + } + return $match +} + +## ConsoleExpandBestMatch2 - finds the best unique match in a list of names +## Improves upon the speed of the below proc only when $l is small +## or $e is {}. $e is extra for compatibility with proc below. +# ARGS: l - list to find best unique match in +# Returns: longest unique match in the list +## +;proc ConsoleExpandBestMatch2 {l {e {}}} { + set s [lindex $l 0] + if {[llength $l]>1} { + set i [expr [string length $s]-1] + foreach l $l { + while {$i>=0 && [string first $s $l]} { + set s [string range $s 0 [incr i -1]] + } + } + } + return $s +} + +## ConsoleExpandBestMatch - finds the best unique match in a list of names +## The extra $e in this argument allows us to limit the innermost loop a +## little further. This improves speed as $l becomes large or $e becomes long. +# ARGS: l - list to find best unique match in +# e - currently best known unique match +# Returns: longest unique match in the list +## +;proc ConsoleExpandBestMatch {l {e {}}} { + set ec [lindex $l 0] + if {[llength $l]>1} { + set e [string length $e]; incr e -1 + set ei [string length $ec]; incr ei -1 + foreach l $l { + while {$ei>=$e && [string first $ec $l]} { + set ec [string range $ec 0 [incr ei -1]] + } + } + } + return $ec +} + + +## ConsoleResource - re'source's this script into current console +## Meant primarily for my development of this program. It follows +## links until the ultimate source is found. +## +set Console(SCRIPT) [info script] +if !$Console(WWW) { + while {[string match link [file type $Console(SCRIPT)]]} { + set link [file readlink $Console(SCRIPT)] + if [string match relative [file pathtype $link]] { + set Console(SCRIPT) [file join [file dirname $Console(SCRIPT)] $link] + } else { + set Console(SCRIPT) $link + } + } + catch {unset link} + if [string match relative [file pathtype $Console(SCRIPT)]] { + set Console(SCRIPT) [file join [pwd] $Console(SCRIPT)] + } +} + +;proc Console:resource {} { + global Console + uplevel \#0 [list source $Console(SCRIPT)] +} + +catch {destroy .c} +console .c +wm iconify .c +wm title .c "Tcl Plugin Console" +wm geometry .c +10+10 diff --git a/extra/stripped.tcl b/extra/stripped.tcl new file mode 100755 index 0000000..64ef1f5 --- /dev/null +++ b/extra/stripped.tcl @@ -0,0 +1,1083 @@ +#!/bin/sh +# \ +exec wish4.1 "$0" ${1+"$@"} + +# +## stripped.tcl +## Stripped down version of Tk Console Widget, part of the VerTcl system +## Stripped to work with Netscape Tk Plugin. +## +## Copyright (c) 1995,1996 by Jeffrey Hobbs +## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/ +## source standard_disclaimer.tcl + +if {[info tclversion] < 7.5} { + error "TkCon requires at least the stable version of tcl7.5/tk4.1" +} + +## tkConInit - inits tkCon +# ARGS: root - widget pathname of the tkCon console root +# title - title for the console root and main (.) windows +# Calls: tkConInitUI +# Outputs: errors found in tkCon resource file +## +proc tkConInit {{title Main}} { + global tkCon tcl_platform env auto_path tcl_interactive + + set tcl_interactive 1 + + array set tkCon { + color,blink yellow + color,proc darkgreen + color,prompt brown + color,stdin black + color,stdout blue + color,stderr red + + blinktime 500 + font fixed + lightbrace 1 + lightcmd 1 + prompt1 {[history nextid] % } + prompt2 {[history nextid] cont > } + showmultiple 1 + slavescript {} + + cmd {} cmdbuf {} cmdsave {} event 1 svnt 1 cols 80 rows 24 + + version {0.5x Stripped} + base .console + } + + if [string comp $tcl_platform(platform) unix] { + array set tkCon { + font {Courier 12 {}} + } + } + + tkConInitUI $title + + interp alias {} clean {} tkConStateRevert tkCon + tkConStateCheckpoint tkCon +} + +## tkConInitUI - inits UI portion (console) of tkCon +## Creates all elements of the console window and sets up the text tags +# ARGS: title - title for the console root and main (.) windows +# Calls: tkConInitMenus, tkConPrompt +## +proc tkConInitUI {title} { + global tkCon + + set root $tkCon(base) + if [string match $root .] { set w {} } else { set w [frame $root] } + + set tkCon(console) [text $w.text -font $tkCon(font) -wrap char \ + -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin)] + bindtags $w.text "$w.text PreCon Console PostCon $root all" + set tkCon(scrolly) [scrollbar $w.sy \ + -command "$w.text yview" -takefocus 0 -bd 1] + + pack $w.sy -side left -fill y + set tkCon(scrollypos) left + pack $w.text -fill both -expand 1 + + $w.text insert insert "$title console display active\n" stdout + tkConPrompt $w.text + + foreach col {prompt stdout stderr stdin proc} { + $w.text tag configure $col -foreground $tkCon(color,$col) + } + $w.text tag configure blink -background $tkCon(color,blink) + + pack $root -fill both -expand 1 + focus $w.text +} + +## tkConEval - evaluates commands input into console window +## This is the first stage of the evaluating commands in the console. +## They need to be broken up into consituent commands (by tkConCmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd +## +proc tkConEval {w} { + global tkCon + tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd) + $w mark set insert end-1c + $w insert end \n + if [llength $cmds] { + foreach cmd $cmds {tkConEvalCmd $w $cmd} + $w insert insert $tkCon(cmd) {} + } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} { + tkConEvalCmd $w $tkCon(cmd) + } + $w see insert +} + +## tkConEvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: tkConPrompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +proc tkConEvalCmd {w cmd} { + global tkCon + $w mark set output end + if [catch {uplevel \#0 history add [list $cmd] exec} result] { + $w insert output $result\n stderr + } elseif [string comp {} $result] { + $w insert output $result\n stdout + } + tkConPrompt $w + set tkCon(svnt) [set tkCon(event) [history nextid]] +} + +## tkConCmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +proc tkConCmdGet w { + if [string match {} [set ix [$w tag nextrange prompt limit end]]] { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## tkConCmdSep - separates multiple commands into a list and remainder +# ARGS: cmd - (possible) multiple command to separate +# list - varname for the list of commands that were separated. +# rmd - varname of any remainder (like an incomplete final command). +# If there is only one command, it's placed in this var. +# Returns: constituent command info in varnames specified by list & rmd. +## +proc tkConCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if [string comp {} $tmp] { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } + } + if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] + } +} + +## tkConPrompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in tkCon(prompt1)) to console +## +proc tkConPrompt w { + global tkCon env + set i [$w index end-1c] + $w insert end [subst $tkCon(prompt1)] prompt + $w mark set output $i + $w mark set limit insert + $w mark gravity limit left +} + +## tkConStateCheckpoint - checkpoints the current state of the system +## This allows you to return to this state with tkConStateRevert +# ARGS: ary an array into which several elements are stored: +# commands - the currently defined commands +# variables - the current global vars +# This is the array you would pass to tkConRevertState +## +proc tkConStateCheckpoint {ary} { + global tkCon + upvar $ary a + set a(commands) [uplevel \#0 info commands *] + set a(variables) [uplevel \#0 info vars *] + return +} + +## tkConStateCompare - compare two states and output difference +# ARGS: ary1 an array with checkpointed state +# ary2 a second array with checkpointed state +# Outputs: +## +proc tkConStateCompare {ary1 ary2} { + upvar $ary1 a1 $ary2 a2 + puts "Commands unique to $ary1:\n[lremove $a1(commands) $a2(commands)]" + puts "Commands unique to $ary2:\n[lremove $a2(commands) $a1(commands)]" + puts "Variables unique to $ary1:\n[lremove $a1(variables) $a2(variables)]" + puts "Variables unique to $ary2:\n[lremove $a2(variables) $a1(variables)]" +} + +## tkConStateRevert - reverts interpreter to a previous state +# ARGS: ary an array with checkpointed state +## +proc tkConStateRevert {ary} { + upvar $ary a + tkConStateCheckpoint tmp + foreach i [lremove $tmp(commands) $a(commands)] { catch "rename $i {}" } + foreach i [lremove $tmp(variables) $a(variables)] { uplevel \#0 unset $i } +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## puts +## This allows me to capture all stdout/stderr to the console window +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +catch {rename puts tcl_puts} +proc puts args { + set len [llength $args] + if {$len==1} { + eval tkcon console insert output $args stdout {\n} stdout + tkcon console see output + } elseif {$len==2 && + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if [string comp $tmp -nonewline] { + eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp + } else { + eval tkcon console insert output [lreplace $args 0 0] stdout + } + tkcon console see output + } elseif {$len==3 && + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if [string comp [lreplace $args 1 2] -nonewline] { + eval tkcon console insert output [lrange $args 1 1] $tmp + } else { + eval tkcon console insert output [lreplace $args 0 1] $tmp + } + tkcon console see output + } else { + eval tcl_puts $args + } +} + +## alias - akin to the csh alias command +## If called with no args, then it prints out all current aliases +## If called with one arg, returns the alias of that arg (or {} if none) +# ARGS: newcmd - (optional) command to bind alias to +# args - command and args being aliased +## +proc alias {{newcmd {}} args} { + if [string match $newcmd {}] { + set res {} + foreach a [interp aliases] { + lappend res [list $a: [interp alias {} $a]] + } + return [join $res \n] + } elseif {[string match {} $args]} { + interp alias {} $newcmd + } else { + eval interp alias {{}} $newcmd {{}} $args + } +} + +## unalias - unaliases an alias'ed command +# ARGS: cmd - command to unbind as an alias +## +proc unalias {cmd} { + interp alias {} $cmd {} +} + +## tkcon - command that allows control over the console +# ARGS: totally variable, see internal comments +## +proc tkcon {args} { + global tkCon + switch -- [lindex $args 0] { + clean { + ## 'cleans' the interpreter - reverting to original tkCon state + tkConStateRevert tkCon + } + console { + ## Passes the args to the text widget of the console. + eval $tkCon(console) [lreplace $args 0 0] + } + font { + ## "tkcon font ?fontname?". Sets the font of the console + if [string comp {} [lindex $args 1]] { + return [$tkCon(console) config -font [lindex $args 1]] + } else { + return [$tkCon(console) config -font] + } + } + version { + return $tkCon(version) + } + default { + ## tries to determine if the command exists, otherwise throws error + set cmd [lindex $args 0] + set cmd tkCon[string toup [string index $cmd 0]][string range $cmd 1 end] + if [string match $cmd [info command $cmd]] { + eval $cmd [lreplace $args 0 0] + } else { + error "bad option \"[lindex $args 0]\": must be attach,\ + clean, console, font" + } + } + } +} + +## clear - clears the buffer of the console (not the history though) +## This is executed in the parent interpreter +## +proc clear {{pcnt 100}} { + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + error "invalid percentage to clear: must be 1-100 (100 default)" + } elseif {$pcnt == 100} { + tkcon console delete 1.0 end + } else { + set tmp [expr $pcnt/100.0*[tkcon console index end]] + tkcon console delete 1.0 "$tmp linestart" + } +} + +## dump - outputs variables/procedure/widget info in source'able form. +## Accepts glob style pattern matching for the names +# ARGS: type - type of thing to dump: must be variable, procedure, widget +# OPTS: -nocomplain don't complain if no vars match something +# Returns: the values of the variables in a 'source'able form +## +proc dump {type args} { + set whine 1 + set code ok + if [string match \-n* [lindex $args 0]] { + set whine 0 + set args [lreplace $args 0 0] + } + if {$whine && [string match {} $args]} { + error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?" + } + set res {} + switch -glob -- $type { + v* { + # variable + # outputs variables value(s), whether array or simple. + foreach arg $args { + if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { + if {[uplevel info exists $arg]} { + set vars $arg + } elseif $whine { + append res "\#\# No known variable $arg\n" + set code error + continue + } else continue + } + foreach var [lsort $vars] { + upvar $var v + if {[array exists v]} { + append res "array set $var \{\n" + foreach i [lsort [array names v]] { + upvar 0 v$$i$ w + if {[array exists w]} { + append res " [list $i {NESTED VAR ERROR}]\n" + if $whine { set code error } + } else { + append res " [list $i $v($i)]\n" + } + } + append res "\}\n" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if {[string comp {} [set ps [info proc $arg]]]} { + foreach p [lsort $ps] { + set as {} + foreach a [info args $p] { + if {[info default $p $a tmp]} { + lappend as [list $a $tmp] + } else { + lappend as $a + } + } + append res [list proc $p $as [info body $p]]\n + } + } elseif $whine { + append res "\#\# No known proc $arg\n" + } + } + } + w* { + # widget + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"[lindex $args 0]\":\ must be procedure, variable, widget" + } + } + return -code $code [string trimr $res \n] +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + if [string comp {} [info commands $cmd]] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + return "$cmd:\taliased to [alias $cmd]" + } elseif [string comp {} [info procs $cmd]] { + return "$cmd:\tinternal proc" + } else { + return "$cmd:\tinternal command" + } + } else { + return "$cmd:\tunknown command" + } +} + +## lremove - remove items from a list +# OPTS: -all remove all instances of each item +# ARGS: l a list to remove items from +# is a list of items to remove +## +proc lremove {args} { + set all 0 + if [string match \-a* [lindex $args 0]] { + set all 1 + set args [lreplace $args 0 0] + } + set l [lindex $args 0] + eval append is [lreplace $args 0 0] + foreach i $is { + if {[set ix [lsearch -exact $l $i]] == -1} continue + set l [lreplace $l $ix $ix] + if $all { + while {[set ix [lsearch -exact $l $i]] != -1} { + set l [lreplace $l $i $i] + } + } + } + return $l +} + + +## Unknown changed to get output into tkCon window +## See $tcl_library/init.tcl for an explanation +## +proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if {[array size unknown_pending] == 0} { + unset unknown_pending + } + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {[info level] == 1 && [string match {} [info script]] \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + if [auto_execok $name] { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec $args] + #return [uplevel exec >&@stdout <@stdin $args] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + if {[string match $name !!]} { + catch {set tkCon(cmd) [history event]} + return [uplevel {history redo}] + } elseif [regexp {^!(.+)$} $name dummy event] { + catch {set tkCon(cmd) [history event $event]} + return [uplevel [list history redo $event]] + } elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $name dummy old new] { + catch {set tkCon(cmd) [history substitute $old $new]} + return [uplevel [list history substitute $old $new]] + } + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } elseif {[llength $cmds]} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code error "invalid command name \"$name\"" +} + + +# tkConClipboardKeysyms -- +# This procedure is invoked to identify the keys that correspond to +# the "copy", "cut", and "paste" functions for the clipboard. +# +# Arguments: +# copy - Name of the key (keysym name plus modifiers, if any, +# such as "Meta-y") used for the copy operation. +# cut - Name of the key used for the cut operation. +# paste - Name of the key used for the paste operation. + +proc tkConCut w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch { + clipboard append -displayof $w [selection get -displayof $w] + if [$w compare sel.first >= limit] {$w delete sel.first sel.last} + } + } +} +proc tkConCopy w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch {clipboard append -displayof $w [selection get -displayof $w]} + } +} + +proc tkConPaste w { + if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] { + if [$w compare insert < limit] {$w mark set insert end} + $w insert insert $tmp + $w see insert + if [string match *\n* $tmp] {tkConEval $w} + } +} + +proc tkConClipboardKeysyms {copy cut paste} { + bind Console <$copy> {tkConCopy %W} + bind Console <$cut> {tkConCut %W} + bind Console <$paste> {tkConPaste %W} +} + +## Get all Text bindings into Console +## +foreach ev [lremove [bind Text] {

\ +

}] { + bind Console $ev [bind Text $ev] +} +unset ev + +## Redefine for Console what we need +## +tkConClipboardKeysyms F16 F20 F18 +tkConClipboardKeysyms Control-c Control-x Control-v + +bind Console {catch {tkConInsert %W [selection get -displayof %W]}} + +bind Console { + if [%W compare {insert linestart} != {limit linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W -1] + } else { + if {$tkCon(event) == [history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] { + incr tkCon(event) + } else { + %W delete limit end + %W insert limit $tkCon(tmp) + %W see end + } + } +} +bind Console { + if [%W compare {insert linestart} != {end-1c linestart}] { + tkTextSetCursor %W [tkTextUpDownLine %W 1] + } else { + if {$tkCon(event) < [history nextid]} { + %W delete limit end + if {[incr tkCon(event)] == [history nextid]} { + %W insert limit $tkCon(cmdbuf) + } else { + %W insert limit [history event $tkCon(event)] + } + %W see end + } + } +} +bind Console { + if [%W compare insert > limit] {tkConExpand %W proc} +} +bind Console { + if [%W compare insert > limit] {tkConExpand %W var} +} +bind Console { + if [%W compare insert >= limit] { + tkConInsert %W \t + } +} +bind Console { + tkConEval %W +} +bind Console [bind Console ] +bind Console { + if {[string comp {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif [%W compare insert >= limit] { + %W delete insert + %W see insert + } +} +bind Console { + if {[string comp {} [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert != 1.0] && [%W compare insert-1c >= limit]} { + %W delete insert-1c + %W see insert + } +} +bind Console [bind Console ] + +bind Console { + tkConInsert %W %A +} + +bind Console { + if [%W compare {limit linestart} == {insert linestart}] { + tkTextSetCursor %W limit + } else { + tkTextSetCursor %W {insert linestart} + } +} +bind Console { + if [%W compare insert < limit] break + %W delete insert +} +bind Console { + if [%W compare insert < limit] break + if [%W compare insert == {insert lineend}] { + %W delete insert + } else { + %W delete insert {insert lineend} + } +} +bind Console { + ## Clear console buffer, without losing current command line input + set tkCon(tmp) [tkConCmdGet %W] + clear + tkConPrompt + tkConInsert %W $tkCon(tmp) +} +bind Console { + ## Goto next command in history + if {$tkCon(event) < [history nextid]} { + %W delete limit end + if {[incr tkCon(event)] == [history nextid]} { + %W insert limit $tkCon(cmdbuf) + } else { + %W insert limit [history event $tkCon(event)] + } + %W see end + } +} +bind Console { + ## Goto previous command in history + if {$tkCon(event) == [history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + if [catch {history event [incr tkCon(event) -1]} tkCon(tmp)] { + incr tkCon(event) + } else { + %W delete limit end + %W insert limit $tkCon(tmp) + %W see end + } +} +bind Console { + ## Search history reverse + if {$tkCon(svnt) == [history nextid]} { + set tkCon(cmdbuf) [tkConCmdGet %W] + } + set tkCon(tmp1) [string len $tkCon(cmdbuf)] + incr tkCon(tmp1) -1 + while 1 { + if {[catch {history event [incr tkCon(svnt) -1]} tkCon(tmp)]} { + incr tkCon(svnt) + break + } elseif {![string comp $tkCon(cmdbuf) \ + [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { + %W delete limit end + %W insert limit $tkCon(tmp) + break + } + } + %W see end +} +bind Console { + ## Search history forward + set tkCon(tmp1) [string len $tkCon(cmdbuf)] + incr tkCon(tmp1) -1 + while {$tkCon(svnt) < [history nextid]} { + if {[incr tkCon(svnt)] == [history nextid]} { + %W delete limit end + %W insert limit $tkCon(cmdbuf) + break + } elseif {![catch {history event $tkCon(svnt)} tkCon(tmp)] + && ![string comp $tkCon(cmdbuf) \ + [string range $tkCon(tmp) 0 $tkCon(tmp1)]]} { + %W delete limit end + %W insert limit $tkCon(tmp) + break + } + } + %W see end +} +bind Console { + ## Transpose current and previous chars + if [%W compare insert > limit] { + tkTextTranspose %W + } +} +bind Console { + ## Clear command line (Unix shell staple) + %W delete limit end +} +bind Console { + ## Save command buffer + set tkCon(tmp) $tkCon(cmdsave) + set tkCon(cmdsave) [tkConCmdGet %W] + if {[string match {} $tkCon(cmdsave)]} { + set tkCon(cmdsave) $tkCon(tmp) + } else { + %W delete limit end-1c + } + tkConInsert %W $tkCon(tmp) + %W see end +} +catch {bind Console { tkTextScrollPages %W -1 }} +catch {bind Console { tkTextScrollPages %W -1 }} +catch {bind Console { tkTextScrollPages %W 1 }} +catch {bind Console { tkTextScrollPages %W 1 }} +bind Console { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } +} +bind Console { + if [%W compare {insert -1c wordstart} >= limit] { + %W delete {insert -1c wordstart} insert + } +} +bind Console { + if [%W compare insert >= limit] { + %W delete insert {insert wordend} + } +} +bind Console { + if {(!$tkPriv(mouseMoved) || $tk_strictMotif) \ + && ![catch {selection get -displayof %W} tkCon(tmp)]} { + if [%W compare @%x,%y < limit] { + %W insert end $tkCon(tmp) + } else { + %W insert @%x,%y $tkCon(tmp) + } + if [string match *\n* $tkCon(tmp)] {tkConEval %W} + } +} + +## +## End weird bindings +## + +## +## PostCon bindings, for doing special things based on certain keys +## +bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W  + } +} +bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \[ \] + } +} +bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchPair %W \{ \} + } +} +bind PostCon { + if {$tkCon(lightbrace) && $tkCon(blinktime)>99 && + [string comp \\ [%W get insert-2c]]} { + tkConMatchQuote %W + } +} + +bind PostCon { + if {$tkCon(lightcmd) && [string comp {} %A]} { tkConTagProc %W } +} + +## tkConTagProc - tags a procedure in the console if it's recognized +## This procedure is not perfect. However, making it perfect wastes +## too much CPU time... Also it should check the existence of a command +## in whatever is the connected slave, not the master interpreter. +## +proc tkConTagProc w { + set i [$w index "insert-1c wordstart"] + set j [$w index "insert-1c wordend"] + if {[string comp {} [info command [list [$w get $i $j]]]]} { + $w tag add proc $i $j + } else { + $w tag remove proc $i $j + } +} + + +## tkConMatchPair - blinks a matching pair of characters +## c2 is assumed to be at the text index 'insert'. +## This proc is really loopy and took me an hour to figure out given +## all possible combinations with escaping except for escaped \'s. +## It doesn't take into account possible commenting... Oh well. If +## anyone has something better, I'd like to see/use it. This is really +## only efficient for small contexts. +# ARGS: w - console text widget +# c1 - first char of pair +# c2 - second char of pair +# Calls: tkConBlink +## +proc tkConMatchPair {w c1 c2} { + if [string comp {} [set ix [$w search -back $c1 insert limit]]] { + while {[string match {\\} [$w get $ix-1c]] && + [string comp {} [set ix [$w search -back $c1 $ix-1c limit]]]} {} + set i1 insert-1c + while {[string comp {} $ix]} { + set i0 $ix + set j 0 + while {[string comp {} [set i0 [$w search $c2 $i0 $i1]]]} { + append i0 +1c + if {[string match {\\} [$w get $i0-2c]]} continue + incr j + } + if {!$j} break + set i1 $ix + while {$j && + [string comp {} [set ix [$w search -back $c1 $ix limit]]]} { + if {[string match {\\} [$w get $ix-1c]]} continue + incr j -1 + } + } + if [string match {} $ix] { set ix [$w index limit] } + } else { set ix [$w index limit] } + tkConBlink $w $ix [$w index insert] +} + +## tkConMatchQuote - blinks between matching quotes. +## Blinks just the quote if it's unmatched, otherwise blinks quoted string +## The quote to match is assumed to be at the text index 'insert'. +# ARGS: w - console text widget +# Calls: tkConBlink +## +proc tkConMatchQuote w { + set i insert-1c + set j 0 + while {[string comp {} [set i [$w search -back \" $i limit]]]} { + if {[string match {\\} [$w get $i-1c]]} continue + if {!$j} {set i0 $i} + incr j + } + if [expr $j%2] { + tkConBlink $w $i0 [$w index insert] + } else { + tkConBlink $w [$w index insert-1c] [$w index insert] + } +} + +## tkConBlink - blinks between 2 indices for a specified duration. +# ARGS: w - console text widget +# i1 - start index to blink region +# i2 - end index of blink region +# dur - duration in usecs to blink for +# Outputs: blinks selected characters in $w +## +proc tkConBlink {w i1 i2} { + global tkCon + $w tag add blink $i1 $i2 + after $tkCon(blinktime) $w tag remove blink $i1 $i2 + return +} + + +## tkConInsert +## Insert a string into a text at the point of the insertion cursor. +## If there is a selection in the text, and it covers the point of the +## insertion cursor, then delete the selection before inserting. +# ARGS: w - text window in which to insert the string +# s - string to insert (usually just a single char) +# Outputs: $s to text widget +## +proc tkConInsert {w s} { + if {[string match {} $s] || [string match disabled [$w cget -state]]} { + return + } + if [$w comp insert < limit] { + $w mark set insert end + } + catch { + if {[$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { + $w delete sel.first sel.last + } + } + $w insert insert $s + $w see insert +} + +## tkConExpand - +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# Calls: tkConExpand(Pathname|Procname|Variable) +# Outputs: The string to match is expanded to the longest possible match. +# If tkCon(showmultiple) is non-zero and the user longest match +# equaled the string to expand, then all possible matches are +# output to stdout. Triggers bell if no matches are found. +# Returns: number of matches found +## +proc tkConExpand {w type} { + set exp "\[^\\]\[ \t\n\r\[\{\"\$]" + set tmp [$w search -back -regexp $exp insert-1c limit-1c] + if [string compare {} $tmp] {append tmp +2c} else {set tmp limit} + if [$w compare $tmp >= insert] return + set str [$w get $tmp insert] + switch -glob $type { + pr* {set res [tkConExpandProcname $str]} + v* {set res [tkConExpandVariable $str]} + default {set res {}} + } + set len [llength $res] + if $len { + $w delete $tmp insert + $w insert $tmp [lindex $res 0] + if {$len > 1} { + global tkCon + if {$tkCon(showmultiple) && [string match [lindex $res 0] $str]} { + puts stdout [lreplace $res 0 0] + } + } + } + return [incr len -1] +} + +## tkConExpandProcname - expand a tcl proc name based on $str +# ARGS: str - partial proc name to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandProcname str { + set match [info commands $str*] + if {[llength $match] > 1} { + regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + return $match +} + +## tkConExpandVariable - expand a tcl variable name based on $str +# ARGS: str - partial tcl var name to expand +# Calls: tkConExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc tkConExpandVariable str { + if [regexp {([^$]*)\((.*)} $str junk ary str] { + set match [uplevel \#0 array names $ary $str*] + if {[llength $match] > 1} { + set vars $ary\([tkConExpandBestMatch $match $str] + foreach var $match {lappend vars $ary\($var$} + return $vars + } else {set match $ary$$match$} + } else { + set match [uplevel \#0 info vars $str*] + if {[llength $match] > 1} { + regsub -all { } [tkConExpandBestMatch $match $str] {\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all { } $match {\\ } match + } + } + return $match +} + +## tkConExpandBestMatch - finds the best unique match in a list of names +## The extra $e in this argument allows us to limit the innermost loop a +## little further. This improves speed as $l becomes large or $e becomes long. +# ARGS: l - list to find best unique match in +# e - currently best known unique match +# Returns: longest unique match in the list +## +proc tkConExpandBestMatch {l {e {}}} { + set ec [lindex $l 0] + if {[llength $l]>1} { + set e [string length $e]; incr e -1 + set ei [string length $ec]; incr ei -1 + foreach l $l { + while {$ei>=$e && [string first $ec $l]} { + set ec [string range $ec 0 [incr ei -1]] + } + } + } + return $ec +} + + +## Initialize only if we haven't yet +## +if [catch {winfo exists $tkCon(base)}] tkConInit diff --git a/tkcon.tcl b/tkcon.tcl new file mode 100755 index 0000000..53091e7 --- /dev/null +++ b/tkcon.tcl @@ -0,0 +1,2141 @@ +#!/bin/sh +# The wish executable needs to be Tk4.1+ \ +exec wish "$0" ${1+"$@"} + +# +## tkcon.tcl +## Tk Console Widget, part of the VerTcl system +## +## Based (loosely) off Brent Welch's Tcl Shell Widget +## +## Thanks especially to the following for bug reports & code ideas: +## Steven Wahl +## Jan Nijtmans +## Crimmins < @umich.edu somewhere > +## +## Copyright 1995,1996 Jeffrey Hobbs. All rights reserved. +## Initiated: Thu Aug 17 15:36:47 PDT 1995 +## +## jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/ +## +## source standard_disclaimer.tcl + +if [catch {package require Tk 4.1}] { + error "TkCon requires at least the stable version of tcl7.5/tk4.1" +} +package ifneeded Tk $tk_version {load {} Tk} + +## warn - little helper proc to pop up a tk_dialog warning message +# ARGS: msg - message you want to display to user +## +proc warn { msg } { + bell + tk_dialog ._warning Warning $msg warning 0 OK +} + +## tkConInit - inits tkCon +# ARGS: root - widget pathname of the tkCon console root +# title - title for the console root and main (.) windows +# Calls: tkConInitUI +# Outputs: errors found in tkCon resource file +## +proc tkConInit {} { + global tkCon tcl_interactive tcl_platform env auto_path argv0 argc argv + + set tcl_interactive 1 + + if [info exists tkCon(name)] { + set title $tkCon(name) + } else { + tkConMainInit + set title Main + } + + array set tkCon { + color,blink yellow + color,proc darkgreen + color,prompt brown + color,stdin black + color,stdout blue + color,stderr red + + blinktime 500 + font fixed + history 32 + library {} + lightbrace 1 + lightcmd 0 + loadTk 0 + maineval {} + nontcl 0 + prompt1 {([file tail [pwd]]) [history nextid] % } + prompt2 {[history nextid] cont > } + rcfile .tkconrc + scrollypos left + showmultiple 1 + showmenu 1 + slaveeval {} + subhistory 1 + + exec slave app {} appname {} apptype slave cmd {} cmdbuf {} cmdsave {} + event 1 svnt 1 cols 80 rows 24 deadapp 0 + errorInfo {} + slavealias { tkcon warn } + slaveprocs { alias clear dir dump lremove puts tclindex \ + auto_execpath unknown unalias which } + version 0.52 + root . + } + + ## If there appear to be children of '.', then make sure we use + ## a disassociated toplevel. + if [string compare {} [winfo children .]] { + set tkCon(root) .tkcon + } + + if [string compare unix $tcl_platform(platform)] { + array set tkCon { + font {Courier 12 {}} + rcfile tkcon.cfg + } + } + + if [info exists env(HOME)] { + set tkCon(rcfile) [file join $env(HOME) $tkCon(rcfile)] + } + + ## Handle command line arguments before sourcing resource file to + ## find if resource file is being specified (let other args pass). + for {set i 0} {$i < $argc} {incr i} { + if [string match \-rcfile [lindex $argv $i]] { + set tkCon(rcfile) [lindex $argv [incr i]] + } + } + + if [file exists $tkCon(rcfile)] { + set code [catch [list uplevel \#0 source $tkCon(rcfile)] err] + } + + if [info exists env(TK_CON_LIBRARY)] { + eval lappend auto_path $env(TK_CON_LIBRARY) + } else { + eval lappend auto_path $tkCon(library) + } + + set dir [file dir [info nameofexec]] + foreach dir [list $dir [file join [file dir $dir] lib]] { + if [file exists [file join $dir pkgIndex.tcl]] { + if {[lsearch -exact $auto_path $dir] < 0} { + lappend auto_path $dir + } + } + } + + foreach dir $auto_path { + if [file exists [file join $dir pkgIndex.tcl]] { + source [file join $dir pkgIndex.tcl] + } + } + + ## Handle rest of command line arguments after sourcing resource file + ## and slave is created, but before initializing UI or setting packages. + set slaveargs {} + set slavefiles {} + for {set i 0} {$i < $argc} {incr i} { + set arg [lindex $argv $i] + if [regexp -- {-.+} $arg] { + ## Handle arg based options + switch -- $arg { + -rcfile { incr i } + -maineval - -e - + -eval { append tkCon(maineval) [lindex $argv [incr i]]\n } + -slave - -slavescript - + -slaveeval { append tkCon(slaveeval) [lindex $argv [incr i]]\n } + -package - -pkg - + -load { set tkCon(load[lindex $argv [incr i]]) 1 } + -nontcl { set tkCon(nontcl) 0 } + -root { set tkCon(root) [lindex $argv [incr i]] } + default { lappend slaveargs $arg } + } + } elseif {[file isfile $arg]} { + lappend slavefiles $arg + } else { + lappend slaveargs $arg + } + } + + ## Create slave executable + if [string comp {} $tkCon(exec)] { + eval tkConInitSlave $tkCon(exec) $slaveargs + } + + tkConAttach $tkCon(appname) $tkCon(apptype) + tkConInitUI $title + + ## Set up package info for the slave + tkConCheckPackages + + ## Evaluate maineval in slave + if {[string comp {} $tkCon(maineval)] && + [catch {uplevel \#0 $tkCon(maineval)} merr]} { + puts stderr "error in eval:\n$merr" + } + + ## Source extra command line argument files into slave executable + foreach fn $slavefiles { + puts -nonewline "slave sourcing $fn ... " + if {[catch {tkConEvalSlave source $fn} fnerr]} { + puts stderr "error:\n$fnerr" + } else { + puts "OK" + } + } + + interp alias {} ls {} dir + #interp alias $tkCon(exec) clean {} tkConStateRevert tkCon + #tkConStateCheckpoint tkCon + + ## Evaluate slaveeval in slave + if {[string comp {} $tkCon(slaveeval)] && + [catch {interp eval $tkCon(exec) $tkCon(slaveeval)} serr]} { + puts stderr "error in slave script:\n$serr" + } + ## Output any error/output that may have been returned from rcfile + if {[info exists code] && [string comp {} $err]} { + if $code { + puts stderr "error in $tkCon(rcfile):\n$err" + } else { + puts stdout "returned from $tkCon(rcfile):\n$err" + } + } +} + +## tkConInitSlave - inits the slave by placing key procs and aliases in it +## It's arg[cv] are based on passed in options, while argv0 is the same as +## the master. tcl_interactive is the same as the master as well. +# ARGS: slave - name of slave to init. If it does not exist, it is created. +# args - args to pass to a slave as argv/argc +## +proc tkConInitSlave {slave args} { + global tkCon argv0 tcl_interactive + if [string match {} $slave] { + error "Don't init the master interpreter, goofball" + } + if ![interp exists $slave] { interp create $slave } + if {[string match {} [$slave eval info command tcl_puts]]} { + interp eval $slave rename puts tcl_puts + } + foreach cmd $tkCon(slaveprocs) { interp eval $slave [dump proc $cmd] } + foreach cmd $tkCon(slavealias) { interp alias $slave $cmd {} $cmd } + interp alias $slave ls $slave dir + interp eval $slave set tcl_interactive $tcl_interactive \; \ + set argv0 [list $argv0] \; set argc [llength $args] \; \ + set argv [list $args] \; history keep $tkCon(history) + + foreach pkg [lremove [package names] Tcl] { + foreach v [package versions $pkg] { + interp eval $slave [list package ifneeded $pkg $v \ + [package ifneeded $pkg $v]] + } + } +} + +## tkConInitUI - inits UI portion (console) of tkCon +## Creates all elements of the console window and sets up the text tags +# ARGS: root - widget pathname of the tkCon console root +# title - title for the console root and main (.) windows +# Calls: tkConInitMenus, tkConPrompt +## +proc tkConInitUI {title} { + global tkCon + + set root $tkCon(root) + if [string match . $root] { set w {} } else { set w [toplevel $root] } + set tkCon(base) $w + wm withdraw $root + + set tkCon(menubar) [frame $w.mbar -relief raised -bd 2] + set tkCon(console) [text $w.text -font $tkCon(font) -wrap char \ + -yscrollcommand "$w.sy set" -setgrid 1 -foreground $tkCon(color,stdin)] + bindtags $w.text "$w.text PreCon Console PostCon $root all" + set tkCon(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 \ + -command "$w.text yview"] + + tkConInitMenus $tkCon(menubar) + + if $tkCon(showmenu) { pack $tkCon(menubar) -fill x } + pack $tkCon(scrolly) -side $tkCon(scrollypos) -fill y + pack $tkCon(console) -fill both -expand 1 + + tkConPrompt "$title console display active\n" + + foreach col {prompt stdout stderr stdin proc} { + $w.text tag configure $col -foreground $tkCon(color,$col) + } + $w.text tag configure blink -background $tkCon(color,blink) + + bind $w.text { + scan [wm geometry [winfo toplevel %W]] "%%dx%%d" tkCon(cols) tkCon(rows) + } + + wm title $root "tkCon $tkCon(version) $title" + wm deiconify $root + focus $w.text +} + +## tkConEval - evaluates commands input into console window +## This is the first stage of the evaluating commands in the console. +## They need to be broken up into consituent commands (by tkConCmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## tkConEvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: tkConCmdGet, tkConCmdSep, tkConEvalCmd +## +proc tkConEval {w} { + global tkCon + tkConCmdSep [tkConCmdGet $w] cmds tkCon(cmd) + $w mark set insert end-1c + $w insert end \n + if [llength $cmds] { + foreach cmd $cmds {tkConEvalCmd $w $cmd} + $w insert insert $tkCon(cmd) {} + } elseif {[info complete $tkCon(cmd)] && ![regexp {[^\\]\\$} $tkCon(cmd)]} { + tkConEvalCmd $w $tkCon(cmd) + } + $w see insert +} + +## tkConEvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: tkConPrompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +proc tkConEvalCmd {w cmd} { + global tkCon + $w mark set output end + if [string comp {} $cmd] { + set err 0 + if $tkCon(subhistory) { + set ev [tkConEvalSlave history nextid] + incr ev -1 + if {[string match !! $cmd]} { + set err [catch {tkConEvalSlave history event $ev} cmd] + } elseif [regexp {^!(.+)$} $cmd dummy event] { + set err [catch {tkConEvalSlave history event $event} cmd] + } elseif [regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new] { + if ![set err [catch {tkConEvalSlave history event $ev} cmd]] { + regsub -all -- $old $cmd $new cmd + } + } + } + if $err { + $w insert output $cmd\n stderr + } else { + if [string match {} $tkCon(appname)] { + if [catch {tkConEvalSlave eval $cmd} res] { + set tkCon(errorInfo) [tkConEvalSlave set errorInfo] + set err 1 + } + } else { + if {$tkCon(nontcl) && [string match interp $tkCon(apptype)]} { + if [catch "tkConEvalSend $cmd" res] { + set tkCon(errorInfo) {Non-Tcl errorInfo not available} + set err 1 + } + } else { + if [catch [list tkConEvalAttached $cmd] res] { + set tkCon(errorInfo) [tkConEvalAttached set errorInfo] + set err 1 + } + } + } + tkConEvalSlave history add $cmd + if $err { + $w insert output $res\n stderr + } elseif [string comp {} $res] { + $w insert output $res\n stdout + } + } + } + tkConPrompt + set tkCon(svnt) [set tkCon(event) [tkConEvalSlave history nextid]] +} + +## tkConEvalSlave - evaluates the args in the associated slave +# ARGS: args - the command and args to evaluate +## +proc tkConEvalSlave args { + global tkCon + interp eval $tkCon(exec) $args +} + +## tkConEvalSend - sends the args to the attached interpreter +## Varies from 'send' by determining whether attachment is dead +## when an error is received +# ARGS: args - the args to send across +# Returns: the result of the command +## +proc tkConEvalSend args { + global tkCon + if $tkCon(deadapp) { + if {[lsearch -exact [winfo interps] $tkCon(app)]<0} { + return + } else { + set tkCon(appname) [string range $tkCon(appname) 5 end] + set tkCon(deadapp) 0 + tkConPrompt "\n\"$tkCon(app)\" alive\n" [tkConCmdGet $tkCon(console)] + } + } + set code [catch {eval send [list $tkCon(app)] $args} result] + if {$code && [lsearch -exact [winfo interps] $tkCon(app)]<0} { + ## Interpreter disappeared + if [tk_dialog $tkCon(base).dead "Dead Attachment" \ + "\"$tkCon(app)\" appears to have died.\nReturn to primary slave interpreter?" questhead 0 OK No] { + set tkCon(appname) "DEAD:$tkCon(appname)" + set tkCon(deadapp) 1 + } else { + set err "Attached Tk interpreter \"$tkCon(app)\" died." + tkConAttach {} + tkConEvalSlave set errorInfo $err + } + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } + return -code $code $result +} + +## tkConCmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +proc tkConCmdGet w { + if [string match {} [set ix [$w tag nextrange prompt limit end]]] { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## tkConCmdSep - separates multiple commands into a list and remainder +# ARGS: cmd - (possible) multiple command to separate +# list - varname for the list of commands that were separated. +# rmd - varname of any remainder (like an incomplete final command). +# If there is only one command, it's placed in this var. +# Returns: constituent command info in varnames specified by list & rmd. +## +proc tkConCmdSep {cmd ls rmd} { + upvar $ls cmds $rmd tmp + set tmp {} + set cmds {} + foreach cmd [split [set cmd] \n] { + if [string comp {} $tmp] { + append tmp \n$cmd + } else { + append tmp $cmd + } + if {[info complete $tmp] && ![regexp {[^\\]\\$} $tmp]} { + lappend cmds $tmp + set tmp {} + } + } + if {[string comp {} [lindex $cmds end]] && [string match {} $tmp]} { + set tmp [lindex $cmds end] + set cmds [lreplace $cmds end end] + } +} + +## tkConPrompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in tkCon(prompt1)) to console +## +proc tkConPrompt {{pre {}} {post {}}} { + global tkCon + set w $tkCon(console) + if [string comp {} $pre] { $w insert end $pre stdout } + set i [$w index end-1c] + if [string comp {} $tkCon(appname)] { + $w insert end ">$tkCon(appname)< " prompt + } + $w insert end [tkConEvalSlave subst $tkCon(prompt1)] prompt + $w mark set output $i + $w mark set limit insert + $w mark gravity limit left + if [string comp {} $post] { $w insert end $post stdin } + $w see end +} + +## tkConAbout - gives about info for tkCon +## +proc tkConAbout {} { + global tkCon + tk_dialog $tkCon(base).about "About TkCon v$tkCon(version)" \ + "Jeffrey Hobbs, Copyright 1995-96\njhobbs@cs.uoregon.edu\ + \nhttp://www.cs.uoregon.edu/~jhobbs/" questhead 0 OK +} + +## tkConHelp - gives help info for tkCon +## +proc tkConHelp {} { + global tkCon + tk_dialog $tkCon(base).help "Help on TkCon v$tkCon(version)" \ + "Jeffrey Hobbs, jhobbs@cs.uoregon.edu\nHelp available at:\ + http://www.cs.uoregon.edu/~jhobbs/work/tkcon/" questhead 0 OK +} + +## tkConInitMenus - inits the menus for the console +# ARGS: w - console text widget +## +proc tkConInitMenus w { + global tkCon + + pack [menubutton $w.con -text Console -un 0 -menu $w.con.m] -side left + pack [menubutton $w.edit -text Edit -un 0 -menu $w.edit.m] -side left + #pack [menubutton $w.insp -text Inspect -un 0 -menu $w.insp.m] -side left + pack [menubutton $w.pkgs -text Packages -un 0 -menu $w.pkgs.m] -side left + pack [menubutton $w.pref -text Prefs -un 0 -menu $w.pref.m] -side left + pack [menubutton $w.help -text Help -un 0 -menu $w.help.m] -side right + + menu $w.pop -tearoff 0 + $w.pop add cascade -label Console -un 0 -menu $w.pop.con + $w.pop add cascade -label Edit -un 0 -menu $w.pop.edit + #$w.pop add cascade -label Inspect -un 0 -menu $w.pop.insp + $w.pop add cascade -label Packages -un 0 -menu $w.pop.pkgs + $w.pop add cascade -label Prefs -un 0 -menu $w.pop.pref + $w.pop add cascade -label Help -un 0 -menu $w.pop.help + bind [winfo toplevel $w] "tk_popup $w.pop %X %Y" + + ## Console Menu + ## + foreach m [list [menu $w.con.m] [menu $w.pop.con]] { + $m add command -label "New Console" -un 0 -acc Ctrl-N -com tkConNew + $m add command -label "Close Console " -un 0 -acc Ctrl-w -com tkConDestroy + $m add separator + $m add cascade -label "Attach Console " -un 0 -menu $m.apps + $m add separator + $m add command -label Quit -un 0 -acc Ctrl-q -command exit + + ## Attach Console Menu + ## + menu $m.apps -disabledforeground $tkCon(color,prompt) \ + -postcommand "tkConFillAppsMenu $m.apps" + } + + ## Edit Menu + ## + set text $tkCon(console) + foreach m [list [menu $w.edit.m] [menu $w.pop.edit]] { + $m add command -label Cut -un 1 -acc Ctrl-x -command "tkConCut $text" + $m add command -label Copy -un 1 -acc Ctrl-c -command "tkConCopy $text" + $m add command -label Paste -un 0 -acc Ctrl-v -command "tkConPaste $text" + } + + ## Inspect Menu + ## Currently disabled + foreach m {} { + $m add command -label Procedures -command "tkConInspect procs" + $m add command -label "Global Vars" -command "tkConInspect vars" + $m add command -label Interpreters -command "tkConInspect interps" + $m add command -label Aliases -command "tkConInspect aliases" + $m add command -label Images -command "tkConInspect images" + $m add command -label "All Widgets" -command "tkConInspect widgets" + $m add command -label "Canvas Widgets" -command "tkConInspect canvases" + $m add command -label "Menu Widgets" -command "tkConInspect menus" + $m add command -label "Text Widgets" -command "tkConInspect texts" + } + + ## Packages Menu + ## + menu $w.pkgs.m -disabledforeground $tkCon(color,prompt) \ + -postcommand "tkConCheckPackages $w.pkgs.m" + menu $w.pop.pkgs -disabledforeground $tkCon(color,prompt) \ + -postcommand "tkConCheckPackages $w.pop.pkgs" + + ## Prefs Menu + ## + foreach m [list [menu $w.pref.m] [menu $w.pop.pref]] { + $m add checkbutton -label "Brace Highlighting" -var tkCon(lightbrace) + $m add checkbutton -label "Command Highlighting" -var tkCon(lightcmd) + $m add checkbutton -label "History Substitution" -var tkCon(subhistory) + $m add checkbutton -label "Non-Tcl Attachments" -var tkCon(nontcl) + $m add checkbutton -label "Show Multiple Matches" -var tkCon(showmultiple) + $m add checkbutton -label "Show Menubar" -var tkCon(showmenu) \ + -command "if \$tkCon(showmenu) { + pack $w -fill x -before $tkCon(scrolly) + } else { pack forget $w }" + $m add cascade -label Scrollbar -un 0 -menu $m.scroll + + ## Scrollbar Menu + ## + set m [menu $m.scroll -tearoff 0] + $m add radio -label Left -var tkCon(scrollypos) -value left -command { + pack config $tkCon(scrolly) -side left + } + $m add radio -label Right -var tkCon(scrollypos) -value right -command { + pack config $tkCon(scrolly) -side right + } + } + + ## Help Menu + ## + foreach m [list [menu $w.help.m] [menu $w.pop.help]] { + $m add command -label "About " -un 0 -acc Ctrl-A -command tkConAbout + $m add separator + $m add command -label Help -un 0 -acc Ctrl-H -command tkConHelp + } + + ## It's OK to bind to all because it's specific to each interpreter + bind all exit + bind all tkConNew + bind all tkConDestroy + bind all tkConAbout + bind all tkConHelp + bind all { + tkConAttach {} + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } + bind all { + if [string comp {} $tkCon(name)] { + tkConAttach $tkCon(name) + } else { + tkConAttach Main + } + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } + bind all { + tkConAttach Main + tkConPrompt \n [tkConCmdGet $tkCon(console)] + } +} + +## tkConCheckPackages - checks which packages are currently loaded +## Requires two loops to make sure that packages which auto-load Tk +## set everything properly. +# ARGS: w - menu name +## +proc tkConCheckPackages {{w {}}} { + global tkCon + foreach pkg [lsort [lremove [package names] Tcl]] { + if {![info exists tkCon(load$pkg)]} { set tkCon(load$pkg) 0 } + if {$tkCon(load$pkg)==1} { + if [catch {tkConEvalSlave package require $pkg}] { + bgerror "$pkg cannot be loaded. Check your pkgIndex.tcl file!!!" + set tkCon(load$pkg) -1 + } + } + } + if [string comp {} [tkConEvalSlave info commands .]] { set tkCon(loadTk) 1 } + if ![winfo exists $w] return + $w delete 0 end + foreach pkg [lsort [lremove [package names] Tcl]] { + if {$tkCon(load$pkg)==-1} { + $w add command -label "$pkg Load Failed" -state disabled + } elseif $tkCon(load$pkg) { + $w add command -label "$pkg Loaded" -state disabled + } else { + $w add checkbutton -label "Load $pkg" -var tkCon(load$pkg) \ + -command "tkConCheckPackages" + } + } +} + +## tkConFillAppsMenu - fill in in the applications sub-menu +## with a list of all the applications that currently exist. +## +proc tkConFillAppsMenu {m} { + global tkCon + + set self [tk appname] + set masters [tkConMain set tkCon(interps)] + set masternm [tkConSlave] + foreach i $masternm { + if [tkConSlave $i set tkCon(loadTk)] { + lappend slaves [tkConSlave $i tkConEvalSlave tk appname] + } else { + lappend slaves "no Tk" + } + } + set path [concat $tkCon(name) $tkCon(exec)] + set tmp [tkConInterps] + array set interps $tmp + array set tknames [concat [lrange $tmp 1 end] [list [lindex $tmp 0]]] + + catch {$m delete 0 last} + set cmd {tkConPrompt \n [tkConCmdGet $tkCon(console)]} + $m add radio -label {None (use local slave) } -var tkCon(app) -value $path \ + -command "tkConAttach {}; $cmd" -acc Ctrl-1 + $m add separator + $m add command -label "Foreign Tk Interpreters" -state disabled + foreach i [lsort [lremove [winfo interps] \ + [concat $masters $slaves [array names tknames]]]] { + $m add radio -label $i -var tkCon(app) -value $i \ + -command "tkConAttach [list $i] interp; $cmd" + } + $m add separator + + $m add command -label "TkCon Interpreters" -state disabled + foreach i [lsort [array names interps]] { + if [string match {} $interps($i)] { set interps($i) "no Tk" } + if [regexp {^Slave[0-9]+} $i] { + if [string comp $tkCon(name) $i] { + $m add radio -label "$i ($interps($i))" -var tkCon(app) -value $i \ + -command "tkConAttach [list $i] slave; $cmd" + } else { + $m add radio -label "$i ($interps($i))" -var tkCon(app) -value $i \ + -acc Ctrl-2 \ + -command "tkConAttach [list $i] slave; $cmd" + } + } else { + set name [concat Main $i] + if [string match Main $name] { + $m add radio -label "$name ($interps($i))" -var tkCon(app) \ + -value Main -acc Ctrl-3 \ + -command "tkConAttach [list $name] slave; $cmd" + } else { + $m add radio -label "$name ($interps($i))" -var tkCon(app) -value $i \ + -command "tkConAttach [list $name] slave; $cmd" + } + } + } +} + +## tkConAttach - called to attach tkCon to an interpreter +# ARGS: an - application name to which tkCon sends commands +# This is either a slave interperter name or tk appname. +# type - (slave|interp) type of interpreter we're attaching to +# slave means it's a TkCon interpreter +# interp means we'll need to 'send' to it. +# Results: tkConEvalAttached is recreated to evaluate in the +# appropriate interpreter +## +proc tkConAttach {an {type slave}} { + global tkCon + set app - + set path [concat $tkCon(name) $tkCon(exec)] + if [string comp {} $an] { + array set interps [tkConInterps] + if [string match {[Mm]ain} [lindex $an 0]] { set an [lrange $an 1 end] } + if {[string match $path $an]} { + set an {} + set app $path + set type slave + } elseif {[info exists interps($an)]} { + if [string match {} $an] { set an Main; set app Main } + set type slave + } elseif {[interp exists $an]} { + set an [concat $tkCon(name) $an] + set type slave + } elseif {[interp exists [concat $tkCon(exec) $an]]} { + set an [concat $path $an] + set type slave + } elseif {[lsearch [winfo interps] $an] > -1} { + if {$tkCon(loadTk) && [string match $an [tkConEvalSlave tk appname]]} { + set an {} + set app $path + set type slave + } elseif {[set i [lsearch [tkConMain set tkCon(interps)] $an]] > -1} { + set an [lindex [tkConMain set tkCon(slaves)] $i] + if [string match {[Mm]ain} $an] { set app Main } + set type slave + } else { + set type interp + } + } else { + error "No known interpreter \"$an\"" + } + } else { + set app $path + } + if [string match - $app] { set app $an } + set tkCon(app) $app + set tkCon(appname) $an + set tkCon(apptype) $type + + ## tkConEvalAttached - evaluates the args in the attached interpreter + ## This procedure is dynamic. It is rewritten by the proc tkConAttach + ## to ensure it evals in the right place. + # ARGS: args - the command and args to evaluate + ## + switch $type { + slave { + if [string match {} $an] { + interp alias {} tkConEvalAttached {} tkConEvalSlave + } elseif [string match Main $tkCon(app)] { + interp alias {} tkConEvalAttached {} tkConMain eval + } elseif [string match $tkCon(name) $tkCon(app)] { + interp alias {} tkConEvalAttached {} uplevel \#0 + } else { + interp alias {} tkConEvalAttached {} tkConMain interp eval $tkCon(app) + } + } + interp { + if $tkCon(nontcl) { + interp alias {} tkConEvalAttached {} tkConEvalSlave + } else { + interp alias {} tkConEvalAttached {} tkConEvalSend + } + } + default { error "[lindex [info level 0] 0] did not specify type" } + } + return +} + +## tkConLoad - sources a file into the console +# ARGS: fn - (optional) filename to source in +# Returns: selected filename ({} if nothing was selected) +## +proc tkConLoad {{fn {}}} { + global tkCon + if {[string match {} $fn] && + ([catch {tkFileSelect} fn] || [string match {} $fn])} return + tkConEvalAttached source $fn +} + +## tkConSave - saves the console buffer to a file +## This does not eval in a slave because it's not necessary +# ARGS: w - console text widget +# fn - (optional) filename to save to +## +proc tkConSave {{fn {}}} { + global tkCon + if {[string match {} $fn] && + ([catch {tkFileSelect} fn] || [string match {} $fn])} return + if [catch {open $fn w} fid] { + error "Save Error: Unable to open '$fn' for writing\n$fid" + } + puts $fid [$tkCon(console) get 1.0 end-1c] + close $fid +} + +## tkConResource - re'source's this script into current console +## Meant primarily for my development of this program. It's seems loopy +## due to quirks in Tcl on windows. +## +set tkCon(SCRIPT) [info script] +if [string match relative [file pathtype [info script]]] { + set tkCon(SCRIPT) [file join [pwd] [info script]] +} +set tkCon(SCRIPT) [eval file join [file split $tkCon(SCRIPT)]] +proc tkConResource {} "uplevel \#0 [list source $tkCon(SCRIPT)]; return" + +## tkConMainInit +## This is only called for the main interpreter to include certain procs +## that we don't want to include (or rather, just alias) in slave interps. +## +proc tkConMainInit {} { + global tkCon + + if ![info exists tkCon(slaves)] { + array set tkCon [list slave 0 slaves Main name {} interps [tk appname]] + } + interp alias {} tkConMain {} tkConInterpEval Main + interp alias {} tkConSlave {} tkConInterpEval + + ## tkConNew - create new console window + ## Creates a slave interpreter and sources in this script. + ## All other interpreters also get a command to eval function in the + ## new interpreter. + ## + proc tkConNew {} { + global argv0 argc argv tkCon + set tmp [interp create Slave[incr tkCon(slave)]] + lappend tkCon(slaves) $tmp + load {} Tk $tmp + lappend tkCon(interps) [$tmp eval [list tk appname "[tk appname] $tmp"]] + $tmp eval set argc $argc \; set argv [list $argv] \; \ + set argv0 [list $argv0] + $tmp eval [list set tkCon(name) $tmp] + $tmp eval [list source $tkCon(SCRIPT)] + $tmp alias tkConDestroy tkConDestroy $tmp + $tmp alias tkConNew tkConNew + $tmp alias tkConMain tkConInterpEval Main + $tmp alias tkConSlave tkConInterpEval + $tmp alias tkConInterps tkConInterps + return $tmp + } + + ## tkConDestroy - destroy console window + ## This proc should only be called by the main interpreter. If it is + ## called from there, it will ask before exiting TkCon. All others + ## (slaves) will just have their slave interpreter deleted, closing them. + ## + proc tkConDestroy {{slave {}}} { + global tkCon + if [string match {} $slave] { + ## Main interpreter close request + if [tk_dialog $tkCon(base).destroyme {Quit TkCon?} \ + {Closing the Main console will quit TkCon} \ + warning 0 "Don't Quit" "Quit TkCon"] exit + } else { + ## Slave interpreter close request + set name [tkConInterpEval $slave] + set tkCon(interps) [lremove $tkCon(interps) [list $name]] + set tkCon(slaves) [lremove $tkCon(slaves) [list $slave]] + interp delete $slave + } + } + + ## tkConInterpEval - passes evaluation to another named interpreter + ## If the interpreter is named, but no args are given, it returns the + ## [tk appname] of that interps master (not the associated eval slave). + ## + proc tkConInterpEval {{slave {}} args} { + if [string match {} $slave] { + global tkCon + return $tkCon(slaves) + } elseif [string match {[Mm]ain} $slave] { + set slave {} + } + if [string match {} $args] { + return [interp eval $slave tk appname] + } else { + uplevel \#0 [list interp eval $slave $args] + } + } + + proc tkConInterps {{ls {}} {interp {}}} { + if [string match {} $interp] { lappend ls {} [list [tk appname]] } + foreach i [interp slaves $interp] { + if [string comp {} $interp] { set i "$interp $i" } + if [catch "interp eval [list $i] tk appname" name] { + lappend ls $i {} + } else { + lappend ls $i $name + } + set ls [tkConInterps $ls $i] + } + return $ls + } +} + + +## tkConStateCheckpoint - checkpoints the current state of the system +## This allows you to return to this state with tkConStateRevert +# ARGS: ary - an array into which several elements are stored: +# commands - the currently defined commands +# variables - the current global vars +# This is the array you would pass to tkConRevertState +## +proc tkConStateCheckpoint {ary} { + global tkCon + upvar $ary a + set a(commands) [tkConEvalAttached info commands *] + set a(variables) [tkConEvalAttached info vars *] + return +} + +## tkConStateCompare - compare two states and output difference +# ARGS: ary1 - an array with checkpointed state +# ary2 - a second array with checkpointed state +# Outputs: +## +proc tkConStateCompare {ary1 ary2} { + upvar $ary1 a1 $ary2 a2 + puts "Commands unique to $ary1:\n[lremove $a1(commands) $a2(commands)]" + puts "Commands unique to $ary2:\n[lremove $a2(commands) $a1(commands)]" + puts "Variables unique to $ary1:\n[lremove $a1(variables) $a2(variables)]" + puts "Variables unique to $ary2:\n[lremove $a2(variables) $a1(variables)]" +} + +## tkConStateRevert - reverts interpreter to a previous state +# ARGS: ary - an array with checkpointed state +## +proc tkConStateRevert {ary} { + upvar $ary a + foreach i [lremove [tkConEvalAttached info commands *] $a(commands)] { + catch "tkConEvalAttached rename $i {}" + } + foreach i [lremove [tkConEvalAttached info vars *] $a(variables)] { + catch "tkConEvalAttached unset $i" + } +} + + +## tkcon - command that allows control over the console +# ARGS: totally variable, see internal comments +## +proc tkcon {args} { + global tkCon + switch -- [lindex $args 0] { + close { + ## Closes the console + tkConDestroy + } + clean { + ## 'cleans' the interpreter - reverting to original tkCon state + ## FIX + ## tkConStateRevert tkCon + } + console { + ## Passes the args to the text widget of the console. + eval $tkCon(console) [lreplace $args 0 0] + } + error { + ## Outputs stack caused by last error. + if [string match {} $tkCon(errorInfo)] { + set tkCon(errorInfo) {errorInfo empty} + } + catch {destroy $tkCon(base).error} + set w [toplevel $tkCon(base).error] + button $w.close -text Dismiss -command "destroy $w" + scrollbar $w.sy -takefocus 0 -bd 1 -command "$w.text yview" + text $w.text -font $tkCon(font) -yscrollcommand "$w.sy set" + pack $w.close -side bottom -fill x + pack $w.sy -side right -fill y + pack $w.text -fill both -expand 1 + $w.text insert 1.0 $tkCon(errorInfo) + $w.text config -state disabled + } + eval { + ## evals contents in master interpreter + eval [lreplace $args 0 0] + } + font { + ## "tkcon font ?fontname?". Sets the font of the console + if [string comp {} [lindex $args 1]] { + return [$tkCon(console) config -font [lindex $args 1]] + } else { + return [$tkCon(console) config -font] + } + } + hide { + ## Hides the console with 'withdraw'. + wm withdraw $tkCon(root) + } + iconify { + ## Iconifies the console with 'iconify'. + wm iconify $tkCon(root) + } + show - deiconify { + ## "tkcon show|deiconify". Deiconifies the console. + wm deiconify $tkCon(root) + } + title { + ## "tkcon title ?title?". Retitles the console + if [string comp {} [lindex $args 1]] { + return [wm title $tkCon(root) [lindex $args 1]] + } else { + return [wm title $tkCon(root)] + } + } + version { + return $tkCon(version) + } + default { + ## tries to determine if the command exists, otherwise throws error + set cmd [lindex $args 0] + set cmd tkCon[string toup [string index $cmd 0]][string range $cmd 1 end] + if [string match $cmd [info command $cmd]] { + eval $cmd [lreplace $args 0 0] + } else { + error "bad option \"[lindex $args 0]\": must be attach, close,\ + console, destroy, eval, font, hide, iconify,\ + load, main, new, save, show, slave, deiconify, title" + } + } + } +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## puts +## This allows me to capture all stdout/stderr to the console window +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +catch {rename puts tcl_puts} +proc puts args { + set len [llength $args] + if {$len==1} { + eval tkcon console insert output $args stdout {\n} stdout + tkcon console see output + } elseif {$len==2 && + [regexp {(stdout|stderr|-nonewline)} [lindex $args 0] junk tmp]} { + if [string comp $tmp -nonewline] { + eval tkcon console insert output [lreplace $args 0 0] $tmp {\n} $tmp + } else { + eval tkcon console insert output [lreplace $args 0 0] stdout + } + tkcon console see output + } elseif {$len==3 && + [regexp {(stdout|stderr)} [lreplace $args 2 2] junk tmp]} { + if [string comp [lreplace $args 1 2] -nonewline] { + eval tkcon console insert output [lrange $args 1 1] $tmp + } else { + eval tkcon console insert output [lreplace $args 0 1] $tmp + } + tkcon console see output + } else { + eval tcl_puts $args + } +} + +## clear - clears the buffer of the console (not the history though) +## This is executed in the parent interpreter +## +proc clear {{pcnt 100}} { + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + error "invalid percentage to clear: must be 1-100 (100 default)" + } elseif {$pcnt == 100} { + tkcon console delete 1.0 end + } else { + set tmp [expr $pcnt/100.0*[tkcon console index end]] + tkcon console delete 1.0 "$tmp linestart" + } +} + +## alias - akin to the csh alias command +## If called with no args, then it dumps out all current aliases +## If called with one arg, returns the alias of that arg (or {} if none) +# ARGS: newcmd - (optional) command to bind alias to +# args - command and args being aliased +## +proc alias {{newcmd {}} args} { + if [string match {} $newcmd] { + set res {} + foreach a [interp aliases] { + lappend res [list $a: [interp alias {} $a]] + } + return [join $res \n] + } elseif {[string match {} $args]} { + interp alias {} $newcmd + } else { + eval interp alias {{}} $newcmd {{}} $args + } +} + +## unalias - unaliases an alias'ed command +# ARGS: cmd - command to unbind as an alias +## +proc unalias {cmd} { + interp alias {} $cmd {} +} + +## dump - outputs variables/procedure/widget info in source'able form. +## Accepts glob style pattern matching for the names +# ARGS: type - type of thing to dump: must be variable, procedure, widget +# OPTS: -nocomplain don't complain if no vars match something +# Returns: the values of the variables in a 'source'able form +## +proc dump {type args} { + set whine 1 + set code ok + if [string match \-n* [lindex $args 0]] { + set whine 0 + set args [lreplace $args 0 0] + } + if {$whine && [string match {} $args]} { + error "wrong \# args: [lindex [info level 0] 0] ?-nocomplain? pattern ?pattern ...?" + } + set res {} + switch -glob -- $type { + v* { + # variable + # outputs variables value(s), whether array or simple. + foreach arg $args { + if {[string match {} [set vars [uplevel info vars [list $arg]]]]} { + if {[uplevel info exists $arg]} { + set vars $arg + } elseif $whine { + append res "\#\# No known variable $arg\n" + set code error + continue + } else continue + } + foreach var [lsort $vars] { + upvar $var v + if {[array exists v]} { + append res "array set $var \{\n" + foreach i [lsort [array names v]] { + upvar 0 v$$i$ w + if {[array exists w]} { + append res " [list $i {NESTED VAR ERROR}]\n" + if $whine { set code error } + } else { + append res " [list $i $v($i)]\n" + } + } + append res "\}\n" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if {[string comp {} [set ps [info proc $arg]]]} { + foreach p [lsort $ps] { + set as {} + foreach a [info args $p] { + if {[info default $p $a tmp]} { + lappend as [list $a $tmp] + } else { + lappend as $a + } + } + append res [list proc $p $as [info body $p]]\n + } + } elseif $whine { + append res "\#\# No known proc $arg\n" + } + } + } + w* { + # widget + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"[lindex $args 0]\":\ must be procedure, variable, widget" + } + } + return -code $code [string trimr $res \n] +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + if [string comp {} [info commands $cmd]] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + return "$cmd:\taliased to [alias $cmd]" + } elseif [string comp {} [info procs $cmd]] { + return "$cmd:\tinternal proc" + } else { + return "$cmd:\tinternal command" + } + } elseif [auto_execok $cmd] { + return [auto_execpath $cmd] + } else { + return "$cmd:\tunknown command" + } +} + +## auto_execpath - tells you where an external command is found +## Only a slight modification from core auto_execok proc +# ARGS: cmd - command name +# Returns: where command is found or {} if not found +## +if {[string match windows $tcl_platform(platform)]} { + proc auto_execpath name { + global auto_execpath tcl_platform env + + if [info exists auto_execpath($name)] { + return $auto_execpath($name) + } + set auto_execpath($name) {} + if {[string comp relative [file pathtype $name]]} { + foreach ext {{} .exe .bat .cmd} { + if {[file exists ${name}${ext}] && \ + ![file isdirectory ${name}${ext}]} { + set auto_execpath($name) $name + } + } + return $auto_execpath($name) + } + if {[info exists env(PATH)]} { + set path $env(PATH) + } else { + if [info exists env(Path)] { set path $env(Path) } else { return {} } + } + foreach dir [split $path {;}] { + if {[string match {} $dir]} { set dir . } + foreach ext {{} .exe .bat .cmd} { + set file [file join $dir ${name}${ext}] + if {[file exists $file] && ![file isdirectory $file]} { + set auto_execpath($name) $file + break + } + } + } + return $auto_execpath($name) + } +} else { + proc auto_execpath name { + global auto_execpath env + + if [info exists auto_execpath($name)] { + return $auto_execpath($name) + } + set auto_execpath($name) {} + if {[string comp relative [file pathtype $name]]} { + if {[file executable $name] && ![file isdirectory $name]} { + set auto_execpath($name) $name + } + return $auto_execpath($name) + } + foreach dir [split $env(PATH) :] { + if {[string match {} $dir]} { set dir . } + set file [file join $dir $name] + if {[file executable $file] && ![file isdirectory $file]} { + set auto_execpath($name) $file + break + } + } + return $auto_execpath($name) + } +} + +## dir - directory list +# ARGS: args - names/glob patterns of directories to list +# OPTS: -all - list hidden files as well (Unix dot files) +# -long - list in full format "permissions size date filename" +# -full - displays / after directories and link paths for links +# Returns: a directory listing +## +proc dir {args} { + array set s { + all 0 full 0 long 0 0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx + } + while {[string match \-* [lindex $args 0]]} { + set str [lindex $args 0] + set args [lreplace $args 0 0] + switch -glob -- $str { + -a* {set s(all) 1} -f* {set s(full) 1} -l* {set s(long) 1} -- break + default { + error "Passed unknown arg $str, should be one of: -all, -full, -long" + } + } + } + set sep [string trim [file join . .] .] + if [string match {} $args] { set args . } + foreach arg $args { + if {[file isdir $arg]} { + set arg [string trimr $arg $sep]$sep + if $s(all) { + lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]] + } else { + lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]] + } + } else { + lappend out [list [file dirname $arg]$sep \ + [lsort [glob -nocomplain -- $arg]]] + } + } + if $s(long) { + set old [clock scan {1 year ago}] + set fmt "%s%9d %s %s\n" + foreach o $out { + set d [lindex $o 0] + append res $d:\n + foreach f [lindex $o 1] { + file lstat $f st + set f [file tail $f] + if $s(full) { + switch -glob $st(type) { + d* { append f $sep } + l* { append f "@ -> [file readlink $d$sep$f]" } + default { if [file exec $d$sep$f] { append f * } } + } + } + if [string match file $st(type)] { + set mode - + } else { + set mode [string index $st(type) 0] + } + foreach j [split [format %o [expr $st(mode)&0777]] {}] { + append mode $s($j) + } + if {$st(mtime)>$old} { + set cfmt {%b %d %H:%M} + } else { + set cfmt {%b %d %Y} + } + append res [format $fmt $mode $st(size) \ + [clock format $st(mtime) -format $cfmt] $f] + } + append res \n + } + } else { + foreach o $out { + set d [lindex $o 0] + append res $d:\n + set i 0 + foreach f [lindex $o 1] { + if {[string len [file tail $f]] > $i} { + set i [string len [file tail $f]] + } + } + set i [expr $i+2+$s(full)] + set j [expr [tkcon eval set tkCon(cols)]/$i] + set k 0 + foreach f [lindex $o 1] { + set f [file tail $f] + if $s(full) { + switch -glob [file type $d$sep$f] { + d* { append f $sep } + l* { append f @ } + default { if [file exec $d$sep$f] { append f * } } + } + } + append res [format "%-${i}s" $f] + if {[incr k]%$j == 0} {set res [string trimr $res]\n} + } + append res \n\n + } + } + return [string trimr $res] +} + + +## tclindex - creates the tclIndex file +# OPTS: -ext - extensions to auto index (defaults to *.tcl) +# ARGS: args - directories to auto index (defaults to pwd) +# Outputs: tclIndex file to each directory +## +proc tclindex args { + set ext {*.tcl} + if [string match \-e* [lindex $args 0]] { + set ext [lindex $args 1] + set args [lreplace $args 0 1] + } + if [string match {} $args] { + eval auto_mkindex [list [pwd]] $ext + } else { + foreach dir $args { + if [file isdir $dir] { eval auto_mkindex [list $dir] $ext } + } + } +} + +## lremove - remove items from a list +# OPTS: -all remove all instances of each item +# ARGS: l a list to remove items from +# is a list of items to remove +## +proc lremove {args} { + set all 0 + if [string match \-a* [lindex $args 0]] { + set all 1 + set args [lreplace $args 0 0] + } + set l [lindex $args 0] + eval append is [lreplace $args 0 0] + foreach i $is { + if {[set ix [lsearch -exact $l $i]] == -1} continue + set l [lreplace $l $ix $ix] + if $all { + while {[set ix [lsearch -exact $l $i]] != -1} { + set l [lreplace $l $i $i] + } + } + } + return $l +} + + +## Unknown changed to get output into tkCon window +# unknown: +# Invoked when a Tcl command is invoked that doesn't exist in the +# interpreter: +# +# 1. See if the autoload facility can locate the command in a +# Tcl script file. If so, load it and execute it. +# 2. If the command was invoked interactively at top-level: +# (a) see if the command exists as an executable UNIX program. +# If so, "exec" the command. +# (b) see if the command requests csh-like history substitution +# in one of the common forms !!, !, or ^old^new. If +# so, emulate csh's history substitution. +# (c) see if the command is a unique abbreviation for another +# command. If so, invoke the command. +# +# Arguments: +# args - A list whose elements are the words of the original +# command, including the command name. + +proc unknown args { + global auto_noexec auto_noload env unknown_pending tcl_interactive tkCon + global errorCode errorInfo + + # Save the values of errorCode and errorInfo variables, since they + # may get modified if caught errors occur below. The variables will + # be restored just before re-executing the missing command. + + set savedErrorCode $errorCode + set savedErrorInfo $errorInfo + set name [lindex $args 0] + if ![info exists auto_noload] { + # + # Make sure we're not trying to load the same proc twice. + # + if [info exists unknown_pending($name)] { + unset unknown_pending($name) + if {[array size unknown_pending] == 0} { + unset unknown_pending + } + return -code error "self-referential recursion in \"unknown\" for command \"$name\""; + } + set unknown_pending($name) pending; + set ret [catch {auto_load $name} msg] + unset unknown_pending($name); + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error while autoloading \"$name\": $msg" + } + if ![array size unknown_pending] { + unset unknown_pending + } + if $msg { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + set code [catch {uplevel $args} msg] + if {$code == 1} { + # + # Strip the last five lines off the error stack (they're + # from the "uplevel" command). + # + + set new [split $errorInfo \n] + set new [join [lrange $new 0 [expr [llength $new] - 6]] \n] + return -code error -errorcode $errorCode \ + -errorinfo $new $msg + } else { + return -code $code $msg + } + } + } + if {[info level] == 1 && [string match {} [info script]] \ + && [info exists tcl_interactive] && $tcl_interactive} { + if ![info exists auto_noexec] { + if [auto_execok $name] { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + return [uplevel exec $args] + #return [uplevel exec >&@stdout <@stdin $args] + } + } + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + ## + ## History substitution moved into tkConEvalCmd + ## + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel [lreplace $args 0 0 $cmds]] + } + if {[llength $cmds]} { + if {$name == ""} { + return -code error "empty command name \"\"" + } else { + return -code error \ + "ambiguous command name \"$name\": [lsort $cmds]" + } + } + } + return -code error "invalid command name \"$name\"" +} + + +#------------------------------------------------------------------------- +# Elements of tkPriv that are used in this file: +# +# char - Character position on the line; kept in order +# to allow moving up or down past short lines while +# still remembering the desired position. +# mouseMoved - Non-zero means the mouse has moved a significant +# amount since the button went down (so, for example, +# start dragging out a selection). +# prevPos - Used when moving up or down lines via the keyboard. +# Keeps track of the previous insert position, so +# we can distinguish a series of ups and downs, all +# in a row, from a new up or down. +# selectMode - The style of selection currently underway: +# char, word, or line. +# x, y - Last known mouse coordinates for scanning +# and auto-scanning. +#------------------------------------------------------------------------- + +# tkConClipboardKeysyms -- +# This procedure is invoked to identify the keys that correspond to +# the "copy", "cut", and "paste" functions for the clipboard. +# +# Arguments: +# copy - Name of the key (keysym name plus modifiers, if any, +# such as "Meta-y") used for the copy operation. +# cut - Name of the key used for the cut operation. +# paste - Name of the key used for the paste operation. + +proc tkConClipboardKeysyms {copy cut paste} { + bind Console <$copy> {tkConCopy %W} + bind Console <$cut> {tkConCut %W} + bind Console <$paste> {tkConPaste %W} +} + +proc tkConCut w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch { + clipboard append -displayof $w [selection get -displayof $w] + if [$w compare sel.first >= limit] {$w delete sel.first sel.last} + } + } +} +proc tkConCopy w { + if [string match $w [selection own -displayof $w]] { + clipboard clear -displayof $w + catch {clipboard append -displayof $w [selection get -displayof $w]} + } +} + +proc tkConPaste w { + if ![catch {selection get -displayof $w -selection CLIPBOARD} tmp] { + if [$w compare insert < limit] {$w mark set insert end} + $w insert insert $tmp + $w see insert + if [string match *\n* $tmp] {tkConEval $w} + } +} + +## Get all Text bindings into Console except Unix cut/copy/paste +## and newline insertion +foreach ev [lremove [bind Text] {

\ +

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