From 64d1425f65568851a1004cbdac170780e95720a2 Mon Sep 17 00:00:00 2001 From: William Joye Date: Tue, 18 Oct 2016 14:04:50 -0400 Subject: Squashed 'tkcon/' content from commit 7538c6d git-subtree-dir: tkcon git-subtree-split: 7538c6d85045099e5ae91c81afa6ca6361429bf2 --- ChangeLog | 607 +++++ README.txt | 42 + docs/bindings.html | 154 ++ docs/changes.txt | 815 ++++++ docs/demopic.png | Bin 0 -> 42253 bytes docs/dump.html | 100 + docs/dump.n.man | 60 + docs/idebug.html | 125 + docs/idebug.n.man | 83 + docs/index.html | 81 + docs/license.terms | 33 + docs/limits.html | 76 + docs/nontcl.html | 75 + docs/observe.html | 104 + docs/observe.n.man | 55 + docs/perl.txt | 109 + docs/plugin.html | 113 + docs/procs.html | 167 ++ docs/purpose.html | 87 + docs/start.html | 358 +++ docs/style.css | 50 + docs/tkcon.1.man | 369 +++ docs/tkcon.html | 189 ++ docs/tkcon.n.man | 140 + docs/tkconrc.5.man | 249 ++ docs/todo.html | 99 + extra/console1_1.tcl | 2209 ++++++++++++++++ extra/stripped.tcl | 1083 ++++++++ icons/tkcon-small.svg | 534 ++++ icons/tkcon-small48.png | Bin 0 -> 4183 bytes index.html | 70 + install-desktop-menu.sh | 26 + pkgIndex.tcl | 11 + tkcon-console.desktop | 10 + tkcon.tcl | 6539 +++++++++++++++++++++++++++++++++++++++++++++++ 35 files changed, 14822 insertions(+) create mode 100644 ChangeLog create mode 100644 README.txt create mode 100755 docs/bindings.html create mode 100755 docs/changes.txt create mode 100644 docs/demopic.png create mode 100755 docs/dump.html create mode 100644 docs/dump.n.man create mode 100755 docs/idebug.html create mode 100644 docs/idebug.n.man create mode 100755 docs/index.html create mode 100755 docs/license.terms create mode 100755 docs/limits.html create mode 100755 docs/nontcl.html create mode 100755 docs/observe.html create mode 100644 docs/observe.n.man create mode 100755 docs/perl.txt create mode 100755 docs/plugin.html create mode 100755 docs/procs.html create mode 100755 docs/purpose.html create mode 100755 docs/start.html create mode 100644 docs/style.css create mode 100644 docs/tkcon.1.man create mode 100755 docs/tkcon.html create mode 100644 docs/tkcon.n.man create mode 100644 docs/tkconrc.5.man create mode 100755 docs/todo.html create mode 100644 extra/console1_1.tcl create mode 100755 extra/stripped.tcl create mode 100644 icons/tkcon-small.svg create mode 100644 icons/tkcon-small48.png create mode 100755 index.html create mode 100755 install-desktop-menu.sh create mode 100644 pkgIndex.tcl create mode 100644 tkcon-console.desktop create mode 100755 tkcon.tcl diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..5931e4d --- /dev/null +++ b/ChangeLog @@ -0,0 +1,607 @@ +2016-09-14 Jeff Hobbs + + * tkcon.tcl: Use -underline clearly to disambiguate from new 8.6.6 + option -underlinefg [Bug #54] (bachmann) + +2015-10-20 Jeff Hobbs + + * tkcon.tcl (edit): prevent file edit from undoing loading of file + [Bug #52] (budyak) + +2014-09-09 Jeff Hobbs + + * tkcon.tcl (::tkcon::SaveHistory): save history at each command + to prevent loss during abnormal termination. [bachmann] + +2014-07-09 Jeff Hobbs + + * tkcon.tcl (idebug): allow multi-char patterns as debug id [Lama] + +2013-01-22 Jeff Hobbs + + * tkcon.tcl (tkcon show): catch deiconify as it will throw an + error if tkcon is embedded. + +2012-12-27 Jeff Hobbs + + * tkcon.tcl (edit): add support for ::tkcon::OPT(tabspace) to + adjust tab spacing in edit window (default: 8). [Bug #7] + + * tkcon.tcl (::tkcon::Bindings): minimal patch for 8.6b3+ event + compatibility. Larger patch to come that addresses shift towards + virtual events in core widgets. [Bug #48] (gollwitzer) + + * docs/{dump.man,tkcon.1.man,tkconc.5.man}: make dtplite happy for + the docs [Bug #47] + + * tkcon.tcl (::tkcon::Init): update to use latest /viewvc/tkcon + url to retrieve head version of tkcon. + + * tkcon.tcl (::tkcon::InitUI): catch deiconify to prevent error + when embedding. [Bug #44] + + * tkcon.tcl (::tkcon::ExpandMethodname): improved expansion for + xotcl methods. Also enhance expansion to allow break/continue + signals to differentiate "I'm not responsible" results from "I + don't have any results". (neumann) + + * tkcon.tcl (::tkcon::InitInterp): correct sending tkcon commands + to user created interps [Bug #42] (kuhn) + +2012-03-06 Jeff Hobbs + + * tkcon.tcl (idebug): better line handling to not use list + functions. [Bug 111462] (goth) + (tkcon): pass any init args to 'tkcon show' + +2011-10-28 Jeff Hobbs + + * pkgIndex.tcl: update to v2.7 + * tkcon.tcl: Improve UI to work on OS X. Adjust some dialogs, + use Command- instead of Control- bindings on OS X. Handle right + click properly. + + * docs/license.terms: removed outdated restricted rights section. + +2010-01-24 Pat Thoyts + + * icons/*: Added an SVG icon and .desktop file suitable + * tkcon-console.desktop: for use installing tkcon into the desktop + * install-desktop-menu.sh: menus on a unix desktop. Also an install + * tkcon.tcl: script to show how it is done. And for + use with 8.6 on X11 - if we can locate the icon, use it as the + tkcon iconphoto so it shows up associated with the running app. + +2010-01-23 Pat Thoyts + + * tkcon.tcl: Make use of the extended window manager hints from + tip 359 on unix for all the dialog windows. + +2009-04-24 Jeff Hobbs + + * tkcon.tcl: override 8.5 [chan puts|gets]. [Bug 1876707] + + * tkcon.tcl: update pre-8.4 private text binding refs + + * tkcon.tcl: clean up cmd global var used [Bug 2441583] + + * tkcon.tcl (::tkcon::Retrieve): support http code redirect for + downloading latest version. [Bug 1755500] + + * README.txt, docs/limits.html, docs/nontcl.html: bump to 2.6 + * pkgIndex.tcl, tkcon.tcl: Use Tcl 8.4 code style. + +2009-02-26 Jeff Hobbs + + **** TKCON 2.5 TAGGED FOR RELEASE **** + + * index.html, docs/*.html: update links and references + +2009-02-25 Jeff Hobbs + + * docs/tkcon.html, docs/tkcon.n.man: add tkcon resultfilter docs. + +2008-02-07 Jeff Hobbs + + * tkcon.tcl (::tkcon::Bindings): prevent Expand virtual events + from triggering follow-on events (most important for ). + (::tkcon::Retrieve): remove extraneous http::geturl call. + +2007-06-22 Jeff Hobbs + + * tkcon.tcl (::tkcon::EvalCmd): add OPT(resultfilter) and 'tkcon + resultfilter ?cmd?' to allow optional result filter command. + Command will be passed result code and data and must return what + tkcon will return to the user. Command is run in attached slave. + Ensure that initial files are sources at level #0. + Convert args after (--|-argv|-args) into slave arguments and set + them as the main $::argv/$::argc for propagation. + +2007-06-21 Jeff Hobbs + + * docs/tkcon.1.man, docs/tkcon.n.man, docs/tkconrc.5.man (new): + * docs/dump.n.man, docs/observe.n.man, docs/idebug.n.man (new): + * index.html, docs/demopic.gif (removed), docs/demopic.png (new): + * docs/plugin.html, docs/start.html, docs/tkcon.html: + Updated docs and added doctools equivalents courtesy Sergei Golovan + * docs/style.css: updated stylesheet + +2007-04-04 Jeff Hobbs + + *** BUMPED TO VERSION 2.5 *** + + * tkcon.tcl: ensure option overrides only effect tkcon and + subwidgets. + (edit): Add -wrap option to 'edit' command. + (::tkcon::AtSource): adjust argv0 existence check + +2006-09-05 Jeff Hobbs + + * tkcon.tcl (::tkcon::NewTab, ::tkcon::GetSlave): ensure that new + tabs in other toplevel tkcon windows are built in the correct + slave hierarchy. + + * pkgIndex.tcl: sample pkgIndex.tcl that allows using tkcon as a + package. + + * tkcon.tcl (::tkcon::InitSlave): adjust to make the first file + passed in to be argv0 in the slave + +2006-08-25 Jeff Hobbs + + * tkcon.tcl (tkcon): default wm protocol to hide tkcon when used + in embedded context. + +2006-08-23 Jeff Hobbs + + * tkcon.tcl: remove use of -exact in package require Tk + +2006-06-29 Jeff Hobbs + + * tkcon.tcl: updated to handle ttk scrollbars as well as other UI + cleanup. + +2006-06-15 Jeff Hobbs + + * tkcon.tcl: modify CVS location after SF changes + + * README.txt: correct reference email address + +2006-02-28 Jeff Hobbs + + * tkcon.tcl (tkcon): update 'gets stdin' override (tkcon congets) + to support usage at script load time. (decoster) + +2006-01-25 Jeff Hobbs + + * tkcon.tcl (MenuConfigure): Fix ActiveTcl Help link when pointing + to a file with space in path. [Bug 1408425] + (::tkcon::Save, ::tkcon::Load): in VFS paths, use the X11 dialogs + that support viewing in VFS dirs. + +2005-09-12 Jeff Hobbs + + * tkcon.tcl (::tkcon::AtSource): do not require argv to be defined + (edit): enable text -undo in editor + (::tkcon::InitUI): shrink aqua resize control space alloted + +2005-07-14 Jeff Hobbs + + * tkcon.tcl: add ::tkcon::OPT(maxlinelen) (default 0 == unlimited) + and 'tkcon linelength ?value?' to optionally limit long result + lines. True result is still captured in $_ (and 'puts $_' works). + +2005-05-25 Jeff Hobbs + + * tkcon.tcl (InitMenus): add ActiveTcl Help menu item, if AT Help + is found. + +2005-04-06 Jeff Hobbs + + * tkcon.tcl (ExpandXotcl): allow for xotcl method name expansion, + if you change ::tkcon::OPT(expandorder) to include Xotcl before + Procname + +2005-02-21 Jeff Hobbs + + * tkcon.tcl (::send::send): propagate -displayof to winfo interps + call. [Bug 1124369] (mbec) + +2004-11-17 Jeff Hobbs + + * tkcon.tcl (::tkcon::ExpandVariable): correct array keyname + expansion. [Bug 1004508] (bold) + +2004-11-12 Jeff Hobbs + + * tkcon.tcl (::tkcon::EvalSocket): pass sock arg. (allaert) + +2004-11-11 Jeff Hobbs + + * tkcon.tcl (::tkcon::DeleteTab): allow for exit code to be passed + when exit is aliased to DeleteTab. [Bug 1064462] + (::tkcon::Expect): graphicsSet isn't valid yet + +2004-10-10 Jeff Hobbs + + * tkcon.tcl (::tkcon::Highlight): use ctext for the 'edit' dialog + if available + +2004-07-26 Jeff Hobbs + + **** TKCON 2.4 TAGGED FOR RELEASE **** + + * index.html, docs/*.html: remove email links, update 2.4 info + * docs/plugin.html: update plugin page embed code + +2004-06-24 Jeff Hobbs + + * tkcon.tcl (DeleteTab, Destroy): improve the 'exit' handling so + that 'exit' in the first created tab doesn't do a full exit. + 'exit' in the last tab of the first created console still exits + tkcon, fixing that requires a rearch of the console + creation/management. + (InitTab): Have the binding only fire for the root + window, not for each tab. + (GotoTab): Keep tabs around - just raise/lower instead of grid + remove/add. break on Next/Prev Tab binding to get focus right. + (Prompt): return if console w doesn't exist + +2004-06-10 Jeff Hobbs + + * tkcon.tcl: add [X] tab delete button and Console -> Delete Tab + menu item. [Bug 970785] + +2004-05-12 Jeff Hobbs + + * tkcon.tcl (observe): allow observe of 'proc' + +2004-03-20 Jeff Hobbs + + * tkcon.tcl (::tkcon::EvalSocketEvent): correctly handle socket + events after attachment changes + +2004-03-01 Jeff Hobbs + + * tkcon.tcl: correct 'exit' in extra tabs. + make tkconfixed font Courier -12 (was Courier 10), use it on unix. + Add extra space for OS X/Aqua in statusbar (for resize handle). + Only use -overrelief in 8.4 + +2004-02-12 Jeff Hobbs + + * tkcon.tcl (::tkcon::InitUI): check existence of tcl_platform(os) + as it doesn't exist in the Tcl plugin. + Show Attach info in tab text, maintain namespace attachment + between console switches. + (::tkcon::InterpEval, Interps): beware safe interps with Tk + +2004-02-05 Jeff Hobbs + + * tkcon.tcl: brought code back to 8.0 compatability. + Use $_ as last cached result var (was ${}). + Ensure hoterrors garbage collection occurs across all tabs. + +2004-01-29 Jeff Hobbs + + * tkcon.tcl: first whack at tabbed consoles + +2004-01-28 Jeff Hobbs + + * tkcon.tcl: don't use menu tearoffs + remove recognizable email addresses from source + enabled more send variants (comm, dde, winsend) [bug 649257] (thoyts) + change Packages menu (that would be too large with many packages) + to a Manage Packages dialog. + tightened up Create Socket dialog, added dismiss binding. + Moved source time initialization into ::tkcon::AtSource to guard + against leftover vars and just better encapsulate it. + (::tkcon::Retrieve): correct retrieve URL and add intelligence to + sense whether what we retrieved is correct before overwriting file. + +2003-11-18 Jeff Hobbs + + * tkcon.tcl (::tkcon::InitSlave): remove tk_library from the + seeded auto_path. Do not add OPT(library) to auto_path if it is "". + +2003-11-04 Jeff Hobbs + + * tkcon.tcl (::tkcon::EvalSocketClosed): use tk_messageBox instead + of tk_dialog + +2003-10-06 Jeff Hobbs + + * tkcon.tcl (dir): use %9ld instead of %9d to support large files + +2003-04-08 Jeff Hobbs + + * tkcon.tcl (::tkcon::InitUI): WinCE code to resize the window to + fit on the small screen + +2003-03-31 Jeff Hobbs + + * tkcon.tcl (tkcon::Retrieve): correct the check for tkcon version + when retrieving from http. + +2003-02-20 Jeff Hobbs + + * tkcon.tcl (EvalCmd): set $:: (aka ${}) var to last command result. + (EvalOther): use tk_messageBox instead of tk_dialog + (Init): allow 'edit' to be overridden using OPT(edit) + +2003-01-13 Jeff Hobbs + + * tkcon.tcl: add tk appname alias in WWW plugin case. + +2002-10-08 Jeff Hobbs + + * tkcon.tcl (tcl_unknown): allow ::namespace (:'s) to be + recognized. (koloska) + (MainInit): add option for overriding exit command. + (InitUI): add option to control the wm protocol for WM_DELETE_WINDOW. + +2002-10-01 Jeff Hobbs + + * tkcon.tcl (InterpEval): correctly handle no args case. + (New): autoload tbcload when it exists. + +2002-06-22 Jeff Hobbs + + * tkcon.tcl: call Init with eval to break out argv into args. + +2002-06-04 Jeff Hobbs + + * tkcon.tcl (Init): convert env(home) from 'C:' to 'C:/' if necessary. + +2002-06-03 Jeff Hobbs + + * tkcon.tcl: fixed Retrieve to use the proxy info (Thoyts). + Added code so that tkcon.tcl can be sourced in and used like a + quasi-package. Once sourced, you can do a 'package require tkcon' + (there is no pkgIndex.tcl for it), and the first 'tkcon show' will + initialize anything that is needed. + (observe): corrected variables tracing to not allow duplicates. + (dump): improved check for empty named arrays as well as locally + aliased vars in var dumps. + Use the 'fixed' font on unix by default. + +2002-02-22 Jeff Hobbs + + * tkcon.tcl (AddSlaveHistory): changed history to not add the + command if it is the same as the previous command (it will still + be evaluated). (soderstrom) + Added panedwindow and labelframe as recognized Tk commands. + +2002-01-24 Jeff Hobbs + + **** TKCON 2.3 RELEASE **** + + * tkcon.tcl: bumped to v2.3 + +2002-01-23 Jeff Hobbs + + * docs/procs.html: + * tkcon.tcl (what): changed to differentiate between 'array' and + 'scalar' instead of just returning 'variable'. + (which): called what in uplevel to get scope right. + +2002-01-22 Jeff Hobbs + + * tkcon.tcl (ExpandPathname): use a safer regsub to first unescape + the str, then to protect it in the glob. + (dir): Use -directory arg in 8.3+ for better results. + + * docs/idebug.html: added note about ? help at debug prompt. + + * tkcon.tcl (dir): prevented possible 'divide by zero' error. + [Bug #496584] + (Expand*): fixed ExpandPathname to better handle spaced pathnames. + [Bug #497079] + +2001-12-14 Jeff Hobbs + + * tkcon.tcl: 'tkcon show' causes loss of focus on Windows, so an + extra focus to the console was added. + +2001-12-12 Jeff Hobbs + + * tkcon.tcl (EvalSocketEvent): changed EvalSocketClosed to only + occur after gets, then eof check. (Gerold Jury) + +2001-11-14 Jeff Hobbs + + * tkcon.tcl: added catch around file type call + +2001-10-14 Jeff Hobbs + + * tkcon.tcl (Init): corrected loading of rcfile when it was in a + path including spaces. (siltberg) + (About): clarified CVS info in about box. + + * docs/start.html: correct old refs to TKCON var. + +2001-09-28 Jeff Hobbs + + * tkcon.tcl (ExpandPathname): recognize NT as a case *in*sensitive + file system for pathname expansion. + +2001-08-31 Jeff Hobbs + + * tkcon.tcl (InitSlave): propagate auto_path from master to slave. + +2001-08-24 Jeff Hobbs + + * tkcon.tcl (NewSocket, NewDisplay): when nothing is specified, + just return. + (Display): fixed connecting to interps on other displays. + +2001-08-22 Jeff Hobbs + + * docs/bindings.html: noted ^r/^s change. + + * tkcon.tcl (Event): changed event ^r/^s searching to search for + any matching substring, and blink the substring. + Added statusbar, default off (not much in status yet). + +2001-08-20 Jeff Hobbs + + * tkcon.tcl (EvalNamespace): fixed to work when attached to a + foreign interpreter. [Bug #453431] + Added fix that allows access to Tk privates in 8.4. Still needs + a long-term fix. [Bug #450865] (porter) + +2001-08-03 Jeff Hobbs + + * tkcon.tcl (EvalCmd): protected against non-existent + tkPriv(mouseMoved) variable + +2001-07-05 Jeff Hobbs + + * tkcon.tcl (RetrieveFilter, RetrieveAuthentication): added + support for retrieving latest tkcon via a proxy. (Thoyts) + +2001-07-04 Jeff Hobbs + + * tkcon.tcl (tkcon): made tkcon console return whatever result it + received. Fixed Bug #438281. + +2001-06-20 Jeff Hobbs + + TKCON 2.2 RELEASE + + * README.txt: + * index.html: + * docs/index.html: updated for 2.2 release + + * tkcon.tcl (InitUI): moved wm protocol inside check to not run + under plugin. + (::tkcon::Retrieve): added a new method to allow tkcon to retrieve + the latest version of itself. + +2001-06-19 Jeff Hobbs + + * tkcon.tcl (dir): added fallback in generic dir command to not + require being run in tkcon. + (Init): Changed around how all options are initialized to allow + for tkcon embedders to set their own defaults. Added a usehistory + PRIV key that tells us whether to load/save history files. Added + showOnStartup PRIV key to control whether tkcon should deiconify + itself on startup. Changed setting root to .tkcon to ensure that + root was just . before. + +2001-06-18 Jeff Hobbs + + * tkcon.tcl: (InitUI) added WM_DELETE_WINDOW hook to exit to + correctly deconstruct slave consoles. + (tkcon congets/getc) added tkcon show to ensure that tkcon would + be displayed when input is expected. + (GetSelection) new command to handle getting selection, this + supports the new UTF8_STRING type. + (InitMenus) added version check around Attach to Socket menu, as + 8.3 is need for the file channels call. + +2001-05-28 Jeff Hobbs + + * docs/start.html: added note about ::tkcon::OPT(gets) var. + * docs/tkcon.html: improved docs for tkcon *get* methods. + * tkcon.tcl: reinstituted override of gets by default to use the + tkcon console based gets. + + * tkcon.tcl (dump): corrected outputting local vars with dump. + Added RCS info to PRIV array and About box. + (tkcon congets) corrected congets to set the limit and insert + properly to return data without needing to call the prompt. + (tkcon set) corrected to return [array get] string for arrays, + and scalar value for vars. + Placed exact level value to all calls to uplevel and upvar. + +2001-05-17 Jeff Hobbs + + * tkcon.tcl: make check for actual tkcon root existence to allow + for setting the var ($::tkcon::PRIV(root)) in controlling apps to + better control the root window. + +2001-05-04 Jeff Hobbs + + TKCON 2.1 RELEASE + + * docs/style.css: new file for html files to use. + * README.txt: + * index.html: + * doc/*: updated for 2.1 release. + + * tkcon.tcl: allowed 'tkcon font ...' and 'tkcon buffer ...' to + work before the main console have been created. + Changed "TkCon" -> "tkcon", updated for new release. + +2001-03-28 Jeff Hobbs + + * tkcon.tcl (::tkcon::Init): added safe interp check around 'cd' + call for Macs + +2000-10-30 Jeff Hobbs + + * tkcon.tcl (dir): fixed bug where permissions wouldn't print + correctly if user had no permissions. (kuchler) + +2000-10-18 Jeff Hobbs + + * tkcon.tcl (::tkcon::NamespacesList): corrected to not use window + starting with an uppercase letter (error). (reins) + +2000-09-27 Jeff Hobbs + + * tkcon.tcl (::tkcon::About): added 'variable COLOR' decl (Zaers). + +2000-09-20 Jeff Hobbs + + * tkcon.tcl (InitMenus): restricted the Attach Socket + functionality to Tcl 8.3+ due to use of [file channels]. + (InitUI): fixed Configure binding to use correct namespace for OPT + (EvalSocket, EvalSend, EvalAttached): cleaned up to require that + they accept only one arg as the command string to be evaluated. + Prior behavior left some ambiguity as to what was eval'ed where. + EvalOther, EvalSlave may need some sanitation as well. + (EvalCmd): Changed EvalSocket functionality to have the \'s + substituted before sending data, to allow for special chars to be + added to the string. + +2000-09-19 Jeff Hobbs + + * tkcon.tcl (::tkcon::InitUI): corrected plugin handling, as 'wm + withdraw' worked, but 'wm deiconify' was disallowed. + + * docs/plugin.html: updated link to plugin source + * docs/changes.txt: noted that changes.txt is no longer updated in + favor of this ChangeLog + + * index.html: updated page with sourceforge links + * index.html: added toplevel html index doc + + * tkcon.tcl: updated v2.0 to v2.1 alpha version + All tkcon procedures have been namespaced, except for the ones + that are visible to the user. TkCon has added the ability to + attach to other displays or a socket. + + * tkcon.tcl: updated v1.6 to v2.0 version, tagged tkcon-2-0 + This is the first version to require 8.0+ to run, although it + will still connect to older interps. + + * tkcon.tcl: updated v1.5 to v1.6 version, tagged tkcon-1-6 + * tkcon.tcl: updated v1.4 to v1.5 version, tagged tkcon-1-5 + * tkcon.tcl: updated v1.3 to v1.4 version, tagged tkcon-1-4 + * tkcon.tcl: updated v1.2 to v1.3 version, tagged tkcon-1-3 + * tkcon.tcl: updated v1.1 to v1.2 version, tagged tkcon-1-2 + * tkcon.tcl: updated v1.03 to v1.1 version, tagged tkcon-1-1 + * tkcon.tcl: updated v1.02 to v1.03 version, tagged tkcon-1-03 + * tkcon.tcl: updated v0.71 to v1.02 version, tagged tkcon-1-02 + * tkcon.tcl: updated v0.69 to v0.71 version, tagged tkcon-0-71 + * tkcon.tcl: updated v0.68 to v0.69 version, tagged tkcon-0-69 + * tkcon.tcl: updated v0.67 to v0.68 version, tagged tkcon-0-68 + * tkcon.tcl: updated v0.66 to v0.67 version, tagged tkcon-0-67 + * tkcon.tcl: updated v0.65 to v0.66 version, tagged tkcon-0-66 + * tkcon.tcl: updated v0.64 to v0.65 version, tagged tkcon-0-65 + * tkcon.tcl: updated v0.63 to v0.64 version, tagged tkcon-0-64 + * tkcon.tcl: updated v0.52 to v0.63 version, tagged tkcon-0-63 + + * ChangeLog: added a ChangeLog diff --git a/README.txt b/README.txt new file mode 100644 index 0000000..cd9b6cc --- /dev/null +++ b/README.txt @@ -0,0 +1,42 @@ +WHAT: Enhanced Tk Console for all Tk platforms + +WHERE: http://tkcon.sourceforge.net/ + http://www.purl.org/net/hobbs/tcl/script/ + +REQUIREMENTS: Tcl/Tk 8.4+ + Tested through Tcl/Tk 8.6. + 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 and tabbed 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 at hobbs dot 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 and OS X, I place it +in a directory on my path and run this instead of wish. + +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..f6a13c5 --- /dev/null +++ b/docs/bindings.html @@ -0,0 +1,154 @@ + + +tkcon: Special Bindings + + + + + +
+ + + + + + +
tkcon: Special Bindings + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ +
+ + + + + + + + + + + + + + +
Getting StartedSpecial BindingsProceduresScreenshot
dumptkconidebugobserve
+ +
+
+

+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 any command that contains the +string in the current command line. Repeatable to search farther back. +The matching substring off the found command will blink. +
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?). +
+
+ +
+
© Jeffrey Hobbs
+ + + diff --git a/docs/changes.txt b/docs/changes.txt new file mode 100755 index 0000000..b0c8ed6 --- /dev/null +++ b/docs/changes.txt @@ -0,0 +1,815 @@ +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). +------------------------------------------------------------------------- + +THIS FILE IS NO LONGER PERTINENT. + +All changes are now recorded in the ChangeLog. + +---- 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.png b/docs/demopic.png new file mode 100644 index 0000000..799c09c Binary files /dev/null and b/docs/demopic.png differ diff --git a/docs/dump.html b/docs/dump.html new file mode 100755 index 0000000..87e7873 --- /dev/null +++ b/docs/dump.html @@ -0,0 +1,100 @@ + + +tkcon: dump procedure + + + + + +
+ + + + + + +
tkcon: dump procedure + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ +
+ + + + + + + + + + + + + + +
Getting StartedSpecial BindingsProceduresScreenshot
dumptkconidebugobserve
+ +
+
+

+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 {.*}) + +
+
+
+ +
+
© Jeffrey Hobbs
+ + + diff --git a/docs/dump.n.man b/docs/dump.n.man new file mode 100644 index 0000000..9dbccdb --- /dev/null +++ b/docs/dump.n.man @@ -0,0 +1,60 @@ +[comment {-*- tcl -*- dump manpage}] +[manpage_begin dump n 2.5] +[copyright {Jeffrey Hobbs }] +[moddesc {TkCon}] +[titledesc {Dump information about Tcl interpreter in TkCon}] + +[description] +[para] +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: + +[list_begin definitions] + +[call [cmd dump] [arg method]\ + [opt [arg -nocomplain]]\ + [opt [arg "-filter pattern"]]\ + [opt [cmd --]]\ + [arg pattern]\ + [opt [arg "pattern ..."]]] + +[list_end] + +[para] +The patterns represent glob-style patterns (as in [cmd string] [arg {match pattern $str}]). +[arg -nocomplain] will prevent dump from throwing an error if no items +matched the pattern. +[arg -filter] is interpreted as appropriate for the method. +The various methods are: + +[list_begin definitions] + +[def "[cmd dump] [arg command] [arg args]"] +Outputs one or more commands. + +[def "[cmd dump] [arg procedure] [arg args]"] +Outputs one or more procs in sourceable form. + +[def "[cmd dump] [arg variable] [arg 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. + +[def "[cmd dump] [arg widget] [arg 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 {.*}). + +[list_end] + +[see_also [cmd tkcon](1)] +[see_also [cmd tkconrc](5) [cmd tkcon](n) [cmd idebug](n)] +[see_also [cmd observe](n)] +[keywords Tk console dump] + +[manpage_end] + diff --git a/docs/idebug.html b/docs/idebug.html new file mode 100755 index 0000000..8a98ec1 --- /dev/null +++ b/docs/idebug.html @@ -0,0 +1,125 @@ + + +tkcon: idebug procedure + + + + + +
+ + + + + + +
tkcon: idebug procedure + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ +
+ + + + + + + + + + + + + + +
Getting StartedSpecial BindingsProceduresScreenshot
dumptkconidebugobserve
+ +
+
+

+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 works for minimal debugging sessions. 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. +To see the special commands available at the debug prompt, type ? +and hit return. + +
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. + +
+
+
+ +
+
© Jeffrey Hobbs
+ + + diff --git a/docs/idebug.n.man b/docs/idebug.n.man new file mode 100644 index 0000000..1547081 --- /dev/null +++ b/docs/idebug.n.man @@ -0,0 +1,83 @@ +[comment {-*- tcl -*- idebug manpage}] +[manpage_begin idebug n 2.5] +[copyright {Jeffrey Hobbs }] +[moddesc {TkCon}] +[titledesc {Interactive debugging environment in TkCon}] + +[description] +[para] +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 [arg body], [arg show] & [arg trace] methods are +intended for internal use only. + +This procedure works for minimal debugging sessions. +Comments are encouraged. + +[list_begin definitions] + +[call [cmd idebug] [arg body] [opt [arg level]]] +Prints out the body of the command (if it is a procedure) +at the specified level. +level defaults to the current level. + +[call [cmd idebug] [arg break] [opt [arg id]]] +Creates a breakpoint within a procedure. +This will only trigger if idebug is on and the [arg 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. +To see the special commands available at the debug prompt, +type ? and hit return. + +[call [cmd idebug] \{[arg "[arg echo] [opt [arg id]]"]\} [opt [arg args]]] +Behaves just like [cmd echo], but only triggers when idebug is on. +You can specify an optional [arg id] to further restrict triggering. +If no id is specified, it defaults to the name of the command +in which the call was made. + +[call [cmd idebug] [arg id] [opt [arg 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 *. + +[call [cmd idebug] [arg off]] +Turns idebug off. + +[call [cmd idebug] [arg on] [opt [arg id]]] +Turns idebug on. +If [arg id] is specified, it sets the id to it. + +[call [cmd idebug] \{[arg "[arg puts] [opt [arg id]]"]\} [arg args]] +Behaves just like [cmd puts], but only triggers when idebug is on. +You can specify an optional [arg id] to further restrict triggering. +If no id is specified, it defaults to the name of the +command in which the call was made. + +[call [cmd idebug] [arg show] [arg type] [opt [arg level]] [opt [arg VERBOSE]]] +type must be one of vars, locals or globals. +This method will output the variables/locals/globals present +in a particular level. +If [arg VERBOSE] is added, then it actually [cmd dump]s out the values as well. +level defaults to the level in which this method was called. + +[call [cmd idebug] [arg trace] [opt [arg level]]] +Prints out the stack trace from the specified level up to the top level. +level defaults to the current level. + +[list_end] + +[see_also [cmd tkcon](1)] +[see_also [cmd tkconrc](5) [cmd tkcon](n) [cmd dump](n)] +[see_also [cmd observe](n)] +[keywords Tk console debug] + +[manpage_end] + diff --git a/docs/index.html b/docs/index.html new file mode 100755 index 0000000..9d4709b --- /dev/null +++ b/docs/index.html @@ -0,0 +1,81 @@ + + +tkcon: Documentation + + + + + +
+ + + + + + +
tkcon Documentation (June 2001) + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ + +
+
+ + + +

Release +Archives (high speed server)

+ +

Screenshot

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

+

+
+ + + + + + + + + + + + + +
Getting Started +Special Bindingstkcon ProceduresScreenshot
dump proctkcon procidebug procobserve proc
+ +
+ +
+
© Jeffrey Hobbs
+ + + diff --git a/docs/license.terms b/docs/license.terms new file mode 100755 index 0000000..5b757ba --- /dev/null +++ b/docs/license.terms @@ -0,0 +1,33 @@ + * COPYRIGHT AND 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. + +SPECIAL NOTES: + +This software is also falls under the bourbon_ware clause v2: + + This software is free, but should you find this software useful in your + daily work and would like to compensate the author, donations in the form + of aged bourbon and scotch are welcome by the author. 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..072501d --- /dev/null +++ b/docs/limits.html @@ -0,0 +1,76 @@ + + +tkcon: Limitations + + + + + +
+ + + + + + +
tkcon: Limitations + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ + +
+
+

Limitations:

+ +TkCon requires Tk8.4+. 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. +

+
+ +
+
© Jeffrey Hobbs
+ + + diff --git a/docs/nontcl.html b/docs/nontcl.html new file mode 100755 index 0000000..47dbbe9 --- /dev/null +++ b/docs/nontcl.html @@ -0,0 +1,75 @@ + + +tkcon for Non-Tcl Users + + + + + +
+ + + + + + +
tkcon: Non-Tcl Usage + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)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/Tk 8.4+ to +run. 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. +
+
+ +
+
© Jeffrey Hobbs
+ + + diff --git a/docs/observe.html b/docs/observe.html new file mode 100755 index 0000000..f597534 --- /dev/null +++ b/docs/observe.html @@ -0,0 +1,104 @@ + + +tkcon: observe procedure + + + + + +
+ + + + + + +
tkcon: observe procedure + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ +
+ + + + + + + + + + + + + + +
Getting StartedSpecial BindingsProceduresScreenshot
dumptkconidebugobserve
+ +
+
+

+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. + +
+
+
+ +
+
© +Jeffrey Hobbs
+ + + diff --git a/docs/observe.n.man b/docs/observe.n.man new file mode 100644 index 0000000..d9630ba --- /dev/null +++ b/docs/observe.n.man @@ -0,0 +1,55 @@ +[comment {-*- tcl -*- observe manpage}] +[manpage_begin observe n 2.5] +[copyright {Jeffrey Hobbs }] +[moddesc {TkCon}] +[titledesc {Runtime debugging output in TkCon}] + +[description] +[para] +This command provides runtime debugging output for variables +and commands without the need to edit your code. +For variables, the underlying mechanism uses [cmd trace] and [cmd 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. + +[para] +This procedure is experimental. +Comments are encouraged. + +[list_begin definitions] + +[call [cmd observe] [arg command] [arg cmdname] [opt [arg maxlevel]]] +This will create a wrapper command which prints out (using [cmd 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). + +[call [cmd observe] [arg cdelete] [arg cmdname]] +Removes the wrapper around an observed command. + +[call [cmd observe] [arg cinfo] [arg cmdname]] +Prints out useless info. + +[call [cmd observe] [arg variable] [arg varname] [arg operation] [opt [arg args]]] +Currently a wrapper around trace that uses [cmd dump] to print out +the value of the named variable whenever the specified +operation on that variable occurs (must be [arg read], [arg write] or [arg unset]). + +[call [cmd observe] [arg vdelete] [arg varname] [arg operation]] +Deletes the trace wrapper around the named variable. + +[call [cmd observe] [arg vinfo] [arg varname]] +Prints out trace info about the named variable. + +[list_end] + +[see_also [cmd tkcon](1)] +[see_also [cmd tkconrc](5) [cmd tkcon](n) [cmd dump](n)] +[see_also [cmd idebug](n)] +[keywords Tk console debug] + +[manpage_end] + 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..1cc1896 --- /dev/null +++ b/docs/plugin.html @@ -0,0 +1,113 @@ + + +tkcon: Tcl Plugin Stripped Demo + + + + + +
+ + + + + + +
tkcon Documentation (May 2001) + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ + +
+
+

+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. The demo below uses the CVS head of tkcon. + +

+ + + + + + + + +

+ +Have a look at some of the features: (culled from the +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>. + +
+
+
+ +
+
© Jeffrey Hobbs
+ + + diff --git a/docs/procs.html b/docs/procs.html new file mode 100755 index 0000000..c2a0279 --- /dev/null +++ b/docs/procs.html @@ -0,0 +1,167 @@ + + +tkcon: Procedures + + + + + +
+ + + + + + +
tkcon: Procedures + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ +
+ + + + + + + + + + + + + + +
Getting StartedSpecial BindingsProceduresScreenshot
dumptkconidebugobserve
+ +
+
+

+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, +array variable, scalar 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). +
+
+ +
+
© +Jeffrey Hobbs
+ + + diff --git a/docs/purpose.html b/docs/purpose.html new file mode 100755 index 0000000..1d5a087 --- /dev/null +++ b/docs/purpose.html @@ -0,0 +1,87 @@ + + +tkcon: Purpose & Features + + + + + +
+ + + + + + +
tkcon: Purpose & Features + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)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) +
  • Hot Errors (click on error result to see stack trace) +
  • Works on all Tk platforms +
+ +Read the documentation for how to take advantage +of these features. +
+
+ +
+
© +Jeffrey Hobbs
+ + + diff --git a/docs/start.html b/docs/start.html new file mode 100755 index 0000000..5cc9808 --- /dev/null +++ b/docs/start.html @@ -0,0 +1,358 @@ + + +tkcon: Getting Started + + + + + +
+ + + + + + +
tkcon: Getting Started + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ +
+ + + + + + + + + + + + + + +
Getting StartedSpecial BindingsProceduresScreenshot
dumptkconidebugobserve
+ +
+
+

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> color +
Sets the requested color type to the specified color for tkcon. +See the Variables section for the recognized +<color> names. + +
-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::OPT(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 ::tkcon namespace. The +modifiable array variables are ::tkcon::COLOR and +::tkcon::OPT. You can call 'tkcon set +::tkcon::COLOR' when the program is running to check its state. +Here is an explanation of certain variables you might change or use: + +
+ +
::tkcon::COLOR(bg) +
The background color for tkcon text widgets. +Defaults to the operating system default (determined at startup). + +
::tkcon::COLOR(blink) +
The background color of the electric brace highlighting, if on. +Defaults to yellow. + +
::tkcon::COLOR(cursor) +
The background color for the insertion cursor in tkcon. +Defaults to black. + +
::tkcon::COLOR(disabled) +
The foreground color for disabled menu items. +Defaults to dark grey. + +
::tkcon::COLOR(proc) +
The foreground color of a recognized proc, if command highlighting is on. +Defaults to dark green. + +
::tkcon::COLOR(var) +
The background color of a recognized var, if command highlighting is on. +Defaults to pink. + +
::tkcon::COLOR(prompt) +
The foreground color of the prompt as output in the console. +Defaults to brown. + +
::tkcon::COLOR(stdin) +
The foreground color of the stdin for the console. +Defaults to black. + +
::tkcon::COLOR(stdout) +
The foreground color of the stdout as output in the console. +Defaults to blue. + +
::tkcon::COLOR(stderr) +
The foreground color of stderr as output in the console. +Defaults to red. +

+ +

::tkcon::OPT(autoload) +
Packages to automatically load into the slave interpreter (ie - 'Tk'). +This is a list. Defaults to {} (none). + +
::tkcon::OPT(blinktime) +
The amount of time (in millisecs) that braced sections should +blink for. Defaults to 500 (.5 secs), must be at least 100. + +
::tkcon::OPT(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). + +
::tkcon::OPT(buffer) +
The size of the console scroll buffer (in lines). +Defaults to 512. + +
::tkcon::OPT(calcmode) +
Whether to allow expr commands to be run at the command +line without prefixing them with expr (just a convenience). + +
::tkcon::OPT(cols) +
Number of columns for the console to start out with. Defaults to 80. + +
::tkcon::OPT(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. + +
::tkcon::OPT(exec) +
This corresponds to the -exec option above + +
::tkcon::OPT(font) +
Font to use for tkcon text widgets (also specified with -font). +Defaults to the system default, or a fixed width equivalent. + +
::tkcon::OPT(gets) +
Controls whether tkcon will overload the gets command to work with +tkcon. The valid values are: congets (the default), which +will redirect stdin requests to the tkcon window; +gets, which will pop up a dialog to get input; and {} (empty +string) which tells tkcon not to overload gets. This value must be set at +startup to alter tkcon's behavior. + +
::tkcon::OPT(history) +
The size of the history list to keep. Defaults to 48. + +
::tkcon::OPT(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. + +
::tkcon::OPT(library) +
The path to any tcl library directories (these are appended to the +auto_path when the after the resource file is loaded in). + +
::tkcon::OPT(lightbrace) +
Whether to use the brace highlighting feature or not +(respectively 1 or 0, defaults to 1). + +
::tkcon::OPT(lightcmd) +
Whether to use the command highlighting feature or not +(respectively 1 or 0, defaults to 1). + +
::tkcon::OPT(maineval) +
A tcl script to execute in the main interpreter after the slave +interpreter is created and the user interface is initialized. + +
::tkcon::OPT(maxlinelen) +
A number that specifies the limit of long result lines. +True result is still captured in $_ (and 'puts $_' works). +Defaults to 0 (unlimited). + +
::tkcon::OPT(maxmenu) +
A number that specifies the maximum number of packages to show +vertically in the Interp->Packages menu before breaking into +another column. Defaults to 15. + +
::tkcon::OPT(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. + +
::tkcon::OPT(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] % }. + +
::tkcon::OPT(rows) +
Number of rows for the console to start out with. Defaults to 20. + +
::tkcon::OPT(scollypos) +
Y scrollbar position. Valid values are left or +right. Defaults to left. + +
::tkcon::OPT(showmenu) +
Show the menubar on startup (1 or 0, defaults to 1). + +
::tkcon::OPT(showmultiple) +
Show multiple matches for path/proc/var name expansion +(1 or 0, defaults to 1). + +
::tkcon::OPT(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::OPT(slaveeval) {
+		proc foo args { puts $args }
+		lappend auto_path .
+	}
+ +
::tkcon::OPT(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. + +
::tkcon::OPT(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 a fixed default font
+#tkcon font fixed; # valid on unix
+#tkcon font systemfixed; # valid on win
+tkcon font Courier 12; # valid everywhere
+
+# Keep 50 commands in history
+set ::tkcon::OPT(history) 50
+
+# Use a pink prompt
+set ::tkcon::COLOR(prompt) pink
+######################################################
+ +

+

+
+ +
+
© +Jeffrey Hobbs
+ + + diff --git a/docs/style.css b/docs/style.css new file mode 100644 index 0000000..7aee5e8 --- /dev/null +++ b/docs/style.css @@ -0,0 +1,50 @@ +body, div, p, th, td, li, dd, ul, ol, dl, dt, blockquote { + font-family: Arial, Helvetica, sans-serif; +} +body { + background-color: #FFFFFF; + font-size: 12px; + line-height: 1.25; + letter-spacing: .2px; +} +th { + font-style: bold; + text-align: left; +} +a { text-decoration: none } +.hi, .hi2 { + font-weight: bold; + color: #B82619; + background: #FFFFCC; + text-decoration: none; +} +.hi2 { background: #CCFFCC; } +.indent { margin: 3px; } + +/* general styles */ +.heading { + font-size: 14px; + font-weight: bold; + color: #B82619; +} +.subheading { + font-weight: bold; + color: #B82619; +} + +.err { + font-weight: bold; + color: #B82619; +} +.smallText{ + font-size: 10px; +} +.notsosmallText { + font-size: 11px; +} + +/* unordered list without bullets */ +ul.sans { + list-style-type: none; + list-style-postition: inside; +} diff --git a/docs/tkcon.1.man b/docs/tkcon.1.man new file mode 100644 index 0000000..25ba74b --- /dev/null +++ b/docs/tkcon.1.man @@ -0,0 +1,369 @@ +[comment {-*- tcl -*- tkcon manpage}] +[manpage_begin tkcon 1 2.5] +[copyright {Jeffrey Hobbs (jeff at hobbs.org)}] +[moddesc {TkCon}] +[titledesc {Tk console replacement}] + +[description] +[para] +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. + +[list_begin definitions] +[call [cmd tkcon] [lb]\{[arg option] [arg value] | [arg tcl_script]\} ...[rb]] +[list_end] + +[section OPTIONS] +[para] +Except for [cmd -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. + +[para] +[cmd -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 + +[example_begin] +tkcon main set argv {}; tkcon main set argc 0 +[example_end] + +[para] +For these options, any unique substring is allowed. + +[list_begin definitions] +[def "[cmd -argv] (also [cmd --])"] +Causes TkCon to stop evaluating arguments and set the remaining +args to be argv/argc (with [cmd --] prepended). +This carries over for any further consoles. +This is meant only for wrapping TkCon +around programs that require their own arguments. + +[def "[cmd -color-] [arg color]"] +Sets the requested color type to the specified color for tkcon. +See [cmd tkconrc](5) for the recognized [cmd ] names. + +[def "[cmd -eval] [arg tcl_script] (also [cmd -main] or [cmd -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 [cmd -eval] switches will be recognized (in order). + +[def "[cmd -exec] [arg slavename]"] +Sets the named slave that tkcon operates in. +In general, this is only useful to set to [arg {""}] (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. + +[def "[cmd -font] [arg font]"] +Sets the font that tkcon uses for its text windows. +If this isn't a fixed width font, tkcon will override it. + +[def "[cmd -nontcl] [arg TCL_BOOLEAN]"] +Sets [cmd ::tkcon::OPT(nontcl)] to [arg TCL_BOOLEAN] (see +[cmd tkconrc](5)). +Needed when attaching to non-Tcl interpreters. + +[def "[cmd -package] [arg package_name] (also [cmd -load])"] +Packages to automatically load into the slave interpreters (i.e. "Tk"). + +[def "[cmd -rcfile] [arg filename]"] +Specify an alternate tkcon resource file name. + +[def "[cmd -root] [arg widgetname]"] +Makes the named widget the root name of all consoles (i.e. .tkcon). + +[def "[cmd -slave] [arg tcl_script]"] +A Tcl script to eval in each slave interpreter. +This will append the one specified in the tkcon resource file, if any. + +[list_end] + +[section {KEY BINDINGS}] +[para] +Most of the bindings are the same as for the [cmd 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. + +[list_begin definitions] + +[def "[cmd Control-x] or [cmd Cut] (on Sparc5 keyboards)"] +Cut. + +[def "[cmd Control-c] or [cmd Copy] (on Sparc5 keyboards)"] +Copy. + +[def "[cmd Control-v] or [cmd Paste] (on Sparc5 keyboards)"] +Paste. + +[def [cmd Insert]] +Insert (duh). + +[def [cmd Up]] +Goes up one level in the commands line history when cursor is on +the prompt line, otherwise it moves through the buffer. + +[def [cmd 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. + +[def [cmd Control-p]] +Goes up one level in the commands line history. + +[def [cmd Control-n]] +Goes down one level in the commands line history. + +[def [cmd Tab]] +Tries to expand file path names, then variable names, then proc names. + +[def [cmd Escape]] +Tries to expand file path names. + +[def [cmd 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). + +[def [cmd Control-V]] +Tries to expand variable names (those returned by [lb]info vars[rb]). +It's search behavior is like that for procedure names. + +[def "[cmd Return] or [cmd Enter]"] +Evaluates the current command line if it is a complete command, +otherwise it just goes to a new line. + +[def [cmd Control-a]] +Go to the beginning of the current command line. + +[def [cmd Control-l]] +Clear the entire console buffer. + +[def [cmd Control-r]] +Searches backwards in the history for any command that contains +the string in the current command line. +Repeatable to search farther back. +The matching substring off the found command will blink. + +[def [cmd Control-s]] +As above, but searches forward (only useful if you searched too far back). + +[def [cmd Control-t]] +Transposes characters. + +[def [cmd Control-u]] +Clears the current command line. + +[def [cmd Control-z]] +Saves current command line in a buffer that can be retrieved +with another [cmd 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. + +[def [cmd Control-Key-1]] +Attaches console to the console's slave interpreter. + +[def [cmd Control-Key-2]] +Attaches console to the console's master interpreter. + +[def [cmd Control-Key-3]] +Attaches console to main TkCon interpreter. + +[def [cmd Control-A]] +Pops up the "About" dialog. + +[def [cmd Control-N]] +Creates a new console. Each console has separate state, including +it's own widget hierarchy (it's a slave interpreter). + +[def [cmd Control-q]] +Close the current console OR Quit the program (depends on the +value of [cmd ::tkcon::TKCON(slaveexit)]). + +[def [cmd Control-w]] +Closes the current console. +Closing the main console will exit the program (something has +to control all the slaves...). + +[list_end] + +[para] +TkCon also has electric bracing (similar to that in emacs). +It will highlight matching pairs of {}'s, [lb][rb]'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?). + +[section COMMANDS] +[para] +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: + +[list_begin definitions] + +[def "[cmd alias] ?[arg sourceCmd] [arg targetCmd] ?[arg arg] [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. + +[def "[cmd clear] ?[arg percentage]?"] +Clears the text widget. +Same as the <[cmd Control-l]> binding, except this will accept a +percentage of the buffer to clear (1-100, 100 default). + +[def "[cmd dir] ?[arg -all]? ?[arg -full]? ?[arg -long]?\ + ?[arg pattern] [arg pattern] ...?"] +Cheap way to get directory listings. +Uses glob style pattern matching. + +[def "[cmd dump] [arg type] ?[arg -nocomplain]? ?[arg {-filter pattern}]?\ + ?[cmd --]? [arg pattern] ?[arg 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 [cmd dump](n) for details. + +[def "[cmd echo] ?[arg arg] [arg arg] ...?"] +Concatenates the args and spits the result to the console (stdout). + +[def "[cmd edit] ?[arg {-type type}]? ?[arg {-find str}]?\ + ?[arg {-attach interp}]? [arg arg]"] +Opens an editor with the data from arg. +The optional type argument can be one of: [arg proc], [arg var] or [arg file]. +For proc or var, the arg may be a pattern. + +[def "[cmd idebug] [arg command] ?[arg args]?"] +Interactive debugging command. +See [cmd idebug](n) for details. + +[def "[cmd lremove] ?[arg -all]? ?[arg -regexp] [arg -glob]?\ + [arg list] [arg items]"] +Removes one or more items from a list and returns the new list. +If [arg -all] is specified, it removes all instances of each item +in the list. +If [arg -regexp] or [arg -glob] is specified, it interprets each item in +the items list as a regexp or glob pattern to match against. + +[def [cmd less]] +Aliased to [cmd edit]. + +[def [cmd ls]] +Aliased to [cmd dir] [arg -full]. + +[def [cmd more]] +Aliased to [cmd edit]. + +[def "[cmd observe] [arg type] ?[arg args]?"] +This command provides passive runtime debugging output for +variables and commands. +See [cmd observe](n) for details. + +[def "[cmd puts] (same options as always)"] +Redefined to put the output into TkCon. + +[def "[cmd tkcon] [arg method] ?[arg args]?"] +Multi-purpose command. +See [cmd tkcon](n) for details. + +[def "[cmd tclindex] [arg {?-extensions patternlist? ?-index TCL_BOOLEAN?\ + ?-package TCL_BOOLEAN? ?dir1 dir2 ...?}]"] +Convenience proc to update the [file tclIndex] (controlled by [arg -index] switch) +and/or [file pkgIndex.tcl] (controlled by [arg -package] switch) file in the named +directories based on the given pattern for files. +It defaults to creating the [file tclIndex] but not the [file pkgIndex.tcl] file, +with the directory defaulting to [lb]pwd[rb]. +The extension defaults to *.tcl, with *.[lb]info sharelibextension[rb] +added when [arg -package] is true. + +[def "[cmd unalias] [arg cmd]"] +unaliases command. + +[def "[cmd what] [arg 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, array variable, +scalar variable, directory, file, widget, and executable. +Used by procedures dump and which. + +[def "[cmd which] [arg command]"] +Like the [syscmd 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 [cmd auto_index] for it, +it tells you the file that [cmd 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. + +[list_end] + +[para] +There are several procedures that I use as helpers that some may find +helpful in there coding (i.e. expanding pathnames). Feel free to lift +them from the code (but do assign proper attribution). + +[section EXAMLPES] +[para] +Some examples of tkcon command line startup situations: + +[example_begin] +[cmd megawish] /usr/bin/tkcon [cmd -exec] "" [cmd -root] .tkcon [arg mainfile.tcl] +[example_end] + +Use tkcon as a console for your [cmd megawish] application. +You can avoid starting the line with megawish if that is the +default [cmd wish] that TkCon would use. +The [cmd -root] ensures that tkcon will not conflict with the +application root window. + +[example_begin] +[cmd tkcon] [cmd -font] "Courier 12" [cmd -load] Tk +[example_end] + +Use the courier font for TkCon and always load Tk in slave +interpreters at startup. + +[example_begin] +[cmd tkcon] [cmd -rcfile] ~/.wishrc [cmd -color-bg] white +[example_end] + +Use the ~/.wishrc file as the resource file, and a white +background for TkCon's text widgets. + +[section FILES] +TkCon will search for a resource file in [file ~/.tkconrc]. +TkCon never sources the [file ~/.wishrc] file. +The resource file is sourced by each new instance of the console. +An example resource file is provided in [cmd tkconrc](5). + +[see_also [cmd tkconrc](5)] +[see_also [cmd dump](n) [cmd tkcon](n) [cmd idebug](n)] +[see_also [cmd observe](n) [cmd text](n)] +[keywords Tk console] + +[manpage_end] + diff --git a/docs/tkcon.html b/docs/tkcon.html new file mode 100755 index 0000000..cb88a52 --- /dev/null +++ b/docs/tkcon.html @@ -0,0 +1,189 @@ + + +tkcon: tkcon procedure + + + + + +
+ + + + + + +
tkcon: tkcon procedure + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)Using TkCon with other Tk Languages
+ +
+ + + + + + + + + + + + + + +
Getting StartedSpecial BindingsProceduresScreenshot
dumptkconidebugobserve
+ +
+
+

+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 congets +
Behaves like the traditional Tcl gets, but instead of +using stdin, it uses the tkcon console window. By default, +tkcon replaces the standard gets with this command. This behavior can be +controlled by altering the ::tkcon::OPT(gets) parameter at +startup. This should not be called directly - instead rely on the +overloaded gets, which has support for the optional varName +parameter. + +
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 +
Behaves like the traditional Tcl gets, but instead of +needing stdin, it pops a dialog box up for the user. The +overloaded gets has support for the optional varName parameter. + +
tkcon getcommand +
A variation of the congets method that requires a +full command to be input before returning. + +
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 linelength ?value? +
Sets or displays the number that specifies the limit of long result lines. +True result is still captured in $_ (and 'puts $_' works). + +
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 resultfilter ?command? +
Specify a command to process the results before outputting it to the +console window. The command receives one argument (the result string) and +the string returned is placed in the console. + +
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. + +
+
+
+ +
+
© +Jeffrey Hobbs
+ + + diff --git a/docs/tkcon.n.man b/docs/tkcon.n.man new file mode 100644 index 0000000..6f99fa5 --- /dev/null +++ b/docs/tkcon.n.man @@ -0,0 +1,140 @@ +[comment {-*- tcl -*- tkcon manpage}] +[manpage_begin tkcon n 2.5] +[copyright {Jeffrey Hobbs }] +[moddesc {TkCon}] +[titledesc {Controlling TkCon console}] + +[description] +[para] +This provides lots of useful control over a console: + +[list_begin definitions] + +[call [cmd tkcon] [arg attach] [arg interpreter]] +Attaches tkcon to the named interpreter. +The name must be that returned by [lb][cmd tk] [arg appname][rb] or a valid +path to a slave interpreter. +It's best to use this via the [arg {Console->Attach Console}] menu. + +[call [cmd tkcon] [arg buffer] [opt [arg 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). + +[call [cmd tkcon] [arg bgerror] [opt "[arg msg] [arg errorInfo]"]] +Does bgerror stuff in the tkcon master interpreter. + +[call [cmd tkcon] [arg close] or [cmd tkcon] [arg destroy]] +Destroys this tkcon widget. + +[call [cmd tkcon] [arg congets]] +Behaves like the traditional Tcl gets, but instead of using stdin, +it uses the tkcon console window. +By default, tkcon replaces the standard gets with this command. +This behavior can be controlled by altering the [cmd ::tkcon::OPT(gets)] +parameter at startup. +This should not be called directly - instead rely on the overloaded +gets, which has support for the optional varName parameter. + +[call [cmd tkcon] [arg console] [arg args]] +Passes the args to the tkcon text widget (the console). + +[call [cmd tkcon] [arg error]] +Pops up a dialog that gives the user a full trace of the +last error received in the tkcon console. + +[call [cmd tkcon] [arg find] [arg string]\ + [opt "[arg -case] [arg TCL_BOOLEAN] [arg -regexp] [arg TCL_BOOLEAN]"]] +Highlights all instances of string in the console. +If the string is empty, it clears any previous highlighting. + +[call [cmd tkcon] [arg font] [opt [arg fontname]]] +Sets or returns the font used by tkcon text widgets. + +[call [cmd tkcon] [arg gets]] +Behaves like the traditional Tcl gets, but instead of needing +stdin, it pops a dialog box up for the user. +The overloaded gets has support for the optional varName parameter. + +[call [cmd tkcon] [arg getcommand]] +A variation of the congets method that requires a full +command to be input before returning. + +[call [cmd tkcon] [arg hide]] +Withdraw the tkcon display from the screen (make sure you +have a way to get it back). + +[call [cmd tkcon] [arg history] [opt [arg -newline]]] +Displays the tkcon history in sourceable form. +If [arg -newline] is specified, it separates each command by +an extra newline. + +[call [cmd tkcon] [arg iconify]] +Iconifies the tkcon display. + +[call [cmd tkcon] [arg linelength] [opt [arg value]]] +Sets or displays the number that specifies the limit of long result lines. +True result is still captured in $_ (and 'puts $_' works). + +[call [cmd tkcon] [arg load] [arg filename]] +Sources named file into the slave interpreter. +If no filename is given, it will attempt to call +[cmd tk_getOpenFile] to pop up the file select box. + +[call [cmd tkcon] [arg main] [opt "[arg arg] [arg arg] [arg ...]"]] +Passes the args to the main tkcon interpreter to be +evaluated and returns the result. + +[call [cmd tkcon] [arg master] [arg args]] +Passes the args to the master interpreter to be evaluated +and returns the result. + +[call [cmd tkcon] [arg new]] +Creates a new tkcon widget. + +[call [cmd tkcon] [arg resultfilter] [opt [arg command]]] +Specify a command to process the results before outputting it to the console +window. The command receives one argument (the result string) and the string +returned is placed in the console. + +[call [cmd tkcon] [arg save] [opt "[arg filename] [opt [arg type]]"]] +Saves the console buffer to the given filename. +If no filename is given, it will attempt to call +[cmd 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. + +[call [cmd tkcon] [arg set] [arg var] [opt [arg value]]] +Queries or sets a master interpreter variable. + +[call [cmd tkcon] [arg append] [arg var] [opt [arg value]]] +Like set, but uses append on the variable. + +[call [cmd tkcon] [arg lappend] [arg var] [opt [arg value]]] +Like set, but uses lappend on the variable. + +[call [cmd tkcon] [arg show] or [cmd tkcon] [arg deiconify]] +Redisplays tkcon on the screen. + +[call [cmd tkcon] [arg slave] [opt "[arg slavename] [opt [arg {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 [lb][cmd tk] [arg appname][rb] of that +interpreter. + +[call [cmd tkcon] [arg title] [opt [arg title]]] +Sets or returns the title for tkcon. + +[call [cmd tkcon] [arg version]] +Returns of version of tkcon. + +[list_end] + +[see_also [cmd tkcon](1)] +[see_also [cmd tkconrc](5) [cmd tkcon](n) [cmd dump](n)] +[see_also [cmd observe](n)] +[keywords Tk console debug] + +[manpage_end] + diff --git a/docs/tkconrc.5.man b/docs/tkconrc.5.man new file mode 100644 index 0000000..b10af92 --- /dev/null +++ b/docs/tkconrc.5.man @@ -0,0 +1,249 @@ +[comment {-*- tcl -*- tkconrc manpage}] +[manpage_begin tkconrc 5 2.5] +[copyright {Jeffrey Hobbs }] +[moddesc {TkCon}] +[titledesc {TkCon resource file}] + +[description] +[para] +TkCon will search for a resource file in [file ~/.tkconrc]. +TkCon never sources the [file ~/.wishrc] file. +The resource file is sourced by each new instance of the console. +An example resource file is provided below. + +[para] +The file itself is a Tcl script, so it is required that the +file conforms to Tcl script conventions. + +[section VARIABLES] +[para] +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 [arg Prefs] menu). +All these are part of the master interpreter's [cmd ::tkcon] +namespace. +The modifiable array variables are [cmd ::tkcon::COLOR] and +[cmd ::tkcon::OPT]. +You can call + +[example_begin] +tkcon set ::tkcon::COLOR +[example_end] + +when the program is running to check its state. +Here is an explanation of certain variables you +might change or use: + +[list_begin definitions] + +[def [cmd ::tkcon::COLOR(bg)]] +The background color for tkcon text widgets. +Defaults to the operating system default (determined at startup). + +[def [cmd ::tkcon::COLOR(blink)]] +The background color of the electric brace highlighting, if on. +Defaults to yellow. + +[def [cmd ::tkcon::COLOR(cursor)]] +The background color for the insertion cursor in tkcon. +Defaults to black. + +[def [cmd ::tkcon::COLOR(disabled)]] +The foreground color for disabled menu items. +Defaults to dark grey. + +[def [cmd ::tkcon::COLOR(proc)]] +The foreground color of a recognized proc, if command highlighting is on. +Defaults to dark green. + +[def [cmd ::tkcon::COLOR(var)]] +The background color of a recognized var, if command highlighting is on. +Defaults to pink. + +[def [cmd ::tkcon::COLOR(prompt)]] +The foreground color of the prompt as output in the console. +Defaults to brown. + +[def [cmd ::tkcon::COLOR(stdin)]] +The foreground color of the stdin for the console. +Defaults to black. + +[def [cmd ::tkcon::COLOR(stdout)]] +The foreground color of the stdout as output in the console. +Defaults to blue. + +[def [cmd ::tkcon::COLOR(stderr)]] +The foreground color of stderr as output in the console. +Defaults to red. + +[def [cmd ::tkcon::OPT(autoload)]] +Packages to automatically load into the slave interpreter (i.e. 'Tk'). +This is a list. +Defaults to {} (none). + +[def [cmd ::tkcon::OPT(blinktime)]] +The amount of time (in millisecs) that braced sections should blink for. +Defaults to 500 (0.5 secs), must be at least 100. + +[def [cmd ::tkcon::OPT(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). + +[def [cmd ::tkcon::OPT(buffer)]] +The size of the console scroll buffer (in lines). +Defaults to 512. + +[def [cmd ::tkcon::OPT(calcmode)]] +Whether to allow expr commands to be run at the command line +without prefixing them with expr (just a convenience). + +[def [cmd ::tkcon::OPT(cols)]] +Number of columns for the console to start out with. +Defaults to 80. + +[def [cmd ::tkcon::OPT(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. + +[def [cmd ::tkcon::OPT(exec)]] +This corresponds to the [cmd -exec] tkcon option (see [cmd tkcon](1)). + +[def [cmd ::tkcon::OPT(font)]] +Font to use for tkcon text widgets (also specified with [cmd -font] option). +Defaults to the system default, or a fixed width equivalent. + +[def [cmd ::tkcon::OPT(gets)]] +Controls whether tkcon will overload the gets command to work with tkcon. +The valid values are: congets (the default), which will redirect +stdin requests to the tkcon window; gets, which will pop up a dialog to +get input; and {} (empty string) which tells tkcon not to overload gets. +This value must be set at startup to alter tkcon's behavior. + +[def [cmd ::tkcon::OPT(history)]] +The size of the history list to keep. +Defaults to 48. + +[def [cmd ::tkcon::OPT(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. + +[def [cmd ::tkcon::OPT(library)]] +The path to any tcl library directories (these are appended +to the [cmd auto_path] when the after the resource file is loaded in). + +[def [cmd ::tkcon::OPT(lightbrace)]] +Whether to use the brace highlighting feature or not +(respectively 1 or 0, defaults to 1). + +[def [cmd ::tkcon::OPT(lightcmd)]] +Whether to use the command highlighting feature or not +(respectively 1 or 0, defaults to 1). + +[def [cmd ::tkcon::OPT(maineval)]] +A tcl script to execute in the main interpreter after the +slave interpreter is created and the user interface is initialized. + +[def [cmd ::tkcon::OPT(maxlinelen)]] +A number that specifies the limit of long result lines. +True result is still captured in $_ (and 'puts $_' works). +Defaults to 0 (unlimited). + +[def [cmd ::tkcon::OPT(maxmenu)]] +A number that specifies the maximum number of packages to +show vertically in the [arg Interp->Packages] menu before breaking +into another column. +Defaults to 15. + +[def [cmd ::tkcon::OPT(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. + +[def [cmd ::tkcon::OPT(prompt1)]] +Like [cmd tcl_prompt1], except it doesn't require you use [cmd puts]. +No equivalent for [cmd tcl_prompt2] is available (it's unnecessary IMHO). +Defaults to {([lb]file tail [lb]pwd[rb][rb]) [lb]history nextid[rb] % }. + +[def [cmd ::tkcon::OPT(rows)]] +Number of rows for the console to start out with. +Defaults to 20. + +[def [cmd ::tkcon::OPT(scollypos)]] +Y scrollbar position. +Valid values are left or right. +Defaults to right. + +[def [cmd ::tkcon::OPT(showmenu)]] +Show the menubar on startup (1 or 0, defaults to 1). + +[def [cmd ::tkcon::OPT(showmultiple)]] +Show multiple matches for path/proc/var name expansion (1 or 0, +defaults to 1). + +[def [cmd ::tkcon::OPT(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. + +[para] +Example: + +[example_begin] +set ::tkcon::OPT(slaveeval) { + proc foo args { puts $args } + lappend auto_path . +} +[example_end] + +[def [cmd ::tkcon::OPT(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. + +[def [cmd ::tkcon::OPT(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. + +[list_end] + +[section EXAMPLES] +[para] +An example TkCon resource file might look like: + +[example_begin] +###################################################### +## My TkCon Resource File + +# Use a fixed default font +#tkcon font fixed; # valid on unix +#tkcon font systemfixed; # valid on win +tkcon font Courier 12; # valid everywhere + +# Keep 50 commands in history +set ::tkcon::OPT(history) 50 + +# Use a pink prompt +set ::tkcon::COLOR(prompt) pink +###################################################### +[example_end] + +[see_also [cmd tkcon](1)] +[see_also [cmd dump](n) [cmd tkcon](n) [cmd idebug](n)] +[see_also [cmd observe](n)] +[keywords Tk console] + +[manpage_end] + diff --git a/docs/todo.html b/docs/todo.html new file mode 100755 index 0000000..f9c2b3a --- /dev/null +++ b/docs/todo.html @@ -0,0 +1,99 @@ + + +tkcon: To Do Ideas + + + + + +
+ + + + + + +
tkcon: To Do Ideas + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + +
DocumentationPurpose & FeaturesLimitationsTo DoLicense
Online Demo +(requires Tk plugin)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... +
+ +
+
+ +
+
© +Jeffrey Hobbs
+ + + 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/icons/tkcon-small.svg b/icons/tkcon-small.svg new file mode 100644 index 0000000..8d6287b --- /dev/null +++ b/icons/tkcon-small.svg @@ -0,0 +1,534 @@ + + + + + tkcon + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + image/svg+xml + + tkcon + 23 Jan 2010 + + + Pat Thoyts + + + Tcl feather icon blended with the console icon fron the tango theme icon package. + + + Pat Thoyts, The Tango Project + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/icons/tkcon-small48.png b/icons/tkcon-small48.png new file mode 100644 index 0000000..8797a76 Binary files /dev/null and b/icons/tkcon-small48.png differ diff --git a/index.html b/index.html new file mode 100755 index 0000000..7c53084 --- /dev/null +++ b/index.html @@ -0,0 +1,70 @@ + + +Enhanced Tk Console: tkcon + + + + + +
+ + + + + + +
Enhanced Tk Console: tkcon + +SourceForge Logo +
+ + +
+ + + + + + + + + + + + + + +
DocumentationScreenshotOnline Demo! (requires +Tk plugin)License
+tkcon Release Archives + +

+Latest Release is 2.5 (2009-02-26) +

+

+You can grab the latest sources from the +tkcon CVS repository. +

+
+ +
+ +

+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). +

+ +
+
© Jeffrey Hobbs (jeff at hobbs dot org)
+ + + diff --git a/install-desktop-menu.sh b/install-desktop-menu.sh new file mode 100755 index 0000000..1e4c4eb --- /dev/null +++ b/install-desktop-menu.sh @@ -0,0 +1,26 @@ +#!/bin/sh +# +# To install a tkcon entry into a FreeDesktop.org compatible menu system such +# as used by GNOME, KDE or most modern X11 desktop environments the tkcon.desktop +# and icons/* files are installed. This should be done using the xdg-desktop-menu +# utility and xdg-icon-resource utility from the xdg-utils package. See +# http://portland.freedesktop.org/xdg-utils-1.0/ for further details. +# + +PROG_XDG_DESKTOP_MENU=`which xdg-desktop-menu` +PROG_XDG_ICON_RESOURCE=`which xdg-icon-resource` + +ICONFILE=icons/tkcon-small48.png + +if [ -x $PROG_XDG_DESKTOP_MENU -a -x PROG_XDG_ICON_RESOURCE ] +then + $PROG_XDG_DESKTOP_MENU install tkcon-console.desktop + $PROG_XDG_ICON_RESOURCE install --size 48 $ICONFILE tkcon-icon +else + [ -d $HOME/.local/share/applications ] || mkdirhier $HOME/.local/share/applications + [ -d $HOME/.local/share/icons ] || mkdirhier $HOME/.local/share/icons + install tkcon-console.desktop $HOME/.local/share/applications/tkcon-console.desktop + install $ICONFILE $HOME/.local/share/icons/tkcon-icon.png +fi + + diff --git a/pkgIndex.tcl b/pkgIndex.tcl new file mode 100644 index 0000000..431442a --- /dev/null +++ b/pkgIndex.tcl @@ -0,0 +1,11 @@ +# pkgIndex.tcl to use tkcon as a package via 'package require tkcon' +# +# 'tkcon show' will do all that is necessary to display tkcon +# +# Defaults to: +# * the main interp as the "slave" +# * hiding tkcon when you click in the titlebar [X] +# * using '.tkcon' as the root toplevel +# * not displaying itself at 'package require' time +# +package ifneeded tkcon 2.7 [list source [file join $dir tkcon.tcl]] diff --git a/tkcon-console.desktop b/tkcon-console.desktop new file mode 100644 index 0000000..0be3094 --- /dev/null +++ b/tkcon-console.desktop @@ -0,0 +1,10 @@ +[Desktop Entry] +Encoding=UTF-8 +Name=tkcon +GenericName=Tk console +Comment=Tk console +Exec=tkcon +Icon=tkcon-icon +Terminal=false +Type=Application +Categories=Development;Utility; diff --git a/tkcon.tcl b/tkcon.tcl new file mode 100755 index 0000000..57e8017 --- /dev/null +++ b/tkcon.tcl @@ -0,0 +1,6539 @@ +#!/bin/sh +# -*- tcl -*- +# \ +exec wish "$0" ${1+"$@"} + +# +## tkcon.tcl +## Enhanced Tk Console, part of the VerTcl system +## +## Originally based off Brent Welch's Tcl Shell Widget +## (from "Practical Programming in Tcl and Tk") +## +## Thanks to the following (among many) for early bug reports & code ideas: +## Steven Wahl, Jan Nijtmans, Mark Crimmins, Wart +## +## Copyright (c) 1995-2011 Jeffrey Hobbs, jeff(a)hobbs(.)org +## Initiated: Thu Aug 17 15:36:47 PDT 1995 +## +## source standard_disclaimer.tcl +## source bourbon_ware.tcl +## + +# Proxy support for retrieving the current version of Tkcon. +# +# Mon Jun 25 12:19:56 2001 - Pat Thoyts +# +# In your tkcon.cfg or .tkconrc file put your proxy details into the +# `proxy' member of the `PRIV' array. e.g.: +# +# set ::tkcon::PRIV(proxy) wwwproxy:8080 +# +# If you want to be prompted for proxy authentication details (eg for +# an NT proxy server) make the second element of this variable non-nil - eg: +# +# set ::tkcon::PRIV(proxy) {wwwproxy:8080 1} +# +# Or you can set the above variable from within tkcon by calling +# +# tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080 +# + +if {$tcl_version < 8.4} { + return -code error "tkcon requires at least Tcl/Tk 8.4" +} else { + package require Tk 8.4 +} + +# We need to load some package to get what's available, and we +# choose ctext because we'll use it if its available in the editor +catch {package require ctext} +foreach pkg [info loaded {}] { + set file [lindex $pkg 0] + set name [lindex $pkg 1] + if {![catch {set version [package require $name]}]} { + if {[package ifneeded $name $version] eq ""} { + package ifneeded $name $version [list load $file $name] + } + } +} + +# Unset temporary global vars +catch {unset pkg file name version} + +# Initialize the ::tkcon namespace +# +namespace eval ::tkcon { + # when modifying this line, make sure that the auto-upgrade check + # for version still works. + variable VERSION "2.7" + # The OPT variable is an array containing most of the optional + # info to configure. COLOR has the color data. + variable OPT + variable COLOR + + # PRIV is used for internal data that only tkcon should fiddle with. + variable PRIV + set PRIV(WWW) [info exists embed_args] + set PRIV(AQUA) [expr {$::tcl_version >= 8.4 && [tk windowingsystem] == "aqua"}] + set PRIV(CTRL) [expr {$PRIV(AQUA) ? "Command-" : "Control-"}] + set PRIV(ACC) [expr {$PRIV(AQUA) ? "Command-" : "Ctrl+"}] + + variable EXPECT 0 +} + +## ::tkcon::Init - inits tkcon +# +# Calls: ::tkcon::InitUI +# Outputs: errors found in tkcon's resource file +## +proc ::tkcon::Init {args} { + variable VERSION + variable OPT + variable COLOR + variable PRIV + global tcl_platform env tcl_interactive errorInfo + + set tcl_interactive 1 + set argc [llength $args] + + ## + ## When setting up all the default values, we always check for + ## prior existence. This allows users who embed tkcon to modify + ## the initial state before tkcon initializes itself. + ## + + # bg == {} will get bg color from the main toplevel (in InitUI) + foreach {key default} { + bg {} + blink \#FFFF00 + cursor \#000000 + disabled \#4D4D4D + proc \#008800 + var \#FFC0D0 + prompt \#8F4433 + stdin \#000000 + stdout \#0000FF + stderr \#FF0000 + } { + if {![info exists COLOR($key)]} { set COLOR($key) $default } + } + + # expandorder could also include 'Methodname' for XOTcl/NSF methods + foreach {key default} { + autoload {} + blinktime 500 + blinkrange 1 + buffer 512 + maxlinelen 0 + calcmode 0 + cols 80 + debugPrompt {(level \#$level) debug [history nextid] > } + dead {} + edit edit + expandorder {Pathname Variable Procname} + font {} + history 48 + hoterrors 1 + library {} + lightbrace 1 + lightcmd 1 + maineval {} + maxmenu 18 + nontcl 0 + prompt1 {ignore this, it's set below} + rows 20 + scrollypos right + showmenu 1 + showmultiple 1 + showstatusbar 1 + slaveeval {} + slaveexit close + subhistory 1 + tabspace 8 + gc-delay 60000 + gets {congets} + overrideexit 1 + usehistory 1 + resultfilter {} + + exec slave + } { + if {![info exists OPT($key)]} { set OPT($key) $default } + } + + foreach {key default} { + app {} + appname {} + apptype slave + namesp :: + cmd {} + cmdbuf {} + cmdsave {} + event 1 + deadapp 0 + deadsock 0 + debugging 0 + displayWin . + histid 0 + find {} + find,case 0 + find,reg 0 + errorInfo {} + protocol exit + showOnStartup 1 + slaveprocs { + alias clear dir dump echo idebug lremove + tkcon_puts tkcon_gets observe observe_var unalias which what + } + RCS {RCS: @(#) $Id: tkcon.tcl,v 1.124 2016/09/14 21:14:43 hobbs Exp $} + HEADURL {http://tkcon.cvs.sourceforge.net/viewvc/tkcon/tkcon/tkcon.tcl} + + docs "http://tkcon.sourceforge.net/" + email {jeff(a)hobbs(.)org} + root . + uid 0 + tabs {} + } { + if {![info exists PRIV($key)]} { set PRIV($key) $default } + } + foreach {key default} { + slavealias { $OPT(edit) more less tkcon } + } { + if {![info exists PRIV($key)]} { set PRIV($key) [subst $default] } + } + set PRIV(version) $VERSION + + if {[info exists PRIV(name)]} { + set title $PRIV(name) + } else { + MainInit + # some main initialization occurs later in this proc, + # to go after the UI init + set MainInit 1 + set title Main + } + + ## NOTES FOR STAYING IN PRIMARY INTERPRETER: + ## + ## If you set ::tkcon::OPT(exec) to {}, then instead of a multiple + ## interp model, you get tkcon operating in the main interp by default. + ## This can be useful when attaching to programs that like to operate + ## in the main interpter (for example, based on special wish'es). + ## You can set this from the command line with -exec "" + ## A side effect is that all tkcon command line args will be used + ## by the first console only. + #set OPT(exec) {} + + if {$PRIV(WWW)} { + lappend PRIV(slavealias) history + set OPT(prompt1) {[history nextid] % } + } else { + lappend PRIV(slaveprocs) tcl_unknown unknown + set OPT(prompt1) {([file tail [pwd]]) [history nextid] % } + } + + ## If we are using the default '.' toplevel, and there appear to be + ## children of '.', then make sure we use a disassociated toplevel. + if {$PRIV(root) == "." && [llength [winfo children .]]} { + set PRIV(root) .tkcon + } + + ## Do platform specific configuration here, other than defaults + ### Use tkcon.cfg filename for resource filename on non-unix systems + ### Determine what directory the resource file should be in + switch $tcl_platform(platform) { + macintosh { + if {![interp issafe]} {cd [file dirname [info script]]} + set envHome PREF_FOLDER + set rcfile tkcon.cfg + set histfile tkcon.hst + catch {console hide} + } + windows { + set envHome HOME + set rcfile tkcon.cfg + set histfile tkcon.hst + } + unix { + set envHome HOME + set rcfile .tkconrc + set histfile .tkcon_history + } + } + if {[info exists env($envHome)]} { + set home $env($envHome) + if {[file pathtype $home] == "volumerelative"} { + # Convert 'C:' to 'C:/' if necessary, innocuous otherwise + append home / + } + if {![info exists PRIV(rcfile)]} { + set PRIV(rcfile) [file join $home $rcfile] + } + if {![info exists PRIV(histfile)]} { + set PRIV(histfile) [file join $home $histfile] + } + } + + ## Handle command line arguments before sourcing resource file to + ## find if resource file is being specified (let other args pass). + if {[set i [lsearch -exact $args -rcfile]] != -1} { + set PRIV(rcfile) [lindex $args [incr i]] + } + + if {!$PRIV(WWW) && [file exists $PRIV(rcfile)]} { + set code [catch {uplevel \#0 [list source $PRIV(rcfile)]} err] + } + + if {[info exists env(TK_CON_LIBRARY)]} { + lappend ::auto_path $env(TK_CON_LIBRARY) + } elseif {$OPT(library) != ""} { + lappend ::auto_path $OPT(library) + } + + if {![info exists ::tcl_pkgPath]} { + set dir [file join [file dirname [info nameofexec]] lib] + if {[llength [info commands @scope]]} { + set dir [file join $dir itcl] + } + catch {source [file join $dir pkgIndex.tcl]} + } + catch {tclPkgUnknown dummy-name dummy-version} + + ## Handle rest of command line arguments after sourcing resource file + ## and slave is created, but before initializing UI or setting packages. + set slaveargs {} + set slavefiles {} + set slaveargv0 {} + set truth {^(1|yes|true|on)$} + for {set i 0} {$i < $argc} {incr i} { + set arg [lindex $args $i] + if {[string match {-*} $arg]} { + set val [lindex $args [incr i]] + ## Handle arg based options + switch -glob -- $arg { + -- - -argv - -args { + set slaveargs [concat $slaveargs [lrange $args $i end]] + set ::argv $slaveargs + set ::argc [llength $::argv] + break + } + -color-* { set COLOR([string range $arg 7 end]) $val } + -exec { set OPT(exec) $val } + -main - -e - -eval { append OPT(maineval) \n$val\n } + -package - -load { + lappend OPT(autoload) $val + if {$val eq "nsf" || $val eq "nx" || $val eq "XOTcl" } { + # If xotcl is loaded, prepend expand order for it + set OPT(expandorder) [concat Methodname $OPT(expandorder)] + } + } + -slave { append OPT(slaveeval) \n$val\n } + -nontcl { set OPT(nontcl) [regexp -nocase $truth $val]} + -root { set PRIV(root) $val } + -font { set OPT(font) $val } + -rcfile {} + default { lappend slaveargs $arg; incr i -1 } + } + } elseif {[file isfile $arg]} { + if {$i == 0} { + set slaveargv0 $arg + } + lappend slavefiles $arg + } else { + lappend slaveargs $arg + } + } + + ## Create slave executable + if {"" != $OPT(exec)} { + InitSlave $OPT(exec) $slaveargs $slaveargv0 + } else { + set argc [llength $slaveargs] + set args $slaveargs + uplevel \#0 $slaveargs + } + + # Try not to make tkcon override too many standard defaults, and only + # do it for the tkcon bits + set optclass [tk appname]$PRIV(root) + option add $optclass*Menu.tearOff 0 + option add $optclass*Menu.borderWidth 1 + option add $optclass*Menu.activeBorderWidth 1 + if {!$PRIV(AQUA)} { + option add $optclass*Scrollbar.borderWidth 1 + } + + ## Attach to the slave, EvalAttached will then be effective + Attach $PRIV(appname) $PRIV(apptype) + InitUI $title + if {"" != $OPT(exec)} { + # override exit to DeleteTab now that tab has been created + $OPT(exec) alias exit ::tkcon::DeleteTab $PRIV(curtab) $OPT(exec) + } + + ## swap puts and gets with the tkcon versions to make sure all + ## input and output is handled by tkcon + if {![catch {rename ::puts ::tkcon_tcl_puts}]} { + interp alias {} ::puts {} ::tkcon_puts + if {[llength [info commands ::tcl::chan::puts]]} { + interp alias {} ::tcl::chan::puts {} ::tkcon_puts + } + } + if {($OPT(gets) != "") && ![catch {rename ::gets ::tkcon_tcl_gets}]} { + interp alias {} ::gets {} ::tkcon_gets + if {[llength [info commands ::tcl::chan::gets]]} { + interp alias {} ::tcl::chan::gets {} ::tkcon_gets + } + } + + EvalSlave history keep $OPT(history) + if {[info exists MainInit]} { + # Source history file only for the main console, as all slave + # consoles will adopt from the main's history, but still + # keep separate histories + if {!$PRIV(WWW) && $OPT(usehistory) && [file exists $PRIV(histfile)]} { + puts -nonewline "loading history file ... " + # The history file is built to be loaded in and + # understood by tkcon + if {[catch {uplevel \#0 [list source $PRIV(histfile)]} herr]} { + puts stderr "error:\n$herr" + append PRIV(errorInfo) $errorInfo\n + } + set PRIV(event) [EvalSlave history nextid] + puts "[expr {$PRIV(event)-1}] events added" + } + } + + ## Autoload specified packages in slave + set pkgs [EvalSlave package names] + foreach pkg $OPT(autoload) { + puts -nonewline "autoloading package \"$pkg\" ... " + if {[lsearch -exact $pkgs $pkg]>-1} { + if {[catch {EvalSlave package require [list $pkg]} pkgerr]} { + puts stderr "error:\n$pkgerr" + append PRIV(errorInfo) $errorInfo\n + } else { puts "OK" } + } else { + puts stderr "error: package does not exist" + } + } + + ## Evaluate maineval in slave + if {($OPT(maineval) ne "") && [catch {uplevel \#0 $OPT(maineval)} merr]} { + puts stderr "error in eval:\n$merr" + append PRIV(errorInfo) $errorInfo\n + } + + ## Source extra command line argument files into slave executable + foreach fn $slavefiles { + puts -nonewline "slave sourcing \"$fn\" ... " + if {[catch {EvalSlave uplevel \#0 [list source $fn]} fnerr]} { + puts stderr "error:\n$fnerr" + append PRIV(errorInfo) $errorInfo\n + } else { puts "OK" } + } + + ## Evaluate slaveeval in slave + if {($OPT(slaveeval) ne "") + && [catch {interp eval $OPT(exec) $OPT(slaveeval)} serr]} { + puts stderr "error in slave eval:\n$serr" + append PRIV(errorInfo) $errorInfo\n + } + ## Output any error/output that may have been returned from rcfile + if {[info exists code] && $code && ($err ne "")} { + puts stderr "error in $PRIV(rcfile):\n$err" + append PRIV(errorInfo) $errorInfo + } + if {$OPT(exec) ne ""} { + StateCheckpoint [concat $PRIV(name) $OPT(exec)] slave + } + StateCheckpoint $PRIV(name) slave + + puts "buffer line limit:\ + [expr {$OPT(buffer)?$OPT(buffer):{unlimited}}] \ + max line length:\ + [expr {$OPT(maxlinelen)?$OPT(maxlinelen):{unlimited}}]" + + Prompt "$title console display active (Tcl$::tcl_patchLevel / Tk$::tk_patchLevel)\n" +} + +## ::tkcon::InitSlave - 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 ::tkcon::InitSlave {slave {slaveargs {}} {slaveargv0 {}}} { + variable OPT + variable COLOR + variable PRIV + global argv0 tcl_interactive tcl_library env auto_path tk_library + + if {$slave eq ""} { + return -code error "Don't init the master interpreter, goofball" + } + if {![interp exists $slave]} { interp create $slave } + if {[interp eval $slave info command source] == ""} { + $slave alias source SafeSource $slave + $slave alias load SafeLoad $slave + $slave alias open SafeOpen $slave + $slave alias file file + interp eval $slave \ + [list set auto_path [lremove $auto_path $tk_library]] + interp eval $slave [dump var -nocomplain tcl_library env] + interp eval $slave { catch {source [file join $tcl_library init.tcl]} } + interp eval $slave { catch unknown } + } + # This will likely be overridden to call DeleteTab where possible + $slave alias exit exit + interp eval $slave { + # Do package require before changing around puts/gets + catch {set __tkcon_error ""; set __tkcon_error $errorInfo} + catch {package require bogus-package-name} + catch {rename ::puts ::tkcon_tcl_puts} + set errorInfo ${__tkcon_error} + unset __tkcon_error + } + foreach cmd $PRIV(slaveprocs) { $slave eval [dump proc $cmd] } + foreach cmd $PRIV(slavealias) { $slave alias $cmd $cmd } + interp alias $slave ::ls $slave ::dir -full + interp alias $slave ::puts $slave ::tkcon_puts + if {[llength [info commands ::tcl::chan::puts]]} { + interp alias $slave ::tcl::chan::puts $slave ::tkcon_puts + } + if {$OPT(gets) != ""} { + interp eval $slave { catch {rename ::gets ::tkcon_tcl_gets} } + interp alias $slave ::gets $slave ::tkcon_gets + if {[llength [info commands ::tcl::chan::gets]]} { + interp alias $slave ::tcl::chan::gets $slave ::tkcon_gets + } + } + if {$slaveargv0 != ""} { + # If tkcon was invoked with 1 or more filenames, then make the + # first filename argv0 in the slave, as tclsh/wish would do it. + interp eval $slave [list set argv0 $slaveargv0] + } else { + if {[info exists argv0]} {interp eval $slave [list set argv0 $argv0]} + } + interp eval $slave set tcl_interactive $tcl_interactive \; \ + set auto_path [list [lremove $auto_path $tk_library]] \; \ + set argc [llength $slaveargs] \; \ + set argv [list $slaveargs] \; { + if {![llength [info command bgerror]]} { + proc bgerror err { + global errorInfo + set body [info body bgerror] + rename ::bgerror {} + if {[auto_load bgerror]} { return [bgerror $err] } + proc bgerror err $body + tkcon bgerror $err $errorInfo + } + } + } + + foreach pkg [lremove [package names] Tcl] { + foreach v [package versions $pkg] { + interp eval $slave [list package ifneeded $pkg $v \ + [package ifneeded $pkg $v]] + } + } +} + +## ::tkcon::InitInterp - inits an interpreter by placing key +## procs and aliases in it. +# ARGS: name - interp name +# type - interp type (slave|interp) +## +proc ::tkcon::InitInterp {name type} { + variable OPT + variable PRIV + + ## Don't allow messing up a local master interpreter + if {($type eq "namespace") + || (($type eq "slave") && + [regexp {^([Mm]ain|Slave[0-9]+)$} $name])} { return } + set old [Attach] + set oldname $PRIV(namesp) + catch { + Attach $name $type + EvalAttached { catch {rename ::puts ::tkcon_tcl_puts} } + foreach cmd $PRIV(slaveprocs) { EvalAttached [dump proc $cmd] } + switch -exact $type { + slave { + foreach cmd $PRIV(slavealias) { + Main [list interp alias $name ::$cmd $PRIV(name) ::$cmd] + } + } + interp { + set thistkcon [::send::appname] + foreach cmd $PRIV(slavealias) { + EvalAttached "proc $cmd args { ::send::send [list $thistkcon] $cmd \$args }" + } + } + } + ## Catch in case it's a 7.4 (no 'interp alias') interp + EvalAttached { + catch {interp alias {} ::ls {} ::dir -full} + if {[catch {interp alias {} ::puts {} ::tkcon_puts}]} { + catch {rename ::tkcon_puts ::puts} + } elseif {[llength [info commands ::tcl::chan::puts]]} { + catch {interp alias {} ::tcl::chan::puts {} ::tkcon_puts} + } + } + if {$OPT(gets) != ""} { + EvalAttached { + catch {rename ::gets ::tkcon_tcl_gets} + if {[catch {interp alias {} ::gets {} ::tkcon_gets}]} { + catch {rename ::tkcon_gets ::gets} + } elseif {[llength [info commands ::tcl::chan::gets]]} { + catch {interp alias {} ::tcl::chan::gets {} ::tkcon_gets} + } + } + } + return + } {err} + eval Attach $old + AttachNamespace $oldname + if {$err ne ""} { return -code error $err } +} + +## ::tkcon::InitUI - 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: ::tkcon::InitMenus, ::tkcon::Prompt +## +proc ::tkcon::InitUI {title} { + variable OPT + variable PRIV + variable COLOR + + set root $PRIV(root) + if {$root eq "."} { set w {} } else { set w [toplevel $root] } + if {!$PRIV(WWW)} { + wm withdraw $root + wm protocol $root WM_DELETE_WINDOW $PRIV(protocol) + } + set PRIV(base) $w + + catch {font create tkconfixed -family Courier -size -12} + catch {font create tkconfixedbold -family Courier -size -12 -weight bold} + + set PRIV(statusbar) [set sbar [frame $w.fstatus]] + set PRIV(tabframe) [frame $sbar.tabs] + set PRIV(X) [button $sbar.deltab -text "X" -command ::tkcon::DeleteTab \ + -activeforeground red -fg red -font tkconfixedbold \ + -highlightthickness 0 -padx 2 -pady 0 -borderwidth 1 \ + -state disabled -relief flat -takefocus 0] + catch {$PRIV(X) configure -overrelief raised} + label $sbar.cursor -relief sunken -borderwidth 1 -anchor e -width 6 \ + -textvariable ::tkcon::PRIV(StatusCursor) + set padx [expr {![info exists ::tcl_platform(os)] + || ($::tcl_platform(os) ne "Windows CE")}] + grid $PRIV(X) $PRIV(tabframe) $sbar.cursor -sticky news -padx $padx + grid configure $PRIV(tabframe) -sticky nsw + grid configure $PRIV(X) -pady 0 -padx 0 + grid columnconfigure $sbar 1 -weight 1 + grid rowconfigure $sbar 0 -weight 1 + grid rowconfigure $PRIV(tabframe) 0 -weight 1 + if {$PRIV(AQUA)} { + # resize control space and correct "X" button space + grid columnconfigure $sbar [lindex [grid size $sbar] 0] -minsize 16 + $PRIV(X) configure -pady 5 -padx 4 + } + + ## Create console tab + set con [InitTab $w] + set PRIV(curtab) $con + + # Only apply this for the first console + $con configure -setgrid 1 -width $OPT(cols) -height $OPT(rows) + bind $PRIV(root) { + if {"%W" == $::tkcon::PRIV(root)} { + scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \ + ::tkcon::OPT(cols) ::tkcon::OPT(rows) + if {[info exists ::tkcon::EXP(spawn_id)]} { + catch {stty rows $::tkcon::OPT(rows) columns \ + $::tkcon::OPT(cols) < $::tkcon::EXP(slave,name)} + } + } + } + + # scrollbar + set sy [scrollbar $w.sy -takefocus 0 -command [list $con yview]] + if {!$PRIV(WWW) && ($::tcl_platform(os) eq "Windows CE")} { + $w.sy configure -width 10 + } + + $con configure -yscrollcommand [list $sy set] + set PRIV(console) $con + set PRIV(scrolly) $sy + + ## Menus + ## catch against use in plugin + if {[catch {menu $w.mbar} PRIV(menubar)]} { + set PRIV(menubar) [frame $w.mbar -relief raised -borderwidth 1] + } + + InitMenus $PRIV(menubar) $title + Bindings + + if {$OPT(showmenu)} { + $root configure -menu $PRIV(menubar) + } + + grid $con -row 1 -column 1 -sticky news + grid $sy -row 1 -column [expr {$OPT(scrollypos)=="left"?0:2}] -sticky ns + grid $sbar -row 2 -column 0 -columnspan 3 -sticky ew + + grid columnconfigure $root 1 -weight 1 + grid rowconfigure $root 1 -weight 1 + + if {!$OPT(showstatusbar)} { + grid remove $sbar + } + + # If we can locate the XDG icon file then make use of it. + if {[package vsatisfies [package provide Tk] 8.6]} { + if {[tk windowingsystem] eq "x11"} { + if {[set icon [locate_xdg_icon tkcon-icon.png]] ne ""} { + image create photo tkcon_icon -file $icon + wm iconphoto $root tkcon_icon + } + } + } + + if {!$PRIV(WWW)} { + wm title $root "tkcon $PRIV(version) $title" + if {$PRIV(showOnStartup)} { + # this may throw an error if toplevel is embedded + catch {wm deiconify $root} + } + } + if {$PRIV(showOnStartup)} { focus -force $PRIV(console) } + if {$OPT(gc-delay)} { + after $OPT(gc-delay) ::tkcon::GarbageCollect + } +} + +# Hunt around the XDG defined directories for the icon. +# Note: hicolor is the standard theme used by xdg-icon-resource. +proc ::tkcon::locate_xdg_icon {name} { + global env + set dirs [list /usr/local/share /usr/share] + if {[info exists env(XDG_DATA_DIRS)]} { + set dirs [split $env(XDG_DATA_DIRS) :] + } + if {[file isdirectory ~/.local/share]} { + set dirs [linsert $dirs 0 ~/.local/share] + } + foreach dir $dirs { + foreach path [list icons icons/hicolor/48x48/apps] { + set path [file join $dir $path $name] + if {[file exists $path]} { + return $path + } + } + } + return "" +} + +proc ::tkcon::InitTab {w} { + variable OPT + variable PRIV + variable COLOR + variable ATTACH + + # text console + set con $w.tab[incr PRIV(uid)] + text $con -wrap char -foreground $COLOR(stdin) \ + -insertbackground $COLOR(cursor) -borderwidth 1 -highlightthickness 0 + $con mark set output 1.0 + $con mark set limit 1.0 + if {$COLOR(bg) ne ""} { + $con configure -background $COLOR(bg) + } + set COLOR(bg) [$con cget -background] + if {$OPT(font) ne ""} { + ## Set user-requested font, if any + $con configure -font $OPT(font) + } elseif {$::tcl_platform(platform) ne "unix"} { + ## otherwise make sure the font is monospace + set font [$con cget -font] + if {![font metrics $font -fixed]} { + $con configure -font tkconfixed + } + } else { + $con configure -font tkconfixed + } + set OPT(font) [$con cget -font] + bindtags $con [list $con TkConsole TkConsolePost $PRIV(root) all] + + # scrollbar + if {!$PRIV(WWW)} { + if {$::tcl_platform(os) eq "Windows CE"} { + font configure tkconfixed -family Tahoma -size 8 + $con configure -font tkconfixed -borderwidth 0 -padx 0 -pady 0 + set cw [font measure tkconfixed "0"] + set ch [font metrics tkconfixed -linespace] + set sw [winfo screenwidth $con] + set sh [winfo screenheight $con] + # We need the magic hard offsets until I find a way to + # correctly assume size + if {$cw*($OPT(cols)+2) > $sw} { + set OPT(cols) [expr {($sw / $cw) - 2}] + } + if {$ch*($OPT(rows)+3) > $sh} { + set OPT(rows) [expr {($sh / $ch) - 3}] + } + # Place it so that the titlebar underlaps the CE titlebar + wm geometry $PRIV(root) +0+0 + } + } + $con configure -height $OPT(rows) -width $OPT(cols) + + foreach col {prompt stdout stderr stdin proc} { + $con tag configure $col -foreground $COLOR($col) + } + $con tag configure var -background $COLOR(var) + $con tag raise sel + $con tag configure blink -background $COLOR(blink) + $con tag configure find -background $COLOR(blink) + + set ATTACH($con) [Attach] + set rb [radiobutton $PRIV(tabframe).cb[winfo name $con] -takefocus 0 \ + -textvariable ::tkcon::ATTACH($con) \ + -selectcolor white -relief sunken \ + -indicatoron 0 -padx 0 -pady 0 -borderwidth 1 \ + -variable ::tkcon::PRIV(curtab) -value $con \ + -command [list ::tkcon::GotoTab $con]] + if {$::tcl_version >= 8.4} { + $rb configure -offrelief flat -overrelief raised + } + if {$PRIV(AQUA)} { + $rb configure -padx 4 -pady 4 -highlightthickness 0 + } + grid $rb -row 0 -column [lindex [grid size $PRIV(tabframe)] 0] -sticky ns + grid $con -row 1 -column 1 -sticky news + + lappend PRIV(tabs) $con + return $con +} + +proc ::tkcon::GotoTab {con} { + variable PRIV + variable ATTACH + + set numtabs [llength $PRIV(tabs)] + #if {$numtabs == 1} { return } + + if {[regexp {^[0-9]+$} $con]} { + set curtab [lsearch -exact $PRIV(tabs) $PRIV(console)] + set nexttab [expr {$curtab + $con}] + if {$nexttab >= $numtabs} { + set nexttab 0 + } elseif {$nexttab < 0} { + set nexttab "end" + } + set con [lindex $PRIV(tabs) $nexttab] + } elseif {$con == $PRIV(console)} { + return + } + + # adjust console + if {[winfo exists $PRIV(console)]} { + lower $PRIV(console) + $PRIV(console) configure -yscrollcommand {} + set ATTACH($PRIV(console)) [Attach] + } + set PRIV(console) $con + $con configure -yscrollcommand [list $PRIV(scrolly) set] + $PRIV(scrolly) configure -command [list $con yview] + + # adjust attach + eval [linsert $ATTACH($con) 0 Attach] + + set PRIV(curtab) $con + + raise $con + + if {[$con compare 1.0 == end-1c]} { + Prompt + } + + # set StatusCursor + set PRIV(StatusCursor) [$con index insert] + + focus -force $con +} + +proc ::tkcon::NewTab {{con {}}} { + variable PRIV + variable ATTACH + + set con [InitTab $PRIV(base)] + set slave [GetSlave] + InitSlave $slave + $slave alias exit ::tkcon::DeleteTab $con $slave + if {$PRIV(name) != ""} { + set ATTACH($con) [list [list $PRIV(name) $slave] slave] + } else { + set ATTACH($con) [list $slave slave] + } + $PRIV(X) configure -state normal + MenuConfigure Console "Delete Tab" -state normal + GotoTab $con +} + +# The extra code arg is for the alias of exit to this function +proc ::tkcon::DeleteTab {{con {}} {slave {}} {code 0}} { + variable PRIV + + set numtabs [llength $PRIV(tabs)] + if {$numtabs <= 2} { + $PRIV(X) configure -state disabled + MenuConfigure Console "Delete Tab" -state disabled + } + if {$numtabs == 1} { + # in the master, it should do the right thing + # currently the first master still exists - need rearch to fix + exit + # we might end up here, depending on how exit is rerouted + return + } + + if {$con == ""} { + set con $PRIV(console) + } + catch {unset ATTACH($con)} + set curtab [lsearch -exact $PRIV(tabs) $con] + set PRIV(tabs) [lreplace $PRIV(tabs) $curtab $curtab] + + set numtabs [llength $PRIV(tabs)] + set nexttab $curtab + if {$nexttab >= $numtabs} { + set nexttab end + } + set nexttab [lindex $PRIV(tabs) $nexttab] + + GotoTab $nexttab + + if {$slave != "" && $slave != $::tkcon::OPT(exec)} { + interp delete $slave + } + destroy $PRIV(tabframe).cb[winfo name $con] + destroy $con +} + +## ::tkcon::GarbageCollect - do various cleanup ops periodically to our setup +## +proc ::tkcon::GarbageCollect {} { + variable OPT + variable PRIV + + foreach w $PRIV(tabs) { + if {[winfo exists $w]} { + ## Remove error tags that no longer span anything + ## Make sure the tag pattern matches the unique tag prefix + foreach tag [$w tag names] { + if {[string match _tag* $tag] + && ![llength [$w tag ranges $tag]]} { + $w tag delete $tag + } + } + } + } + if {$OPT(gc-delay)} { + after $OPT(gc-delay) ::tkcon::GarbageCollect + } +} + +## ::tkcon::Eval - 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 ::tkcon::CmdSep) in +## case a multiple commands were pasted in, then each is eval'ed (by +## ::tkcon::EvalCmd) in turn. Any uncompleted command will not be eval'ed. +# ARGS: w - console text widget +# Calls: ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd +## +proc ::tkcon::Eval {w} { + set complete [CmdSep [CmdGet $w] cmds last] + $w mark set insert end-1c + $w insert end \n + if {[llength $cmds]} { + foreach c $cmds {EvalCmd $w $c} + $w insert insert $last {} + } elseif {$complete} { + EvalCmd $w $last + } + if {[winfo exists $w]} { + $w see insert + } +} + +## ::tkcon::EvalCmd - evaluates a single command, adding it to history +# ARGS: w - console text widget +# cmd - the command to evaluate +# Calls: ::tkcon::Prompt +# Outputs: result of command to stdout (or stderr if error occured) +# Returns: next event number +## +proc ::tkcon::EvalCmd {w cmd} { + variable OPT + variable PRIV + + $w mark set output end + if {$cmd ne ""} { + set code 0 + if {$OPT(subhistory)} { + set ev [EvalSlave history nextid] + incr ev -1 + ## FIX: calcmode doesn't work with requesting history events + if {$cmd eq "!!"} { + set code [catch {EvalSlave history event $ev} cmd] + if {!$code} {$w insert output $cmd\n stdin} + } elseif {[regexp {^!(.+)$} $cmd dummy event]} { + ## Check last event because history event is broken + set code [catch {EvalSlave history event $ev} cmd] + if {!$code && ![string match ${event}* $cmd]} { + set code [catch {EvalSlave history event $event} cmd] + } + if {!$code} {$w insert output $cmd\n stdin} + } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} { + set code [catch {EvalSlave history event $ev} cmd] + if {!$code} { + regsub -all -- $old $cmd $new cmd + $w insert output $cmd\n stdin + } + } elseif {$OPT(calcmode) && ![catch {expr $cmd} err]} { + AddSlaveHistory $cmd + set cmd $err + set code -1 + } + } + if {$code} { + $w insert output $cmd\n stderr + } else { + ## We are about to evaluate the command, so move the limit + ## mark to ensure that further s don't cause double + ## evaluation of this command - for cases like the command + ## has a vwait or something in it + $w mark set limit end + if {$OPT(nontcl) && ($PRIV(apptype) eq "interp")} { + set code [catch {EvalSend $cmd} res] + if {$code == 1} { + set PRIV(errorInfo) "Non-Tcl errorInfo not available" + } + } elseif {$PRIV(apptype) eq "socket"} { + set code [catch {EvalSocket $cmd} res] + if {$code == 1} { + set PRIV(errorInfo) "Socket-based errorInfo not available" + } + } else { + set code [catch {EvalAttached $cmd} res] + if {$code == 1} { + if {[catch {EvalAttached [list set errorInfo]} err]} { + set PRIV(errorInfo) "Error getting errorInfo:\n$err" + } else { + set PRIV(errorInfo) $err + } + } + } + if {![winfo exists $w]} { + # early abort - must be a deleted tab + return + } + AddSlaveHistory $cmd + # Run any user defined result filter command. The command is + # passed result code and data. + if {[llength $OPT(resultfilter)]} { + set cmd [linsert $OPT(resultfilter) end $code $res] + if {[catch {EvalAttached $cmd} res2]} { + $w insert output "Filter failed: $res2" stderr \n stdout + } else { + set res $res2 + } + } + catch {EvalAttached [list set _ $res]} + set maxlen $OPT(maxlinelen) + set trailer "" + if {($maxlen > 0) && ([string length $res] > $maxlen)} { + # If we exceed maximum desired output line length, truncate + # the result and add "...+${num}b" in error coloring + set trailer ...+[expr {[string length $res]-$maxlen}]b + set res [string range $res 0 $maxlen] + } + if {$code} { + if {$OPT(hoterrors)} { + set tag [UniqueTag $w] + $w insert output $res [list stderr $tag] \n$trailer stderr + $w tag bind $tag \ + [list $w tag configure $tag -underline 1] + $w tag bind $tag \ + [list $w tag configure $tag -underline 0] + $w tag bind $tag \ + "if {!\[info exists tk::Priv(mouseMoved)\] || !\$tk::Priv(mouseMoved)} \ + {[list $OPT(edit) -attach [Attach] -type error -- $PRIV(errorInfo)]}" + } else { + $w insert output $res\n$trailer stderr + } + } elseif {$res ne ""} { + $w insert output $res stdout $trailer stderr \n stdout + } + } + } + Prompt + set PRIV(event) [EvalSlave history nextid] +} + +## ::tkcon::EvalSlave - 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 ::tkcon::EvalSlave args { + interp eval $::tkcon::OPT(exec) $args +} + +## ::tkcon::EvalOther - evaluate a command in a foreign interp or slave +## without attaching to it. No check for existence is made. +# ARGS: app - interp/slave name +# type - (slave|interp) +## +proc ::tkcon::EvalOther { app type args } { + if {$type eq "slave"} { + return [Slave $app $args] + } else { + return [uplevel 1 ::send::send [list $app] $args] + } +} + +## ::tkcon::AddSlaveHistory - +## Command is added to history only if different from previous command. +## This also doesn't cause the history id to be incremented, although the +## command will be evaluated. +# ARGS: cmd - command to add +## +proc ::tkcon::AddSlaveHistory cmd { + set ev [EvalSlave history nextid] + incr ev -1 + set code [catch {EvalSlave history event $ev} lastCmd] + if {$code || $cmd ne $lastCmd} { + EvalSlave history add $cmd + # Save history every time so it's not lost in case of an abnormal termination. + # Do not warn in case of an error: we don't want an error message + # after each command if the history file is not writable. + catch {SaveHistory} + } +} + +## ::tkcon::EvalSend - sends the args to the attached interpreter +## Varies from 'send' by determining whether attachment is dead +## when an error is received +# ARGS: cmd - the command string to send across +# Returns: the result of the command +## +proc ::tkcon::EvalSend cmd { + variable OPT + variable PRIV + + if {$PRIV(deadapp)} { + if {[lsearch -exact [::send::interps] $PRIV(app)]<0} { + return + } else { + set PRIV(appname) [string range $PRIV(appname) 5 end] + set PRIV(deadapp) 0 + Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)] + } + } + set code [catch {::send::send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result] + if {$code && [lsearch -exact [::send::interps] $PRIV(app)]<0} { + ## Interpreter disappeared + if {($OPT(dead) ne "leave") && + (($OPT(dead) eq "ignore") || + [tk_messageBox -title "Dead Attachment" -type yesno \ + -icon info -message \ + "\"$PRIV(app)\" appears to have died.\ + \nReturn to primary slave interpreter?"] eq "no")} { + set PRIV(appname) "DEAD:$PRIV(appname)" + set PRIV(deadapp) 1 + } else { + set err "Attached Tk interpreter \"$PRIV(app)\" died." + Attach {} + set PRIV(deadapp) 0 + EvalSlave set errorInfo $err + } + Prompt \n [CmdGet $PRIV(console)] + } + return -code $code $result +} + +## ::tkcon::EvalSocket - sends the string to an interpreter attached via +## a tcp/ip socket +## +## In the EvalSocket case, ::tkcon::PRIV(app) is the socket id +## +## Must determine whether socket is dead when an error is received +# ARGS: cmd - the data string to send across +# Returns: the result of the command +## +proc ::tkcon::EvalSocket cmd { + variable OPT + variable PRIV + global tcl_version + + if {$PRIV(deadapp)} { + if {![info exists PRIV(app)] || \ + [catch {eof $PRIV(app)} eof] || $eof} { + return + } else { + set PRIV(appname) [string range $PRIV(appname) 5 end] + set PRIV(deadapp) 0 + Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)] + } + } + # Sockets get \'s interpreted, so that users can + # send things like \n\r or explicit hex values + set cmd [subst -novariables -nocommands $cmd] + #puts [list $PRIV(app) $cmd] + set code [catch {puts $PRIV(app) $cmd ; flush $PRIV(app)} result] + if {$code && [eof $PRIV(app)]} { + ## Interpreter died or disappeared + puts "$code eof [eof $PRIV(app)]" + EvalSocketClosed $PRIV(app) + } + return -code $code $result +} + +## ::tkcon::EvalSocketEvent - fileevent command for an interpreter attached +## via a tcp/ip socket +## Must determine whether socket is dead when an error is received +# ARGS: args - the args to send across +# Returns: the result of the command +## +proc ::tkcon::EvalSocketEvent {sock} { + variable PRIV + + if {[gets $sock line] == -1} { + if {[eof $sock]} { + EvalSocketClosed $sock + } + return + } + puts $line +} + +## ::tkcon::EvalSocketClosed - takes care of handling a closed eval socket +## +# ARGS: args - the args to send across +# Returns: the result of the command +## +proc ::tkcon::EvalSocketClosed {sock} { + variable OPT + variable PRIV + + catch {close $sock} + if {$sock ne $PRIV(app)} { + # If we are not still attached to that socket, just return. + # Might be nice to tell the user the socket closed ... + return + } + if {$OPT(dead) ne "leave" && + ($OPT(dead) eq "ignore" || + [tk_messageBox -title "Dead Attachment" -type yesno \ + -icon question \ + -message "\"$PRIV(app)\" appears to have died.\ + \nReturn to primary slave interpreter?"] eq "no")} { + set PRIV(appname) "DEAD:$PRIV(appname)" + set PRIV(deadapp) 1 + } else { + set err "Attached Tk interpreter \"$PRIV(app)\" died." + Attach {} + set PRIV(deadapp) 0 + EvalSlave set errorInfo $err + } + Prompt \n [CmdGet $PRIV(console)] +} + +## ::tkcon::EvalNamespace - evaluates the args in a particular namespace +## This is an override for ::tkcon::EvalAttached for when the user wants +## to attach to a particular namespace of the attached interp +# ARGS: attached +# namespace the namespace to evaluate in +# args the args to evaluate +# RETURNS: the result of the command +## +proc ::tkcon::EvalNamespace { attached namespace args } { + if {[llength $args]} { + uplevel \#0 $attached \ + [list [concat [list namespace eval $namespace] $args]] + } +} + + +## ::tkcon::Namespaces - return all the namespaces descendent from $ns +## +# +## +proc ::tkcon::Namespaces {{ns ::} {l {}}} { + if {$ns ne ""} { lappend l $ns } + foreach i [EvalAttached [list namespace children $ns]] { + set l [Namespaces $i $l] + } + return $l +} + +## ::tkcon::CmdGet - gets the current command from the console widget +# ARGS: w - console text widget +# Returns: text which compromises current command line +## +proc ::tkcon::CmdGet w { + if {![llength [$w tag nextrange prompt limit end]]} { + $w tag add stdin limit end-1c + return [$w get limit end-1c] + } +} + +## ::tkcon::CmdSep - 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. +# last - 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 ::tkcon::CmdSep {cmd list last} { + upvar 1 $list cmds $last inc + set inc {} + set cmds {} + foreach c [split [string trimleft $cmd] \n] { + if {$inc ne ""} { + append inc \n$c + } else { + append inc [string trimleft $c] + } + if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} { + if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} + set inc {} + } + } + set i [string equal $inc {}] + if {$i && $cmds ne "" && ![string match *\n $cmd]} { + set inc [lindex $cmds end] + set cmds [lreplace $cmds end end] + } + return $i +} + +## ::tkcon::CmdSplit - splits multiple commands into a list +# ARGS: cmd - (possible) multiple command to separate +# Returns: constituent commands in a list +## +proc ::tkcon::CmdSplit {cmd} { + set inc {} + set cmds {} + foreach cmd [split [string trimleft $cmd] \n] { + if {$inc ne ""} { + append inc \n$cmd + } else { + append inc [string trimleft $cmd] + } + if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} { + #set inc [string trimright $inc] + if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} + set inc {} + } + } + if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc} + return $cmds +} + +## ::tkcon::UniqueTag - creates a uniquely named tag, reusing names +## Called by ::tkcon::EvalCmd +# ARGS: w - text widget +# Outputs: tag name guaranteed unique in the widget +## +proc ::tkcon::UniqueTag {w} { + set tags [$w tag names] + set idx 0 + while {[lsearch -exact $tags _tag[incr idx]] != -1} {} + return _tag$idx +} + +## ::tkcon::ConstrainBuffer - This limits the amount of data in the text widget +## Called by ::tkcon::Prompt and in tkcon proc buffer/console switch cases +# ARGS: w - console text widget +# size - # of lines to constrain to +# Outputs: may delete data in console widget +## +proc ::tkcon::ConstrainBuffer {w size} { + if {$size && ([$w index end] > $size)} { + $w delete 1.0 [expr {int([$w index end])-$size}].0 + } +} + +## ::tkcon::Prompt - displays the prompt in the console widget +# ARGS: w - console text widget +# Outputs: prompt (specified in ::tkcon::OPT(prompt1)) to console +## +proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} { + variable OPT + variable PRIV + + set w $PRIV(console) + if {![winfo exists $w]} { return } + if {$pre ne ""} { $w insert end $pre stdout } + set i [$w index end-1c] + if {!$OPT(showstatusbar)} { + if {$PRIV(appname) ne ""} { + $w insert end ">$PRIV(appname)< " prompt + } + if {$PRIV(namesp) ne "::"} { + $w insert end "<$PRIV(namesp)> " prompt + } + } + if {$prompt ne ""} { + $w insert end $prompt prompt + } else { + $w insert end [EvalSlave subst $OPT(prompt1)] prompt + } + $w mark set output $i + $w mark set insert end + $w mark set limit insert + $w mark gravity limit left + if {$post ne ""} { $w insert end $post stdin } + ConstrainBuffer $w $OPT(buffer) + set ::tkcon::PRIV(StatusCursor) [$w index insert] + $w see end +} +proc ::tkcon::RePrompt {{pre {}} {post {}} {prompt {}}} { + # same as prompt, but does nothing for those actions where we + # only wanted to refresh the prompt on attach change when the + # statusbar is showing (which carries that info instead) + variable OPT + if {!$OPT(showstatusbar)} { + Prompt $pre $post $prompt + } +} + +## ::tkcon::About - gives about info for tkcon +## +proc ::tkcon::About {} { + variable OPT + variable PRIV + variable COLOR + + set w $PRIV(base).about + if {![winfo exists $w]} { + global tk_patchLevel tcl_patchLevel tcl_version + toplevel $w + wm withdraw $w + wm transient $w $PRIV(root) + wm group $w $PRIV(root) + catch {wm attributes $w -type dialog} + wm title $w "About tkcon v$PRIV(version)" + wm resizable $w 0 0 + button $w.b -text Dismiss -command [list wm withdraw $w] + text $w.text -height 9 -width 60 \ + -foreground $COLOR(stdin) \ + -background $COLOR(bg) \ + -font $OPT(font) -borderwidth 1 -highlightthickness 0 + grid $w.text -sticky news + grid $w.b -sticky se -padx 6 -pady 4 + $w.text tag config center -justify center + $w.text tag config title -justify center -font {Courier -18 bold} + # strip down the RCS info displayed in the about box + regexp {,v ([0-9\./: ]*)} $PRIV(RCS) -> RCS + $w.text insert 1.0 "About tkcon v$PRIV(version)" title \ + "\n\nCopyright 1995-2002 Jeffrey Hobbs, $PRIV(email)\ + \nRelease Info: v$PRIV(version), CVS v$RCS\ + \nDocumentation available at:\n$PRIV(docs)\ + \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center + $w.text config -state disabled + bind $w [list destroy $w] + } + wm deiconify $w +} + +## ::tkcon::InitMenus - inits the menubar and popup for the console +# ARGS: w - console text widget +## +proc ::tkcon::InitMenus {w title} { + variable OPT + variable PRIV + variable COLOR + global tcl_platform + + if {[catch {menu $w.pop}]} { + label $w.label -text "Menus not available in plugin mode" + grid $w.label -sticky ew + return + } + menu $w.context -disabledforeground $COLOR(disabled) + set PRIV(context) $w.context + set PRIV(popup) $w.pop + + proc MenuButton {w m l} { + $w add cascade -label $m -underline 0 -menu $w.$l + return $w.$l + } + proc MenuConfigure {m l args} { + variable PRIV + eval [list $PRIV(menubar).[string tolower $m] entryconfigure $l] $args + eval [list $PRIV(popup).[string tolower $m] entryconfigure $l] $args + } + + foreach m [list File Console Edit Interp Prefs History Help] { + set l [string tolower $m] + MenuButton $w $m $l + $w.pop add cascade -label $m -underline 0 -menu $w.pop.$l + } + + ## File Menu + ## + foreach m [list [menu $w.file -disabledforeground $COLOR(disabled)] \ + [menu $w.pop.file -disabledforeground $COLOR(disabled)]] { + $m add command -label "Load File" -underline 0 -command ::tkcon::Load + $m add cascade -label "Save ..." -underline 0 -menu $m.save + $m add separator + $m add command -label "Quit" -underline 0 -accel $PRIV(ACC)q \ + -command exit + + ## Save Menu + ## + set s $m.save + menu $s -disabledforeground $COLOR(disabled) + $s add command -label "All" -underline 0 \ + -command {::tkcon::Save {} all} + $s add command -label "History" -underline 0 \ + -command {::tkcon::Save {} history} + $s add command -label "Stdin" -underline 3 \ + -command {::tkcon::Save {} stdin} + $s add command -label "Stdout" -underline 3 \ + -command {::tkcon::Save {} stdout} + $s add command -label "Stderr" -underline 3 \ + -command {::tkcon::Save {} stderr} + } + + ## Console Menu + ## + foreach m [list [menu $w.console -disabledfore $COLOR(disabled)] \ + [menu $w.pop.console -disabledfore $COLOR(disabled)]] { + $m add command -label "$title Console" -state disabled + $m add command -label "New Console" -underline 0 -accel $PRIV(ACC)N \ + -command ::tkcon::New + $m add command -label "New Tab" -underline 4 -accel $PRIV(ACC)T \ + -command ::tkcon::NewTab + $m add command -label "Delete Tab" -underline 0 \ + -command ::tkcon::DeleteTab -state disabled + $m add command -label "Close Console" -underline 0 -accel $PRIV(ACC)w \ + -command ::tkcon::Destroy + $m add command -label "Clear Console" -underline 1 -accel Ctrl-l \ + -command { clear; ::tkcon::Prompt } + if {[tk windowingsystem] eq "x11"} { + $m add separator + $m add command -label "Make Xauth Secure" -und 5 \ + -command ::tkcon::XauthSecure + } + $m add separator + $m add cascade -label "Attach To ..." -underline 0 -menu $m.attach + + ## Attach Console Menu + ## + set sub [menu $m.attach -disabledforeground $COLOR(disabled)] + $sub add cascade -label "Interpreter" -underline 0 -menu $sub.apps + $sub add cascade -label "Namespace" -underline 0 -menu $sub.name + + ## Attach Console Menu + ## + menu $sub.apps -disabledforeground $COLOR(disabled) \ + -postcommand [list ::tkcon::AttachMenu $sub.apps] + + ## Attach Namespace Menu + ## + menu $sub.name -disabledforeground $COLOR(disabled) \ + -postcommand [list ::tkcon::NamespaceMenu $sub.name] + + ## Attach Socket Menu + ## + $sub add cascade -label "Socket" -underline 0 -menu $sub.sock + menu $sub.sock -disabledforeground $COLOR(disabled) \ + -postcommand [list ::tkcon::SocketMenu $sub.sock] + + if {[tk windowingsystem] eq "x11"} { + ## Attach Display Menu + ## + $sub add cascade -label "Display" -underline 0 -menu $sub.disp + menu $sub.disp -disabledforeground $COLOR(disabled) \ + -postcommand [list ::tkcon::DisplayMenu $sub.disp] + } + } + + ## Edit Menu + ## + set text $PRIV(console) + foreach m [list [menu $w.edit] [menu $w.pop.edit]] { + $m add command -label "Cut" -underline 2 -accel $PRIV(ACC)x \ + -command [list ::tkcon::Cut $text] + $m add command -label "Copy" -underline 0 -accel $PRIV(ACC)c \ + -command [list ::tkcon::Copy $text] + $m add command -label "Paste" -underline 0 -accel $PRIV(ACC)v \ + -command [list ::tkcon::Paste $text] + $m add separator + $m add command -label "Find" -underline 0 -accel $PRIV(ACC)F \ + -command [list ::tkcon::FindBox $text] + } + + ## Interp Menu + ## + foreach m [list $w.interp $w.pop.interp] { + menu $m -disabledforeground $COLOR(disabled) \ + -postcommand [list ::tkcon::InterpMenu $m] + } + + ## Prefs Menu + ## + foreach m [list [menu $w.prefs] [menu $w.pop.prefs]] { + $m add check -label "Brace Highlighting" \ + -underline 0 -variable ::tkcon::OPT(lightbrace) + $m add check -label "Command Highlighting" \ + -underline 0 -variable ::tkcon::OPT(lightcmd) + $m add check -label "History Substitution" \ + -underline 0 -variable ::tkcon::OPT(subhistory) + $m add check -label "Hot Errors" \ + -underline 4 -variable ::tkcon::OPT(hoterrors) + $m add check -label "Non-Tcl Attachments" \ + -underline 0 -variable ::tkcon::OPT(nontcl) + $m add check -label "Calculator Mode" \ + -underline 1 -variable ::tkcon::OPT(calcmode) + $m add check -label "Show Multiple Matches" \ + -underline 0 -variable ::tkcon::OPT(showmultiple) + if {!$PRIV(AQUA)} { + $m add check -label "Show Menubar" \ + -underline 5 -variable ::tkcon::OPT(showmenu) \ + -command { + $::tkcon::PRIV(root) configure \ + -menu [expr {$::tkcon::OPT(showmenu) ? + $::tkcon::PRIV(menubar) : {}}] + } + } + $m add check -label "Show Statusbar" \ + -underline 5 -variable ::tkcon::OPT(showstatusbar) \ + -command { + if {$::tkcon::OPT(showstatusbar)} { + grid $::tkcon::PRIV(statusbar) + } else { grid remove $::tkcon::PRIV(statusbar) } + } + $m add cascade -label "Scrollbar" -underline 2 -menu $m.scroll + + ## Scrollbar Menu + ## + set m [menu $m.scroll] + $m add radio -label "Left" -value left \ + -variable ::tkcon::OPT(scrollypos) \ + -command { grid configure $::tkcon::PRIV(scrolly) -column 0 } + $m add radio -label "Right" -value right \ + -variable ::tkcon::OPT(scrollypos) \ + -command { grid configure $::tkcon::PRIV(scrolly) -column 2 } + } + + ## History Menu + ## + foreach m [list $w.history $w.pop.history] { + menu $m -disabledforeground $COLOR(disabled) \ + -postcommand [list ::tkcon::HistoryMenu $m] + } + + ## Help Menu + ## + foreach m [list [menu $w.help] [menu $w.pop.help]] { + $m add command -label "About " -underline 0 -accel $PRIV(ACC)A \ + -command ::tkcon::About + $m add command -label "Retrieve Latest Version" -underline 0 \ + -command ::tkcon::Retrieve + if {![catch {package require ActiveTcl} ver]} { + set cmd "" + if {$tcl_platform(platform) == "windows"} { + package require registry + set ver [join [lrange [split $ver .] 0 3] .] + set key {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl} + if {![catch {registry get "$key\\$ver\\Help" ""} help] + && [file exists $help]} { + set cmd [list exec $::env(COMSPEC) /c start {} $help] + } + } elseif {$tcl_platform(os) == "Darwin"} { + set ver ActiveTcl-[join [lrange [split $ver .] 0 1] .] + set rsc "/Library/Frameworks/Tcl.framework/Resources" + set help "$rsc/English.lproj/$ver/index.html" + if {[file exists $help]} { + set cmd [list exec open $help] + } + } elseif {$tcl_platform(platform) == "unix"} { + set help [file dirname [info nameofexe]] + append help /../html/index.html + if {[file exists $help]} { + set cmd [list puts "Start $help"] + } + } + if {$cmd != ""} { + $m add separator + $m add command -label "ActiveTcl Help" -underline 10 \ + -command $cmd + } + } + } +} + +## ::tkcon::HistoryMenu - dynamically build the menu for attached interpreters +## +# ARGS: m - menu widget +## +proc ::tkcon::HistoryMenu m { + variable PRIV + + if {![winfo exists $m]} return + set id [EvalSlave history nextid] + if {$PRIV(histid)==$id} return + set PRIV(histid) $id + $m delete 0 end + while {($id>1) && ($id>$PRIV(histid)-10) && \ + ![catch {EvalSlave history event [incr id -1]} tmp]} { + set lbl $tmp + if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... } + $m add command -label "$id: $lbl" -command " + $::tkcon::PRIV(console) delete limit end + $::tkcon::PRIV(console) insert limit [list $tmp] + $::tkcon::PRIV(console) see end + ::tkcon::Eval $::tkcon::PRIV(console)" + } +} + +## ::tkcon::InterpMenu - dynamically build the menu for attached interpreters +## +# ARGS: w - menu widget +## +proc ::tkcon::InterpMenu w { + variable OPT + variable PRIV + variable COLOR + + if {![winfo exists $w]} return + $w delete 0 end + foreach {app type} [Attach] break + $w add command -label "[string toupper $type]: $app" -state disabled + if {($OPT(nontcl) && $type eq "interp") || $PRIV(deadapp)} { + $w add separator + $w add command -state disabled -label "Communication disabled to" + $w add command -state disabled -label "dead or non-Tcl interps" + return + } + + ## Show Last Error + ## + $w add separator + $w add command -label "Show Last Error" \ + -command [list tkcon error $app $type] + + ## Packages Cascaded Menu + ## + $w add separator + $w add command -label "Manage Packages" -underline 0 \ + -command [list ::tkcon::InterpPkgs $app $type] + + ## State Checkpoint/Revert + ## + $w add separator + $w add command -label "Checkpoint State" \ + -command [list ::tkcon::StateCheckpoint $app $type] + $w add command -label "Revert State" \ + -command [list ::tkcon::StateRevert $app $type] + $w add command -label "View State Change" \ + -command [list ::tkcon::StateCompare $app $type] + + ## Init Interp + ## + $w add separator + $w add command -label "Send tkcon Commands" \ + -command [list ::tkcon::InitInterp $app $type] +} + +## ::tkcon::PkgMenu - fill in in the applications sub-menu +## with a list of all the applications that currently exist. +## +proc ::tkcon::InterpPkgs {app type} { + variable PRIV + + set t $PRIV(base).interppkgs + if {![winfo exists $t]} { + toplevel $t + wm withdraw $t + wm title $t "$app Packages" + wm transient $t $PRIV(root) + wm group $t $PRIV(root) + catch {wm attributes $t -type dialog} + bind $t [list destroy $t] + + label $t.ll -text "Loadable:" -anchor w + label $t.lr -text "Loaded:" -anchor w + listbox $t.loadable -font tkconfixed -background white -borderwidth 1 \ + -yscrollcommand [list $t.llsy set] -selectmode extended + listbox $t.loaded -font tkconfixed -background white -borderwidth 1 \ + -yscrollcommand [list $t.lrsy set] + scrollbar $t.llsy -command [list $t.loadable yview] + scrollbar $t.lrsy -command [list $t.loaded yview] + button $t.load -borderwidth 1 -text ">>" \ + -command [list ::tkcon::InterpPkgLoad $app $type $t.loadable] + if {$::tcl_version >= 8.4} { + $t.load configure -relief flat -overrelief raised + } + + set f [frame $t.btns] + button $f.refresh -width 8 -text "Refresh" -command [info level 0] + button $f.dismiss -width 8 -text "Dismiss" -command [list destroy $t] + grid $f.refresh $f.dismiss -padx 4 -pady 3 -sticky ew + if {$PRIV(AQUA)} { # corner resize control space + grid columnconfigure $f [lindex [grid size $f] 0] -minsize 16 + } + + grid $t.ll x x $t.lr x -sticky ew + grid $t.loadable $t.llsy $t.load $t.loaded $t.lrsy -sticky news + grid $t.btns -sticky e -columnspan 5 + grid columnconfigure $t {0 3} -weight 1 + grid rowconfigure $t 1 -weight 1 + grid configure $t.load -sticky "" + + bind $t.loadable "[list $t.load invoke]; break" + } + $t.loaded delete 0 end + $t.loadable delete 0 end + + # just in case stuff has been added to the auto_path + # we have to make sure that the errorInfo doesn't get screwed up + EvalAttached { + set __tkcon_error $errorInfo + catch {package require bogus-package-name} + set errorInfo ${__tkcon_error} + unset __tkcon_error + } + # get all packages loaded into current interp + foreach pkg [EvalAttached [list info loaded {}]] { + set pkg [lindex $pkg 1] + set loaded($pkg) [package provide $pkg] + } + # get all package names currently visible + foreach pkg [lremove [EvalAttached {package names}] Tcl] { + set version [EvalAttached [list package provide $pkg]] + if {$version ne ""} { + set loaded($pkg) $version + } elseif {![info exists loaded($pkg)]} { + set loadable($pkg) package + } + } + # get packages that are loaded in any interp + foreach pkg [EvalAttached {info loaded}] { + set pkg [lindex $pkg 1] + if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} { + set loadable($pkg) load + } + } + foreach pkg [lsort -dictionary [array names loadable]] { + foreach v [EvalAttached [list package version $pkg]] { + $t.loadable insert end [list $pkg $v "($loadable($pkg))"] + } + } + foreach pkg [lsort -dictionary [array names loaded]] { + $t.loaded insert end [list $pkg $loaded($pkg)] + } + + wm deiconify $t + raise $t +} + +proc ::tkcon::InterpPkgLoad {app type lb} { + # load the lb entry items into the interp + foreach sel [$lb curselection] { + foreach {pkg ver method} [$lb get $sel] { break } + if {$method == "(package)"} { + set code [catch {::tkcon::EvalOther $app $type \ + package require $pkg $ver} msg] + } elseif {$method == "(load)"} { + set code [catch {::tkcon::EvalOther $app $type load {} $pkg} msg] + } else { + set code 1 + set msg "Incorrect entry in Loadable selection" + } + if {$code} { + tk_messageBox -icon error -title "Error requiring $pkg" -type ok \ + -message "Error requiring $pkg $ver:\n$msg\n$::errorInfo" + } + } + # refresh package list + InterpPkgs $app $type +} + +## ::tkcon::AttachMenu - fill in in the applications sub-menu +## with a list of all the applications that currently exist. +## +proc ::tkcon::AttachMenu m { + variable OPT + variable PRIV + + array set interps [set tmp [Interps]] + foreach {i j} $tmp { set tknames($j) {} } + + $m delete 0 end + set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} + $m add radio -label {None (use local slave) } -accel $PRIV(ACC)1 \ + -variable ::tkcon::PRIV(app) \ + -value [concat $::tkcon::PRIV(name) $::tkcon::OPT(exec)] \ + -command "::tkcon::Attach {}; $cmd" + $m add separator + $m add command -label "Foreign Tk Interpreters" -state disabled + foreach i [lsort [lremove [::send::interps] [array names tknames]]] { + $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \ + -command "::tkcon::Attach [list $i] interp; $cmd" + } + $m add separator + + $m add command -label "tkcon Interpreters" -state disabled + foreach i [lsort [array names interps]] { + if {$interps($i) eq ""} { set interps($i) "no Tk" } + if {[regexp {^Slave[0-9]+} $i]} { + set opts [list -label "$i ($interps($i))" \ + -variable ::tkcon::PRIV(app) -value $i \ + -command "::tkcon::Attach [list $i] slave; $cmd"] + if {$PRIV(name) eq $i} { + append opts " -accel $PRIV(ACC)2" + } + eval [list $m add radio] $opts + } else { + set name [concat Main $i] + if {$name eq "Main"} { + $m add radio -label "$name ($interps($i))" -accel $PRIV(ACC)3 \ + -variable ::tkcon::PRIV(app) -value Main \ + -command "::tkcon::Attach [list $name] slave; $cmd" + } else { + $m add radio -label "$name ($interps($i))" \ + -variable ::tkcon::PRIV(app) -value $i \ + -command "::tkcon::Attach [list $name] slave; $cmd" + } + } + } +} + +## Displays Cascaded Menu +## +proc ::tkcon::DisplayMenu m { + $m delete 0 end + set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} + + $m add command -label "New Display" -command ::tkcon::NewDisplay + foreach disp [Display] { + $m add separator + $m add command -label $disp -state disabled + set res [Display $disp] + set win [lindex $res 0] + foreach i [lsort [lindex $res 1]] { + $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \ + -command "::tkcon::Attach [list $i] [list dpy:$win]; $cmd" + } + } +} + +## Sockets Cascaded Menu +## +proc ::tkcon::SocketMenu m { + $m delete 0 end + set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} + + $m add command -label "Create Connection" \ + -command "::tkcon::NewSocket; $cmd" + foreach sock [file channels sock*] { + $m add radio -label $sock -variable ::tkcon::PRIV(app) -value $sock \ + -command "::tkcon::Attach $sock socket; $cmd" + } +} + +## Namepaces Cascaded Menu +## +proc ::tkcon::NamespaceMenu m { + variable PRIV + variable OPT + + $m delete 0 end + if {($PRIV(deadapp) || $PRIV(apptype) eq "socket" || \ + ($OPT(nontcl) && $PRIV(apptype) eq "interp"))} { + $m add command -label "No Namespaces" -state disabled + return + } + + ## Same command as for ::tkcon::AttachMenu items + set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]} + + set names [lsort [Namespaces ::]] + if {[llength $names] > $OPT(maxmenu)} { + $m add command -label "Attached to $PRIV(namesp)" -state disabled + $m add command -label "List Namespaces" \ + -command [list ::tkcon::NamespacesList $names] + } else { + foreach i $names { + if {$i eq "::"} { + $m add radio -label "Main" -value $i \ + -variable ::tkcon::PRIV(namesp) \ + -command "::tkcon::AttachNamespace [list $i]; $cmd" + } else { + $m add radio -label $i -value $i \ + -variable ::tkcon::PRIV(namesp) \ + -command "::tkcon::AttachNamespace [list $i]; $cmd" + } + } + } +} + +## Namepaces List +## +proc ::tkcon::NamespacesList {names} { + variable PRIV + + set f $PRIV(base).namespaces + catch {destroy $f} + toplevel $f + catch {wm attributes $f -type dialog} + listbox $f.names -width 30 -height 15 -selectmode single \ + -yscrollcommand [list $f.scrollv set] \ + -xscrollcommand [list $f.scrollh set] \ + -background white -borderwidth 1 + scrollbar $f.scrollv -command [list $f.names yview] + scrollbar $f.scrollh -command [list $f.names xview] -orient horizontal + frame $f.buttons + button $f.cancel -text "Cancel" -command [list destroy $f] + + grid $f.names $f.scrollv -sticky nesw + grid $f.scrollh -sticky ew + grid $f.buttons -sticky nesw + grid $f.cancel -in $f.buttons -pady 6 + + grid columnconfigure $f 0 -weight 1 + grid rowconfigure $f 0 -weight 1 + #fill the listbox + foreach i $names { + if {$i eq "::"} { + $f.names insert 0 Main + } else { + $f.names insert end $i + } + } + #Bindings + bind $f.names { + ## Catch in case the namespace disappeared on us + catch { ::tkcon::AttachNamespace [%W get [%W nearest %y]] } + ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] + destroy [winfo toplevel %W] + } +} + +# ::tkcon::XauthSecure -- +# +# This removes all the names in the xhost list, and secures +# the display for Tk send commands. Of course, this prevents +# what might have been otherwise allowable X connections +# +# Arguments: +# none +# Results: +# Returns nothing +# +proc ::tkcon::XauthSecure {} { + global tcl_platform + + if {[tk windowingsystem] ne "x11"} { + # This makes no sense outside of Unix + return + } + set hosts [exec xhost] + # the first line is info only + foreach host [lrange [split $hosts \n] 1 end] { + exec xhost -$host + } + exec xhost - + tk_messageBox -title "Xhost secured" -message "Xhost secured" -icon info +} + +## ::tkcon::FindBox - creates minimal dialog interface to ::tkcon::Find +# ARGS: w - text widget +# str - optional seed string for ::tkcon::PRIV(find) +## +proc ::tkcon::FindBox {w {str {}}} { + variable PRIV + + set base $PRIV(base).find + if {![winfo exists $base]} { + toplevel $base + wm withdraw $base + catch {wm attributes $base -type dialog} + wm title $base "tkcon Find" + wm resizable $base 1 0 + + label $base.l -text "Find:" -anchor e + entry $base.e -textvariable ::tkcon::PRIV(find) + + checkbutton $base.case -text "Case Sensitive" \ + -variable ::tkcon::PRIV(find,case) + checkbutton $base.re -text "Use Regexp" \ + -variable ::tkcon::PRIV(find,reg) + + frame $base.sep -borderwidth 1 -relief sunken -height 2 + frame $base.btn + grid $base.l $base.e - - -sticky ew + grid $base.case - $base.re -sticky ew + grid $base.sep -columnspan 4 -sticky ew + grid $base.btn -columnspan 4 -sticky ew + grid columnconfigure $base 3 -weight 1 + + 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 grid [winfo children $base.btn] -padx 4 -pady 2 -sticky ew + if {$PRIV(AQUA)} { # corner resize control space + grid columnconfigure $base.btn \ + [lindex [grid size $base.btn] 0] -minsize 16 + } + + focus $base.e + + bind $base.e [list $base.btn.fnd invoke] + bind $base.e [list $base.btn.dis invoke] + } + $base.btn.fnd config -command "::tkcon::Find [list $w] \$::tkcon::PRIV(find) \ + -case \$::tkcon::PRIV(find,case) -reg \$::tkcon::PRIV(find,reg)" + $base.btn.clr config -command " + [list $w] tag remove find 1.0 end + set ::tkcon::PRIV(find) {} + " + $base.btn.dis config -command " + [list $w] tag remove find 1.0 end + wm withdraw [list $base] + " + if {$str ne ""} { + set PRIV(find) $str + $base.btn.fnd invoke + } + + if {[wm state $base] ne "normal"} { + wm deiconify $base + } else { raise $base } + $base.e select range 0 end +} + +## ::tkcon::Find - searches in text widget $w for $str and highlights it +## If $str is empty, it just deletes any highlighting +# ARGS: w - text widget +# str - string to search for +# -case TCL_BOOLEAN whether to be case sensitive DEFAULT: 0 +# -regexp TCL_BOOLEAN whether to use $str as pattern DEFAULT: 0 +## +proc ::tkcon::Find {w str args} { + $w tag remove find 1.0 end + set truth {^(1|yes|true|on)$} + set opts {} + foreach {key val} $args { + switch -glob -- $key { + -c* { if {[regexp -nocase $truth $val]} { set case 1 } } + -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } } + default { return -code error "Unknown option $key" } + } + } + if {![info exists case]} { lappend opts -nocase } + if {$str eq ""} { return } + $w mark set findmark 1.0 + while {[set ix [eval $w search $opts -count numc -- \ + [list $str] findmark end]] ne ""} { + $w tag add find $ix ${ix}+${numc}c + $w mark set findmark ${ix}+1c + } + $w tag configure find -background $::tkcon::COLOR(blink) + catch {$w see find.first} + return [expr {[llength [$w tag ranges find]]/2}] +} + +## ::tkcon::Attach - called to attach tkcon to an interpreter +# ARGS: name - application name to which tkcon sends commands +# This is either a slave interperter name or tk appname. +# type - (slave|interp) type of interpreter we're attaching to +# slave means it's a tkcon interpreter +# interp means we'll need to 'send' to it. +# Results: ::tkcon::EvalAttached is recreated to evaluate in the +# appropriate interpreter +## +proc ::tkcon::Attach {{name } {type slave} {ns {}}} { + variable PRIV + variable OPT + variable ATTACH + + if {[llength [info level 0]] == 1} { + # no args were specified, return the attach info instead + return [AttachId] + } + set path [concat $PRIV(name) $OPT(exec)] + + set PRIV(displayWin) . + if {$type eq "namespace"} { + return [uplevel 1 ::tkcon::AttachNamespace $name] + } elseif {[string match dpy:* $type]} { + set PRIV(displayWin) [string range $type 4 end] + } elseif {[string match sock* $type]} { + global tcl_version + if {[catch {eof $name} res]} { + return -code error "No known channel \"$name\"" + } elseif {$res} { + catch {close $name} + return -code error "Channel \"$name\" returned EOF" + } + set app $name + set type socket + } elseif {$name ne ""} { + array set interps [Interps] + if {[string match {[Mm]ain} [lindex $name 0]]} { + set name [lrange $name 1 end] + } + if {$name eq $path} { + set name {} + set app $path + set type slave + } elseif {[info exists interps($name)]} { + if {$name eq ""} { set name Main; set app Main } + set type slave + } elseif {[interp exists $name]} { + set name [concat $PRIV(name) $name] + set type slave + } elseif {[interp exists [concat $OPT(exec) $name]]} { + set name [concat $path $name] + set type slave + } elseif {[lsearch -exact [::send::interps] $name] > -1} { + if {[EvalSlave info exists tk_library] + && $name eq [EvalSlave tk appname]} { + set name {} + set app $path + set type slave + } elseif {[set i [lsearch -exact \ + [Main set ::tkcon::PRIV(interps)] $name]] != -1} { + set name [lindex [Main set ::tkcon::PRIV(slaves)] $i] + if {[string match {[Mm]ain} $name]} { set app Main } + set type slave + } else { + set type interp + } + } else { + return -code error "No known interpreter \"$name\"" + } + } else { + set app $path + } + if {![info exists app]} { set app $name } + array set PRIV [list app $app appname $name apptype $type deadapp 0] + + ## ::tkcon::EvalAttached - evaluates the args in the attached interp + ## args should be passed to this procedure as if they were being + ## passed to the 'eval' procedure. This procedure is dynamic to + ## ensure evaluation occurs in the right interp. + # ARGS: args - the command and args to evaluate + ## + set PRIV(namesp) :: + set namespOK 0 + switch -glob -- $type { + slave { + if {$name eq ""} { + interp alias {} ::tkcon::EvalAttached {} \ + ::tkcon::EvalSlave uplevel \#0 + } elseif {$PRIV(app) eq "Main"} { + interp alias {} ::tkcon::EvalAttached {} ::tkcon::Main + } elseif {$PRIV(name) eq $PRIV(app)} { + interp alias {} ::tkcon::EvalAttached {} uplevel \#0 + } else { + interp alias {} ::tkcon::EvalAttached {} \ + ::tkcon::Slave $::tkcon::PRIV(app) + } + set namespOK 1 + } + sock* { + interp alias {} ::tkcon::EvalAttached {} \ + ::tkcon::EvalSlave uplevel \#0 + # The file event will just puts whatever data is found + # into the interpreter + fconfigure $name -buffering line -blocking 0 + fileevent $name readable [list ::tkcon::EvalSocketEvent $name] + } + dpy:* - + interp { + if {$OPT(nontcl)} { + interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSlave + } else { + interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSend + set namespOK 1 + } + } + default { + return -code error "[lindex [info level 0] 0] did not specify\ + a valid type: must be slave or interp" + } + } + if {$ns ne "" && $namespOK} { + AttachNamespace $ns + } + return [AttachId] +} + +proc ::tkcon::AttachId {} { + # return Attach info in a form that Attach accepts again + variable PRIV + + if {$PRIV(appname) eq ""} { + variable OPT + set appname [concat $PRIV(name) $OPT(exec)] + } else { + set appname $PRIV(appname) + } + set id [list $appname $PRIV(apptype)] + # only display ns info if it isn't "::" as that is what is also + # used to indicate no eval in namespace + if {$PRIV(namesp) ne "::"} { lappend id $PRIV(namesp) } + if {[info exists PRIV(console)]} { + variable ATTACH + set ATTACH($PRIV(console)) $id + } + return $id +} + +## ::tkcon::AttachNamespace - called to attach tkcon to a namespace +# ARGS: name - namespace name in which tkcon should eval commands +# Results: ::tkcon::EvalAttached will be modified +## +proc ::tkcon::AttachNamespace { name } { + variable PRIV + variable OPT + + # We could enable 'socket' bound Tcl interps, but we'd have to create + # a return listening socket + if {($OPT(nontcl) && $PRIV(apptype) eq "interp") + || $PRIV(apptype) eq "socket" + || $PRIV(deadapp)} { + return -code error "can't attach to namespace in attached environment" + } + if {$name eq "Main"} {set name ::} + if {$name ne "" && [lsearch [Namespaces ::] $name] == -1} { + return -code error "No known namespace \"$name\"" + } + if {[regexp {^(|::)$} $name]} { + ## If name=={} || ::, we want the primary namespace + set alias [interp alias {} ::tkcon::EvalAttached] + if {[string match ::tkcon::EvalNamespace* $alias]} { + eval [list interp alias {} ::tkcon::EvalAttached {}] \ + [lindex $alias 1] + } + set name :: + } else { + interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalNamespace \ + [interp alias {} ::tkcon::EvalAttached] [list $name] + } + set PRIV(namesp) $name + return [AttachId] +} + +## ::tkcon::NewSocket - called to create a socket to connect to +# ARGS: none +# Results: It will create a socket, and attach if requested +## +proc ::tkcon::NewSocket {} { + variable PRIV + + set t $PRIV(base).newsock + if {![winfo exists $t]} { + toplevel $t + wm withdraw $t + catch {wm attributes $t -type dialog} + wm title $t "tkcon Create Socket" + wm resizable $t 1 0 + label $t.lhost -text "Host: " + entry $t.host -width 16 -takefocus 1 + label $t.lport -text "Port: " + entry $t.port -width 4 -takefocus 1 + button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} -width 4 \ + -takefocus 1 + bind $t.host [list focus $t.port] + bind $t.port [list focus $t.ok] + bind $t.ok [list $t.ok invoke] + grid $t.lhost $t.host $t.lport $t.port $t.ok -sticky ew + grid configure $t.ok -padx 4 -pady 2 + grid columnconfig $t 1 -weight 1 + grid rowconfigure $t 1 -weight 1 + if {$PRIV(AQUA)} { # corner resize control space + grid columnconfigure $t [lindex [grid size $t] 0] -minsize 16 + } + wm transient $t $PRIV(root) + wm group $t $PRIV(root) + wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ + reqwidth $t]) / 2}]+[expr {([winfo \ + screenheight $t]-[winfo reqheight $t]) / 2}] + bind $t [list destroy $t] + } + #$t.host delete 0 end + #$t.port delete 0 end + wm deiconify $t + raise $t + grab $t + focus $t.host + vwait ::tkcon::PRIV(grab) + grab release $t + wm withdraw $t + set host [$t.host get] + set port [$t.port get] + if {$host == ""} { return } + if {[catch { + set sock [socket $host $port] + } err]} { + tk_messageBox -title "Socket Connection Error" \ + -message "Unable to connect to \"$host:$port\":\n$err" \ + -icon error -type ok + } else { + Attach $sock socket + } +} + +## ::tkcon::Load - sources a file into the console +## The file is actually sourced in the currently attached's interp +# ARGS: fn - (optional) filename to source in +# Returns: selected filename ({} if nothing was selected) +## +proc ::tkcon::Load { {fn ""} } { + set types { + {{Tcl Files} {.tcl .tk}} + {{Text Files} {.txt}} + {{All Files} *} + } + # Allow for VFS directories, use Tk dialogs automatically when in + # VFS-based areas + set check [expr {$fn == "" ? [pwd] : $fn}] + if {$::tcl_version >= 8.4 && [lindex [file system $check] 0] == "tclvfs"} { + set opencmd [list ::tk::dialog::file:: open] + } else { + set opencmd [list tk_getOpenFile] + } + if {$fn eq "" && + ([catch {tk_getOpenFile -filetypes $types \ + -title "Source File"} fn] || $fn eq "") + } { return } + EvalAttached [list source $fn] +} + +## ::tkcon::Save - saves the console or other widget 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 ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } { + variable PRIV + + if {![regexp -nocase {^(all|history|stdin|stdout|stderr|widget)$} $type]} { + array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel } + ## Allow user to specify what kind of stuff to save + set type [tk_dialog $PRIV(base).savetype "Save Type" \ + "What part of the text do you want to save?" \ + questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)] + if {$type == 5 || $type == -1} return + set type $s($type) + } + # Allow for VFS directories, use Tk dialogs automatically when in + # VFS-based areas + set check [expr {$opt == "" ? [pwd] : $opt}] + if {$::tcl_version >= 8.4 && [lindex [file system $check] 0] == "tclvfs"} { + set savecmd [list ::tk::dialog::file:: save] + } else { + set savecmd [list tk_getSaveFile] + } + if {$fn eq ""} { + set types { + {{Tcl Files} {.tcl .tk}} + {{Text Files} {.txt}} + {{All Files} *} + } + if {[catch {eval $savecmd [list -defaultextension .tcl \ + -filetypes $types \ + -title "Save $type"]} fn] + || $fn eq ""} return + } + set type [string tolower $type] + switch $type { + stdin - stdout - stderr { + set data {} + foreach {first last} [$PRIV(console) tag ranges $type] { + lappend data [$PRIV(console) get $first $last] + } + set data [join $data \n] + } + history { set data [tkcon history] } + all - default { set data [$PRIV(console) get 1.0 end-1c] } + widget { + set data [$opt get 1.0 end-1c] + } + } + if {[catch {open $fn $mode} fid]} { + return -code error "Save Error: Unable to open '$fn' for writing\n$fid" + } + puts -nonewline $fid $data + close $fid +} + +## ::tkcon::MainInit +## 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 ::tkcon::MainInit {} { + variable PRIV + variable OPT + + if {![info exists PRIV(slaves)]} { + array set PRIV [list slave 0 slaves Main name {} \ + interps [list [tk appname]]] + } + interp alias {} ::tkcon::Main {} ::tkcon::InterpEval Main + interp alias {} ::tkcon::Slave {} ::tkcon::InterpEval + + proc ::tkcon::GetSlave {{slave {}}} { + set i 0 + while {[Slave $slave [list interp exists Slave[incr i]]]} { + # oh my god, an empty loop! + } + set interp [Slave $slave [list interp create Slave$i]] + return $interp + } + + ## ::tkcon::New - 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 ::tkcon::New {} { + variable PRIV + global argv0 argc argv + + set tmp [GetSlave] + lappend PRIV(slaves) $tmp + load {} Tk $tmp + # If we have tbcload, then that should be autoloaded into slaves. + set idx [lsearch [info loaded] "* Tbcload"] + if {$idx != -1} { catch {load {} Tbcload $tmp} } + lappend PRIV(interps) [$tmp eval [list tk appname \ + "[tk appname] $tmp"]] + if {[info exists argv0]} {$tmp eval [list set argv0 $argv0]} + if {[info exists argc]} {$tmp eval [list set argc $argc]} + if {[info exists argv]} {$tmp eval [list set argv $argv]} + $tmp eval [list namespace eval ::tkcon {}] + $tmp eval [list set ::tkcon::PRIV(name) $tmp] + $tmp eval [list set ::tkcon::PRIV(SCRIPT) $::tkcon::PRIV(SCRIPT)] + $tmp alias exit ::tkcon::Exit $tmp + $tmp alias ::tkcon::Destroy ::tkcon::Destroy $tmp + $tmp alias ::tkcon::New ::tkcon::New + $tmp alias ::tkcon::GetSlave ::tkcon::GetSlave $tmp + $tmp alias ::tkcon::Main ::tkcon::InterpEval Main + $tmp alias ::tkcon::Slave ::tkcon::InterpEval + $tmp alias ::tkcon::Interps ::tkcon::Interps + $tmp alias ::tkcon::NewDisplay ::tkcon::NewDisplay + $tmp alias ::tkcon::Display ::tkcon::Display + $tmp alias ::tkcon::StateCheckpoint ::tkcon::StateCheckpoint + $tmp alias ::tkcon::StateCleanup ::tkcon::StateCleanup + $tmp alias ::tkcon::StateCompare ::tkcon::StateCompare + $tmp alias ::tkcon::StateRevert ::tkcon::StateRevert + $tmp eval { + if [catch {source -rsrc tkcon}] { source $::tkcon::PRIV(SCRIPT) } + } + return $tmp + } + + ## ::tkcon::Exit - full exit OR destroy slave console + ## This proc should only be called in the main interpreter from a slave. + ## The master determines whether we do a full exit or just kill the slave. + ## + proc ::tkcon::Exit {slave args} { + variable PRIV + variable OPT + + ## Slave interpreter exit request + if {$OPT(slaveexit) eq "exit" || [llength $PRIV(interps)] == 1} { + ## Only exit if it specifically is stated to do so, or this + ## is the last interp + uplevel 1 exit $args + } else { + ## Otherwise we will delete the slave interp and associated data + Destroy $slave + } + } + + ## ::tkcon::Destroy - 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 ::tkcon::Destroy {{slave {}}} { + variable PRIV + + # Just close on the last one + if {[llength $PRIV(interps)] == 1} { exit } + if {"" == $slave} { + ## Main interpreter close request + if {[tk_messageBox -parent $PRIV(root) -title "Quit tkcon?" \ + -message "Close all windows and exit tkcon?" \ + -icon question -type yesno] == "yes"} { exit } + return + } elseif {$slave == $::tkcon::OPT(exec)} { + set name [tk appname] + set slave "Main" + } else { + ## Slave interpreter close request + set name [InterpEval $slave] + interp delete $slave + } + set PRIV(interps) [lremove $PRIV(interps) [list $name]] + set PRIV(slaves) [lremove $PRIV(slaves) [list $slave]] + StateCleanup $slave + } + + if {$OPT(overrideexit)} { + ## We want to do a couple things before exiting... + if {[catch {rename ::exit ::tkcon::FinalExit} err]} { + puts stderr "tkcon might panic:\n$err" + } + proc ::exit args { + if {$::tkcon::OPT(usehistory)} { + if {[catch {::tkcon::SaveHistory} msg]} { + puts stderr "unable to save history file:\n$msg" + # pause a moment, because we are about to die finally... + after 1000 + } + } + uplevel 1 ::tkcon::FinalExit $args + } + } + + ## ::tkcon::SaveHistory - saves history to history file + ## If the history file is not writable it raises an error + proc ::tkcon::SaveHistory {} { + if {$::tkcon::OPT(usehistory)} { + if {[catch {open $::tkcon::PRIV(histfile) w} fid]} { + error $fid + } else { + set max [::tkcon::EvalSlave history nextid] + set id [expr {$max - $::tkcon::OPT(history)}] + if {$id < 1} { set id 1 } + ## FIX: This puts history in backwards!! + while {($id < $max) && ![catch \ + {::tkcon::EvalSlave history event $id} cmd]} { + if {$cmd ne ""} { + puts $fid "::tkcon::EvalSlave\ + history add [list $cmd]" + } + incr id + } + close $fid + } + } + } + + ## ::tkcon::InterpEval - 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 ::tkcon::InterpEval {{slave {}} args} { + variable PRIV + + if {[llength [info level 0]] == 1} { + # no args given + return $PRIV(slaves) + } elseif {[string match {[Mm]ain} $slave]} { + set slave {} + } + if {[llength $args]} { + return [interp eval $slave uplevel \#0 $args] + } else { + # beware safe interps with Tk + if {[interp eval $slave {llength [info commands tk]}]} { + if {[catch {interp eval $slave tk appname} name]} { + return "safetk" + } + return $name + } + } + } + + proc ::tkcon::Interps {{ls {}} {interp {}}} { + if {$interp eq ""} { + lappend ls {} [tk appname] + } + foreach i [interp slaves $interp] { + if {$interp ne ""} { set i "$interp $i" } + if {[interp eval $i package provide Tk] ne ""} { + # beware safe interps with Tk + if {[catch {interp eval $i tk appname} name]} { + set name {} + } + lappend ls $i $name + } else { + lappend ls $i {} + } + set ls [Interps $ls $i] + } + return $ls + } + + proc ::tkcon::Display {{disp {}}} { + variable DISP + + set res {} + if {$disp != ""} { + if {![info exists DISP($disp)]} { return } + return [list $DISP($disp) [winfo interps -displayof $DISP($disp)]] + } + return [lsort -dictionary [array names DISP]] + } + + proc ::tkcon::NewDisplay {} { + variable PRIV + variable DISP + + set t $PRIV(base).newdisp + if {![winfo exists $t]} { + toplevel $t + wm withdraw $t + catch {wm attributes $t -type dialog} + wm title $t "tkcon Attach to Display" + label $t.gets -text "New Display: " + entry $t.data -width 32 + button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} + bind $t.data [list $t.ok invoke] + bind $t.ok [list $t.ok invoke] + grid $t.gets $t.data -sticky ew + grid $t.ok - -sticky ew + grid columnconfig $t 1 -weight 1 + grid rowconfigure $t 1 -weight 1 + wm transient $t $PRIV(root) + wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ + reqwidth $t]) / 2}]+[expr {([winfo \ + screenheight $t]-[winfo reqheight $t]) / 2}] + } + $t.data delete 0 end + wm deiconify $t + raise $t + grab $t + focus $t.data + vwait ::tkcon::PRIV(grab) + grab release $t + wm withdraw $t + set disp [$t.data get] + if {$disp == ""} { return } + regsub -all {\.} [string tolower $disp] ! dt + set dt $PRIV(base).$dt + destroy $dt + if {[catch { + toplevel $dt -screen $disp + set interps [winfo interps -displayof $dt] + if {![llength $interps]} { + error "No other Tk interpreters on $disp" + } + ::send::send -displayof $dt [lindex $interps 0] [list info tclversion] + } err]} { + global env + if {[info exists env(DISPLAY)]} { + set myd $env(DISPLAY) + } else { + set myd "myDisplay:0" + } + tk_messageBox -title "Display Connection Error" \ + -message "Unable to connect to \"$disp\":\n$err\ + \nMake sure you have xauth-based permissions\ + (xauth add $myd . `mcookie`), and xhost is disabled\ + (xhost -) on \"$disp\"" \ + -icon error -type ok + destroy $dt + return + } + set DISP($disp) $dt + wm withdraw $dt + bind $dt [subst {catch {unset ::tkcon::DISP($disp)}}] + tk_messageBox -title "$disp Connection" \ + -message "Connected to \"$disp\", found:\n[join $interps \n]" \ + -type ok + } + + ## + ## The following state checkpoint/revert procedures are very sketchy + ## and prone to problems. They do not track modifications to currently + ## existing procedures/variables, and they can really screw things up + ## if you load in libraries (especially Tk) between checkpoint and + ## revert. Only with this knowledge in mind should you use these. + ## + + ## ::tkcon::StateCheckpoint - checkpoints the current state of the system + ## This allows you to return to this state with ::tkcon::StateRevert + # ARGS: + ## + proc ::tkcon::StateCheckpoint {app type} { + variable CPS + variable PRIV + + if {[info exists CPS($type,$app,cmd)] && \ + [tk_dialog $PRIV(base).warning "Overwrite Previous State?" \ + "Are you sure you want to lose previously checkpointed\ + state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return + set CPS($type,$app,cmd) [EvalOther $app $type info commands *] + set CPS($type,$app,var) [EvalOther $app $type info vars *] + return + } + + ## ::tkcon::StateCompare - compare two states and output difference + # ARGS: + ## + proc ::tkcon::StateCompare {app type {verbose 0}} { + variable CPS + variable PRIV + variable OPT + variable COLOR + + if {![info exists CPS($type,$app,cmd)]} { + return -code error \ + "No previously checkpointed state for $type \"$app\"" + } + set w $PRIV(base).compare + if {[winfo exists $w]} { + $w.text config -state normal + $w.text delete 1.0 end + } else { + toplevel $w + catch {wm attributes $w -type dialog} + frame $w.btn + scrollbar $w.sy -command [list $w.text yview] + text $w.text -yscrollcommand [list $w.sy set] -height 12 \ + -foreground $COLOR(stdin) \ + -background $COLOR(bg) \ + -insertbackground $COLOR(cursor) \ + -font $OPT(font) -borderwidth 1 -highlightthickness 0 + $w.text tag config red -foreground red + button $w.close -text "Dismiss" -width 8 \ + -command [list destroy $w] + button $w.check -text "Recheckpoint" -width 11 + button $w.revert -text "Revert" -width 8 + button $w.expand -text "Verbose" -width 8 + button $w.update -text "Update" -width 8 + + grid $w.text - - - - - $w.sy -sticky news + grid x $w.check $w.revert $w.expand $w.update $w.close + grid configure $w.close -padx {4 0} + grid rowconfigure $w 0 -weight 1 + grid columnconfigure $w 0 -weight 1 + } + wm title $w "Compare State: $type [list $app]" + + $w.check config \ + -command "::tkcon::StateCheckpoint [list $app] $type; \ + ::tkcon::StateCompare [list $app] $type $verbose" + $w.revert config \ + -command "::tkcon::StateRevert [list $app] $type; \ + ::tkcon::StateCompare [list $app] $type $verbose" + $w.update config -command [info level 0] + if {$verbose} { + $w.expand config -text Brief \ + -command [list ::tkcon::StateCompare $app $type 0] + } else { + $w.expand config -text Verbose \ + -command [list ::tkcon::StateCompare $app $type 1] + } + ## Don't allow verbose mode unless 'dump' exists in $app + ## We're assuming this is tkcon's dump command + set hasdump [llength [EvalOther $app $type info commands dump]] + if {$hasdump} { + $w.expand config -state normal + } else { + $w.expand config -state disabled + } + + set cmds [lremove [EvalOther $app $type info commands *] \ + $CPS($type,$app,cmd)] + set vars [lremove [EvalOther $app $type info vars *] \ + $CPS($type,$app,var)] + + if {$hasdump && $verbose} { + set cmds [EvalOther $app $type eval dump c -nocomplain $cmds] + set vars [EvalOther $app $type eval dump v -nocomplain $vars] + } + $w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \ + $cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {} + + raise $w + $w.text config -state disabled + } + + ## ::tkcon::StateRevert - reverts interpreter to previous state + # ARGS: + ## + proc ::tkcon::StateRevert {app type} { + variable CPS + variable PRIV + + if {![info exists CPS($type,$app,cmd)]} { + return -code error \ + "No previously checkpointed state for $type \"$app\"" + } + if {![tk_dialog $PRIV(base).warning "Revert State?" \ + "Are you sure you want to revert the state in $type \"$app\"?"\ + questhead 1 "Do It" "Cancel"]} { + foreach i [lremove [EvalOther $app $type info commands *] \ + $CPS($type,$app,cmd)] { + catch {EvalOther $app $type rename $i {}} + } + foreach i [lremove [EvalOther $app $type info vars *] \ + $CPS($type,$app,var)] { + catch {EvalOther $app $type unset $i} + } + } + } + + ## ::tkcon::StateCleanup - cleans up state information in master array + # + ## + proc ::tkcon::StateCleanup {args} { + variable CPS + + if {![llength $args]} { + foreach state [array names CPS slave,*] { + if {![interp exists [string range $state 6 end]]} { + unset CPS($state) + } + } + } else { + set app [lindex $args 0] + set type [lindex $args 1] + if {[regexp {^(|slave)$} $type]} { + foreach state [array names CPS "slave,$app\[, \]*"] { + if {![interp exists [string range $state 6 end]]} { + unset CPS($state) + } + } + } else { + catch {unset CPS($type,$app)} + } + } + } +} + +## ::tkcon::Event - get history event, search if string != {} +## look forward (next) if $int>0, otherwise look back (prev) +# ARGS: W - console widget +## +proc ::tkcon::Event {int {str {}}} { + if {!$int} return + + variable PRIV + set w $PRIV(console) + + set nextid [EvalSlave history nextid] + if {$str ne ""} { + ## String is not empty, do an event search + set event $PRIV(event) + if {$int < 0 && $event == $nextid} { set PRIV(cmdbuf) $str } + set len [string len $PRIV(cmdbuf)] + incr len -1 + if {$int > 0} { + ## Search history forward + while {$event < $nextid} { + if {[incr event] == $nextid} { + $w delete limit end + $w insert limit $PRIV(cmdbuf) + break + } elseif { + ![catch {EvalSlave history event $event} res] && + [set p [string first $PRIV(cmdbuf) $res]] > -1 + } { + set p2 [expr {$p + [string length $PRIV(cmdbuf)]}] + $w delete limit end + $w insert limit $res + Blink $w "limit + $p c" "limit + $p2 c" + break + } + } + set PRIV(event) $event + } else { + ## Search history reverse + while {![catch {EvalSlave history event [incr event -1]} res]} { + if {[set p [string first $PRIV(cmdbuf) $res]] > -1} { + set p2 [expr {$p + [string length $PRIV(cmdbuf)]}] + $w delete limit end + $w insert limit $res + set PRIV(event) $event + Blink $w "limit + $p c" "limit + $p2 c" + break + } + } + } + } else { + ## String is empty, just get next/prev event + if {$int > 0} { + ## Goto next command in history + if {$PRIV(event) < $nextid} { + $w delete limit end + if {[incr PRIV(event)] == $nextid} { + $w insert limit $PRIV(cmdbuf) + } else { + $w insert limit [EvalSlave history event $PRIV(event)] + } + } + } else { + ## Goto previous command in history + if {$PRIV(event) == $nextid} { + set PRIV(cmdbuf) [CmdGet $w] + } + if {[catch {EvalSlave history event [incr PRIV(event) -1]} res]} { + incr PRIV(event) + } else { + $w delete limit end + $w insert limit $res + } + } + } + $w mark set insert end + $w see end +} + +## ::tkcon::Highlight - magic highlighting +## beware: voodoo included +# ARGS: +## +proc ::tkcon::Highlight {w type} { + variable COLOR + variable OPT + + switch -exact $type { + "error" { HighlightError $w } + "tcl" - "test" { + if {[winfo class $w] != "Ctext"} { return } + + foreach {app type} [tkcon attach] {break} + set cmds [::tkcon::EvalOther $app $type info commands] + + set classes [list \ + [list comment ClassForRegexp "^\\s*#\[^\n\]*" $COLOR(stderr)] \ + [list var ClassWithOnlyCharStart "\$" $COLOR(stdout)] \ + [list syntax ClassForSpecialChars "\[\]{}\"" $COLOR(prompt)] \ + [list command Class $cmds $COLOR(proc)] \ + ] + + # Remove all highlight classes from a widget + ctext::clearHighlightClasses $w + foreach class $classes { + foreach {cname ctype cptn ccol} $class break + ctext::addHighlight$ctype $w $cname $ccol $cptn + } + $w highlight 1.0 end + } + } +} + +## ::tkcon::HighlightError - magic error highlighting +## beware: voodoo included +# ARGS: +## +proc ::tkcon::HighlightError w { + variable COLOR + variable OPT + + ## do voodoo here + set app [Attach] + # we have to pull the text out, because text regexps are screwed on \n's. + set info [$w get 1.0 end-1c] + # Check for specific line error in a proc + set exp(proc) "\"(\[^\"\]+)\"\n\[\t \]+\\\(procedure \"(\[^\"\]+)\"" + # Check for too few args to a proc + set exp(param) "parameter \"(\[^\"\]+)\" to \"(\[^\"\]+)\"" + set start 1.0 + while { + [regexp -indices -- $exp(proc) $info junk what cmd] || + [regexp -indices -- $exp(param) $info junk what cmd] + } { + foreach {w0 w1} $what {c0 c1} $cmd {break} + set what [string range $info $w0 $w1] + set cmd [string range $info $c0 $c1] + if {[string match *::* $cmd]} { + set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \ + [list [namespace qualifiers $cmd] \ + [list info procs [namespace tail $cmd]]]] + } else { + set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]] + } + if {[llength $res]==1} { + set tag [UniqueTag $w] + $w tag add $tag $start+${c0}c $start+1c+${c1}c + $w tag configure $tag -foreground $COLOR(stdout) + $w tag bind $tag [list $w tag configure $tag -underline 1] + $w tag bind $tag [list $w tag configure $tag -underline 0] + $w tag bind $tag "if {!\$tk::Priv(mouseMoved)} \ + {[list $OPT(edit) -attach $app -type proc -find $what -- $cmd]}" + } + set info [string range $info $c1 end] + set start [$w index $start+${c1}c] + } + ## Next stage, check for procs that start a line + set start 1.0 + set exp(cmd) "^\"\[^\" \t\n\]+" + while { + [string compare {} [set ix \ + [$w search -regexp -count numc -- $exp(cmd) $start end]]] + } { + set start [$w index $ix+${numc}c] + # +1c to avoid the first quote + set cmd [$w get $ix+1c $start] + if {[string match *::* $cmd]} { + set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \ + [list [namespace qualifiers $cmd] \ + [list info procs [namespace tail $cmd]]]] + } else { + set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]] + } + if {[llength $res]==1} { + set tag [UniqueTag $w] + $w tag add $tag $ix+1c $start + $w tag configure $tag -foreground $COLOR(proc) + $w tag bind $tag [list $w tag configure $tag -underline 1] + $w tag bind $tag [list $w tag configure $tag -underline 0] + $w tag bind $tag "if {!\$tk::Priv(mouseMoved)} \ + {[list $OPT(edit) -attach $app -type proc -- $cmd]}" + } + } +} + +proc ::tkcon::ExpectInit {{termcap 1} {terminfo 1}} { + global env + + if {$termcap} { + set env(TERM) "tt" + set env(TERMCAP) {tt: + :ks=\E[KS: + :ke=\E[KE: + :cm=\E[%d;%dH: + :up=\E[A: + :nd=\E[C: + :cl=\E[H\E[J: + :do=^J: + :so=\E[7m: + :se=\E[m: + :k1=\EOP: + :k2=\EOQ: + :k3=\EOR: + :k4=\EOS: + :k5=\EOT: + :k6=\EOU: + :k7=\EOV: + :k8=\EOW: + :k9=\EOX: + } + } + + if {$terminfo} { + set env(TERM) "tkterm" + if {![info exists env(TEMP)]} { set env(TEMP) /tmp } + set env(TERMINFO) $env(TEMP) + + set ttsrc [file join $env(TEMP) tt.src] + set file [open $ttsrc w] + puts $file {tkterm|Don Libes' tk text widget terminal emulator, + smkx=\E[KS, + rmkx=\E[KE, + cup=\E[%p1%d;%p2%dH, + cuu1=\E[A, + cuf1=\E[C, + clear=\E[H\E[J, + ind=\n, + cr=\r, + smso=\E[7m, + rmso=\E[m, + kf1=\EOP, + kf2=\EOQ, + kf3=\EOR, + kf4=\EOS, + kf5=\EOT, + kf6=\EOU, + kf7=\EOV, + kf8=\EOW, + kf9=\EOX, + } + close $file + + if {[catch {exec tic $ttsrc} msg]} { + return -code error \ + "tic failed, you may not have terminfo support:\n$msg" + } + + file delete $ttsrc + } +} + +# term_exit is called if the spawned process exits +proc ::tkcon::term_exit {w} { + variable EXP + catch {exp_close -i $EXP(spawn_id)} + set EXP(forever) 1 + unset EXP +} + +# term_chars_changed is called after every change to the displayed chars +# You can use if you want matches to occur in the background (a la bind) +# If you want to test synchronously, then just do so - you don't need to +# redefine this procedure. +proc ::tkcon::term_chars_changed {w args} { +} + +# term_cursor_changed is called after the cursor is moved +proc ::tkcon::term_cursor_changed {w args} { +} + +proc ::tkcon::term_update_cursor {w args} { + variable OPT + variable EXP + + $w mark set insert $EXP(row).$EXP(col) + $w see insert + term_cursor_changed $w +} + +proc ::tkcon::term_clear {w args} { + $w delete 1.0 end + term_init $w +} + +proc ::tkcon::term_init {w args} { + variable OPT + variable EXP + + # initialize it with blanks to make insertions later more easily + set blankline [string repeat " " $OPT(cols)]\n + for {set i 1} {$i <= $OPT(rows)} {incr i} { + $w insert $i.0 $blankline + } + + set EXP(row) 1 + set EXP(col) 0 + + $w mark set insert $EXP(row).$EXP(col) +} + +proc ::tkcon::term_down {w args} { + variable OPT + variable EXP + + if {$EXP(row) < $OPT(rows)} { + incr EXP(row) + } else { + # already at last line of term, so scroll screen up + $w delete 1.0 2.0 + + # recreate line at end + $w insert end [string repeat " " $OPT(cols)]\n + } +} + +proc ::tkcon::term_insert {w s} { + variable OPT + variable EXP + + set chars_rem_to_write [string length $s] + set space_rem_on_line [expr {$OPT(cols) - $EXP(col)}] + + set tag_action [expr {$EXP(standout) ? "add" : "remove"}] + + ################## + # write first line + ################## + + if {$chars_rem_to_write > $space_rem_on_line} { + set chars_to_write $space_rem_on_line + set newline 1 + } else { + set chars_to_write $chars_rem_to_write + set newline 0 + } + + $w delete $EXP(row).$EXP(col) \ + $EXP(row).[expr {$EXP(col) + $chars_to_write}] + $w insert $EXP(row).$EXP(col) \ + [string range $s 0 [expr {$space_rem_on_line-1}]] + + $w tag $tag_action standout $EXP(row).$EXP(col) \ + $EXP(row).[expr {$EXP(col) + $chars_to_write}] + + # discard first line already written + incr chars_rem_to_write -$chars_to_write + set s [string range $s $chars_to_write end] + + # update EXP(col) + incr EXP(col) $chars_to_write + # update EXP(row) + if {$newline} { term_down $w } + + ################## + # write full lines + ################## + while {$chars_rem_to_write >= $OPT(cols)} { + $w delete $EXP(row).0 $EXP(row).end + $w insert $EXP(row).0 [string range $s 0 [expr {$OPT(cols)-1}]] + $w tag $tag_action standout $EXP(row).0 $EXP(row).end + + # discard line from buffer + set s [string range $s $OPT(cols) end] + incr chars_rem_to_write -$OPT(cols) + + set EXP(col) 0 + term_down $w + } + + ################# + # write last line + ################# + + if {$chars_rem_to_write} { + $w delete $EXP(row).0 $EXP(row).$chars_rem_to_write + $w insert $EXP(row).0 $s + $w tag $tag_action standout $EXP(row).0 $EXP(row).$chars_rem_to_write + set EXP(col) $chars_rem_to_write + } + + term_chars_changed $w +} + +proc ::tkcon::Expect {cmd} { + variable OPT + variable PRIV + variable EXP + + set EXP(standout) 0 + set EXP(row) 0 + set EXP(col) 0 + + set env(LINES) $OPT(rows) + set env(COLUMNS) $OPT(cols) + + ExpectInit + log_user 0 + set ::stty_init "-tabs" + uplevel \#0 [linsert $cmd 0 spawn] + set EXP(spawn_id) $::spawn_id + if {[info exists ::spawn_out(slave,name)]} { + set EXP(slave,name) $::spawn_out(slave,name) + catch {stty rows $OPT(rows) columns $OPT(cols) < $::spawn_out(slave,name)} + } + if {[string index $cmd end] == "&"} { + set cmd expect_background + } else { + set cmd expect + } + bind $PRIV(console) { + if {"%A" != ""} { + exp_send -i $::tkcon::EXP(spawn_id) "\033%A" + break + } + } + bind $PRIV(console) { + exp_send -i $::tkcon::EXP(spawn_id) -- %A + break + } + bind $PRIV(console) {exp_send -null} + set code [catch { + term_init $PRIV(console) + while {[info exists EXP(spawn_id)]} { + $cmd { + -i $::tkcon::EXP(spawn_id) + -re "^\[^\x01-\x1f\]+" { + # Text + ::tkcon::term_insert $::tkcon::PRIV(console) \ + $expect_out(0,string) + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\r" { + # (cr,) Go to beginning of line + update idle + set ::tkcon::EXP(col) 0 + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\n" { + # (ind,do) Move cursor down one line + if {$::tcl_platform(platform) eq "windows"} { + # Windows seems to get the LF without the CR + update idle + set ::tkcon::EXP(col) 0 + } + ::tkcon::term_down $::tkcon::PRIV(console) + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\b" { + # Backspace nondestructively + incr ::tkcon::EXP(col) -1 + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\a" { + bell + } "^\t" { + # Tab, shouldn't happen + send_error "got a tab!?" + } eof { + ::tkcon::term_exit $::tkcon::PRIV(console) + } "^\x1b\\\[A" { + # Cursor Up (cuu1,up) + incr ::tkcon::EXP(row) -1 + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\x1b\\\[B" { + # Cursor Down + incr ::tkcon::EXP(row) + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\x1b\\\[C" { + # Cursor Right (cuf1,nd) + incr ::tkcon::EXP(col) + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\x1b\\\[D" { + # Cursor Left + incr ::tkcon::EXP(col) + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\x1b\\\[H" { + # Cursor Home + } -re "^\x1b\\\[(\[0-9\]*);(\[0-9\]*)H" { + # (cup,cm) Move to row y col x + set ::tkcon::EXP(row) [expr {$expect_out(1,string)+1}] + set ::tkcon::EXP(col) $expect_out(2,string) + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\x1b\\\[H\x1b\\\[J" { + # (clear,cl) Clear screen + ::tkcon::term_clear $::tkcon::PRIV(console) + ::tkcon::term_update_cursor $::tkcon::PRIV(console) + } "^\x1b\\\[7m" { + # (smso,so) Begin standout mode + set ::tkcon::EXP(standout) 1 + } "^\x1b\\\[m" { + # (rmso,se) End standout mode + set ::tkcon::EXP(standout) 0 + } "^\x1b\\\[KS" { + # (smkx,ks) start keyboard-transmit mode + # terminfo invokes these when going in/out of graphics mode + # In graphics mode, we should have no scrollbars + #graphicsSet 1 + } "^\x1b\\\[KE" { + # (rmkx,ke) end keyboard-transmit mode + # Out of graphics mode, we should have scrollbars + #graphicsSet 0 + } + } + } + #vwait ::tkcon::EXP(forever) + } err] + bind $PRIV(console) {} + bind $PRIV(console) {} + bind $PRIV(console) {} + catch {unset EXP} + if {$code} { + return -code $code -errorinfo $::errorInfo $err + } +} + +## tkcon - command that allows control over the console +## This always exists in the main interpreter, and is aliased into +## other connected interpreters +# ARGS: totally variable, see internal comments +## +proc tkcon {cmd args} { + variable ::tkcon::PRIV + variable ::tkcon::OPT + global errorInfo + + switch -glob -- $cmd { + buf* { + ## 'buffer' Sets/Query the buffer size + if {[llength $args]} { + if {[regexp {^[1-9][0-9]*$} $args]} { + set OPT(buffer) $args + # catch in case the console doesn't exist yet + catch {::tkcon::ConstrainBuffer $PRIV(console) \ + $OPT(buffer)} + } else { + return -code error "buffer must be a valid integer" + } + } + return $OPT(buffer) + } + linelen* { + ## 'linelength' Sets/Query the maximum line length + if {[llength $args]} { + if {[regexp {^-?[0-9]+$} $args]} { + set OPT(maxlinelen) $args + } else { + return -code error "buffer must be a valid integer" + } + } + return $OPT(maxlinelen) + } + bg* { + ## 'bgerror' Brings up an error dialog + set errorInfo [lindex $args 1] + bgerror [lindex $args 0] + } + cl* { + ## 'close' Closes the console + ::tkcon::Destroy + } + cons* { + ## 'console' - passes the args to the text widget of the console. + set result [uplevel 1 $PRIV(console) $args] + ::tkcon::ConstrainBuffer $PRIV(console) $OPT(buffer) + return $result + } + congets { + ## 'congets' a replacement for [gets stdin] + # Use the 'gets' alias of 'tkcon_gets' command instead of + # calling the *get* methods directly for best compatability + if {[llength $args]} { + return -code error "wrong # args: must be \"tkcon congets\"" + } + tkcon show + set old [bind TkConsole <>] + bind TkConsole <> { set ::tkcon::PRIV(wait) 0 } + set w $PRIV(console) + # Make sure to move the limit to get the right data + $w mark set limit end-1c + $w mark gravity limit left + $w mark set insert end + $w see end + vwait ::tkcon::PRIV(wait) + set line [::tkcon::CmdGet $w] + $w insert end \n + bind TkConsole <> $old + return $line + } + exp* { + ::tkcon::Expect [lindex $args 0] + } + getc* { + ## 'getcommand' a replacement for [gets stdin] + ## This forces a complete command to be input though + if {[llength $args]} { + return -code error "wrong # args: must be \"tkcon getcommand\"" + } + tkcon show + set old [bind TkConsole <>] + bind TkConsole <> { set ::tkcon::PRIV(wait) 0 } + set w $PRIV(console) + # Make sure to move the limit to get the right data + $w mark set insert end + $w mark set limit insert + $w see end + vwait ::tkcon::PRIV(wait) + set line [::tkcon::CmdGet $w] + $w insert end \n + while {![info complete $line] || [regexp {[^\\]\\$} $line]} { + vwait ::tkcon::PRIV(wait) + set line [::tkcon::CmdGet $w] + $w insert end \n + $w see end + } + bind TkConsole <> $old + return $line + } + get - gets { + ## 'gets' - a replacement for [gets stdin] + ## This pops up a text widget to be used for stdin (local grabbed) + if {[llength $args]} { + return -code error "wrong # args: should be \"tkcon gets\"" + } + set t $PRIV(base).gets + if {![winfo exists $t]} { + toplevel $t + wm withdraw $t + catch {wm attributes $t -type dialog} + wm title $t "tkcon gets stdin request" + label $t.gets -text "\"gets stdin\" request:" + text $t.data -width 32 -height 5 -wrap none \ + -xscrollcommand [list $t.sx set] \ + -yscrollcommand [list $t.sy set] -borderwidth 1 + scrollbar $t.sx -orient h -takefocus 0 -highlightthickness 0 \ + -command [list $t.data xview] + scrollbar $t.sy -orient v -takefocus 0 -highlightthickness 0 \ + -command [list $t.data yview] + button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} + bind $t.ok { %W invoke } + grid $t.gets - -sticky ew + grid $t.data $t.sy -sticky news + grid $t.sx -sticky ew + grid $t.ok - -sticky ew + grid columnconfig $t 0 -weight 1 + grid rowconfig $t 1 -weight 1 + wm transient $t $PRIV(root) + wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \ + reqwidth $t]) / 2}]+[expr {([winfo \ + screenheight $t]-[winfo reqheight $t]) / 2}] + } + $t.data delete 1.0 end + wm deiconify $t + raise $t + grab $t + focus $t.data + vwait ::tkcon::PRIV(grab) + grab release $t + wm withdraw $t + return [$t.data get 1.0 end-1c] + } + err* { + ## Outputs stack caused by last error. + ## error handling with pizazz (but with pizza would be nice too) + if {[llength $args]==2} { + set app [lindex $args 0] + set type [lindex $args 1] + if {[catch {::tkcon::EvalOther $app $type set errorInfo} info]} { + set info "error getting info from $type $app:\n$info" + } + } else { + set info $PRIV(errorInfo) + } + if {[string match {} $info]} { set info "errorInfo empty" } + ## If args is empty, the -attach switch just ignores it + $OPT(edit) -attach $args -type error -- $info + } + fi* { + ## 'find' string + ::tkcon::Find $PRIV(console) $args + } + fo* { + ## 'font' ?fontname? - gets/sets the font of the console + if {[llength $args]} { + if {[info exists PRIV(console)] && \ + [winfo exists $PRIV(console)]} { + $PRIV(console) config -font $args + set OPT(font) [$PRIV(console) cget -font] + } else { + set OPT(font) $args + } + } + return $OPT(font) + } + hid* - with* { + ## 'hide' 'withdraw' - hides the console. + if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} { + wm withdraw $PRIV(root) + } + } + his* { + ## 'history' + set sub {\2} + if {[string match -new* $args]} { append sub "\n"} + set h [::tkcon::EvalSlave history] + regsub -all "( *\[0-9\]+ |\t)(\[^\n\]*\n?)" $h $sub h + return $h + } + ico* { + ## 'iconify' - iconifies the console with 'iconify'. + if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} { + wm iconify $PRIV(root) + } + } + mas* - eval { + ## 'master' - evals contents in master interpreter + uplevel \#0 $args + } + result* { + ## 'resultfilter' Sets/queries the result filter command + if {[llength $args]} { + set OPT(resultfilter) $args + } + return $OPT(resultfilter) + } + set { + ## 'set' - set (or get, or unset) simple vars (not whole arrays) + ## from the master console interpreter + ## possible formats: + ## tkcon set + ## tkcon set + ## tkcon set w + ## tkcon set u + ## tkcon set r + if {[llength $args]==5} { + ## This is for use w/ 'tkcon upvar' and only works with slaves + foreach {var i var1 var2 op} $args break + if {[string compare {} $var2]} { append var1 "($var2)" } + switch $op { + u { uplevel \#0 [list unset $var] } + w { + return [uplevel \#0 [list set $var \ + [interp eval $i [list set $var1]]]] + } + r { + return [interp eval $i [list set $var1 \ + [uplevel \#0 [list set $var]]]] + } + } + } elseif {[llength $args] == 1} { + upvar \#0 [lindex $args 0] var + if {[array exists var]} { + return [array get var] + } else { + return $var + } + } + return [uplevel \#0 set $args] + } + append { + ## Modify a var in the master environment using append + return [uplevel \#0 append $args] + } + lappend { + ## Modify a var in the master environment using lappend + return [uplevel \#0 lappend $args] + } + sh* - dei* { + ## 'show|deiconify' - deiconifies the console. + if {![info exists PRIV(root)]} { + # We are likely in some embedded console configuration. + # Make default setup reflect that. + set PRIV(showOnStartup) 0 + set PRIV(protocol) {tkcon hide} + set PRIV(root) .tkcon + set OPT(exec) "" + } + if {![winfo exists $PRIV(root)]} { + eval [linsert $args 0 ::tkcon::Init] + } + # this may throw an error if toplevel is embedded + catch {wm deiconify $PRIV(root); raise $PRIV(root)} + focus -force $PRIV(console) + } + ti* { + ## 'title' ?title? - gets/sets the console's title + if {[llength $args]} { + return [wm title $PRIV(root) [join $args]] + } else { + return [wm title $PRIV(root)] + } + } + upv* { + ## 'upvar' masterVar slaveVar + ## link slave variable slaveVar to the master variable masterVar + ## only works masters<->slave + set masterVar [lindex $args 0] + set slaveVar [lindex $args 1] + if {[info exists $masterVar]} { + interp eval $OPT(exec) \ + [list set $slaveVar [set $masterVar]] + } else { + catch {interp eval $OPT(exec) [list unset $slaveVar]} + } + interp eval $OPT(exec) \ + [list trace variable $slaveVar rwu \ + [list tkcon set $masterVar $OPT(exec)]] + return + } + v* { + return $PRIV(version) + } + default { + ## tries to determine if the command exists, otherwise throws error + set new ::tkcon::[string toupper \ + [string index $cmd 0]][string range $cmd 1 end] + if {[llength [info command $new]]} { + uplevel \#0 $new $args + } else { + return -code error "bad option \"$cmd\": must be\ + [join [lsort [list attach close console destroy \ + font hide iconify load main master new save show \ + slave deiconify version title bgerror]] {, }]" + } + } + } +} + +## +## Some procedures to make up for lack of built-in shell commands +## + +## tkcon_puts - +## This allows me to capture all stdout/stderr to the console window +## This will be renamed to 'puts' at the appropriate time during init +## +# ARGS: same as usual +# Outputs: the string with a color-coded text tag +## +proc tkcon_puts args { + set len [llength $args] + foreach {arg1 arg2 arg3} $args { break } + + if {$len == 1} { + tkcon console insert output "$arg1\n" stdout + } elseif {$len == 2} { + if {![string compare $arg1 -nonewline]} { + tkcon console insert output $arg2 stdout + } elseif {![string compare $arg1 stdout] \ + || ![string compare $arg1 stderr]} { + tkcon console insert output "$arg2\n" $arg1 + } else { + set len 0 + } + } elseif {$len == 3} { + if {![string compare $arg1 -nonewline] \ + && (![string compare $arg2 stdout] \ + || ![string compare $arg2 stderr])} { + tkcon console insert output $arg3 $arg2 + } elseif {(![string compare $arg1 stdout] \ + || ![string compare $arg1 stderr]) \ + && ![string compare $arg3 nonewline]} { + tkcon console insert output $arg2 $arg1 + } else { + set len 0 + } + } else { + set len 0 + } + + ## $len == 0 means it wasn't handled by tkcon above. + ## + if {$len == 0} { + global errorCode errorInfo + if {[catch "tkcon_tcl_puts $args" msg]} { + regsub tkcon_tcl_puts $msg puts msg + regsub -all tkcon_tcl_puts $errorInfo puts errorInfo + return -code error $msg + } + return $msg + } + + ## WARNING: This update should behave well because it uses idletasks, + ## however, if there are weird looping problems with events, or + ## hanging in waits, try commenting this out. + if {$len} { + tkcon console see output + update idletasks + } +} + +## tkcon_gets - +## This allows me to capture all stdin input without needing to stdin +## This will be renamed to 'gets' at the appropriate time during init +## +# ARGS: same as gets +# Outputs: same as gets +## +proc tkcon_gets args { + set len [llength $args] + if {$len != 1 && $len != 2} { + return -code error \ + "wrong # args: should be \"gets channelId ?varName?\"" + } + if {[string compare stdin [lindex $args 0]]} { + return [uplevel 1 tkcon_tcl_gets $args] + } + set gtype [tkcon set ::tkcon::OPT(gets)] + if {$gtype == ""} { set gtype congets } + set data [tkcon $gtype] + if {$len == 2} { + upvar 1 [lindex $args 1] var + set var $data + return [string length $data] + } + return $data +} + +## edit - opens a file/proc/var for reading/editing +## +# Arguments: +# type proc/file/var +# what the actual name of the item +# Returns: nothing +## +proc edit {args} { + variable ::tkcon::PRIV + variable ::tkcon::COLOR + variable ::tkcon::OPT + + array set opts {-find {} -type {} -attach {} -wrap {none}} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -f* { set opts(-find) [lindex $args 1] } + -a* { set opts(-attach) [lindex $args 1] } + -t* { set opts(-type) [lindex $args 1] } + -w* { set opts(-wrap) [lindex $args 1] } + -- { set args [lreplace $args 0 0]; break } + default {return -code error "unknown option \"[lindex $args 0]\""} + } + set args [lreplace $args 0 1] + } + # determine who we are dealing with + if {[llength $opts(-attach)]} { + foreach {app type} $opts(-attach) {break} + } else { + foreach {app type} [tkcon attach] {break} + } + + set word [lindex $args 0] + if {$opts(-type) == {}} { + if {[llength [::tkcon::EvalOther $app $type info commands [list $word]]]} { + set opts(-type) "proc" + } elseif {[llength [::tkcon::EvalOther $app $type info vars [list $word]]]} { + set opts(-type) "var" + } elseif {[::tkcon::EvalOther $app $type file isfile [list $word]]} { + set opts(-type) "file" + } + } + if {$opts(-type) == {}} { + return -code error "unrecognized type '$word'" + } + + # Create unique edit window toplevel + set w $PRIV(base).__edit + set i 0 + while {[winfo exists $w[incr i]]} {} + append w $i + toplevel $w + wm withdraw $w + if {[string length $word] > 20} { + wm title $w "[string range $word 0 16]... - tkcon Edit" + } else { + wm title $w "$word - tkcon Edit" + } + + if {[package provide ctext] != ""} { + set txt [ctext $w.text] + } else { + set txt [text $w.text] + } + $w.text configure -wrap $opts(-wrap) \ + -xscrollcommand [list $w.sx set] \ + -yscrollcommand [list $w.sy set] \ + -foreground $COLOR(stdin) \ + -background $COLOR(bg) \ + -insertbackground $COLOR(cursor) \ + -font $::tkcon::OPT(font) -borderwidth 1 -highlightthickness 0 \ + -undo 1 + catch { + # 8.5+ stuff + set tabsp [expr {$OPT(tabspace) * [font measure $OPT(font) 0]}] + $w.text configure -tabs [list $tabsp left] -tabstyle wordprocessor + } + + scrollbar $w.sx -orient h -command [list $w.text xview] + scrollbar $w.sy -orient v -command [list $w.text yview] + + set menu [menu $w.mbar] + $w configure -menu $menu + + ## File Menu + ## + set m [menu [::tkcon::MenuButton $menu File file]] + $m add command -label "Save As..." -underline 0 \ + -command [list ::tkcon::Save {} widget $w.text] + $m add command -label "Append To..." -underline 0 \ + -command [list ::tkcon::Save {} widget $w.text a+] + $m add separator + $m add command -label "Dismiss" -underline 0 -accel $PRIV(ACC)w \ + -command [list destroy $w] + bind $w <$PRIV(CTRL)w> [list destroy $w] + bind $w [list destroy $w] + + ## Edit Menu + ## + set text $w.text + set m [menu [::tkcon::MenuButton $menu Edit edit]] + $m add command -label "Cut" -underline 2 \ + -command [list tk_textCut $text] + $m add command -label "Copy" -underline 0 \ + -command [list tk_textCopy $text] + $m add command -label "Paste" -underline 0 \ + -command [list tk_textPaste $text] + $m add separator + $m add command -label "Find" -underline 0 \ + -command [list ::tkcon::FindBox $text] + + ## Send To Menu + ## + set m [menu [::tkcon::MenuButton $menu "Send To..." send]] + $m add command -label "Send To $app" -underline 0 \ + -command "::tkcon::EvalOther [list $app] $type \ + eval \[$w.text get 1.0 end-1c\]" + set other [tkcon attach] + if {[string compare $other [list $app $type]]} { + $m add command -label "Send To [lindex $other 0]" \ + -command "::tkcon::EvalOther $other \ + eval \[$w.text get 1.0 end-1c\]" + } + + grid $w.text - $w.sy -sticky news + grid $w.sx - -sticky ew + grid columnconfigure $w 0 -weight 1 + grid columnconfigure $w 1 -weight 1 + grid rowconfigure $w 0 -weight 1 + + switch -glob -- $opts(-type) { + proc* { + $w.text insert 1.0 \ + [::tkcon::EvalOther $app $type dump proc [list $word]] + after idle [::tkcon::Highlight $w.text tcl] + } + var* { + $w.text insert 1.0 \ + [::tkcon::EvalOther $app $type dump var [list $word]] + after idle [::tkcon::Highlight $w.text tcl] + } + file { + $w.text insert 1.0 [::tkcon::EvalOther $app $type eval \ + [subst -nocommands { + set __tkcon(fid) [open {$word} r] + set __tkcon(data) [read \$__tkcon(fid)] + close \$__tkcon(fid) + after 1000 unset __tkcon + return \$__tkcon(data) + } + ]] + after idle [::tkcon::Highlight $w.text \ + [string trimleft [file extension $word] .]] + } + error* { + $w.text insert 1.0 [join $args \n] + after idle [::tkcon::Highlight $w.text error] + } + default { + $w.text insert 1.0 [join $args \n] + } + } + # prevent stuff above being "undoable" in newer Tk + catch { $w.text edit reset ; $w.text edit modified 0 } + wm deiconify $w + focus $w.text + if {[string compare $opts(-find) {}]} { + ::tkcon::Find $w.text $opts(-find) -case 1 + } +} +interp alias {} ::more {} ::edit +interp alias {} ::less {} ::edit + +## echo +## Relaxes the one string restriction of 'puts' +# ARGS: any number of strings to output to stdout +## +proc echo args { puts stdout [concat $args] } + +## clear - clears the buffer of the console (not the history though) +## This is executed in the parent interpreter +## +proc clear {{pcnt 100}} { + if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} { + return -code error \ + "invalid percentage to clear: must be 1-100 (100 default)" + } elseif {$pcnt == 100} { + tkcon console delete 1.0 end + } else { + set tmp [expr {$pcnt/100.0*[tkcon console index end]}] + tkcon console delete 1.0 "$tmp linestart" + } +} + +## alias - akin to the csh alias command +## 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 {![llength $args]} { + interp alias {} $newcmd + } else { + eval interp alias [list {} $newcmd {}] $args + } +} + +## unalias - unaliases an alias'ed command +# ARGS: cmd - command to unbind as an alias +## +proc unalias {cmd} { + interp alias {} $cmd {} +} + +## 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 items of the specified type are found +# -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 + if {![llength $args]} { + ## If no args, assume they gave us something to dump and + ## we'll try anything + set args $type + set type any + } + while {[string match -* [lindex $args 0]]} { + 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 && ![llength $args]} { + return -code error "wrong \# args: [lindex [info level 0] 0] type\ + ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?" + } + set res {} + switch -glob -- $type { + c* { + # command + # outputs commands by figuring out, as well as possible, what it is + # this does not attempt to auto-load anything + foreach arg $args { + if {[llength [set cmds [info commands $arg]]]} { + foreach cmd [lsort $cmds] { + if {[lsearch -exact [interp aliases] $cmd] > -1} { + append res "\#\# ALIAS: $cmd =>\ + [interp alias {} $cmd]\n" + } elseif { + [llength [info procs $cmd]] || + ([string match *::* $cmd] && + [llength [namespace eval [namespace qual $cmd] \ + info procs [namespace tail $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 {![llength [set vars [uplevel 1 info vars [list $arg]]]]} { + if {[uplevel 1 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] { + if {[uplevel 1 [list info locals $var]] == ""} { + # use the proper scope of the var, but namespace which + # won't id locals or some upvar'ed vars correctly + set new [uplevel 1 \ + [list namespace which -variable $var]] + if {$new != ""} { + set var $new + } + } + upvar 1 $var v + if {[array exists v] || [catch {string length $v}]} { + set nst {} + append res "array set [list $var] \{\n" + if {[array size v]} { + foreach i \ + [lsort -dictionary [array names v $fltr]] { + upvar 0 v\($i\) __a + if {[array exists __a]} { + append nst "\#\# NESTED ARRAY ELEM: $i\n" + append nst "upvar 0 [list $var\($i\)] __a;\ + [dump v -filter $fltr __a]\n" + } else { + append res " [list $i]\t[list $v($i)]\n" + } + } + } else { + ## empty array + append res " empty array\n" + if {$var == ""} { + append nst "unset (empty)\n" + } else { + append nst "unset [list $var](empty)\n" + } + } + append res "\}\n$nst" + } else { + append res [list set $var $v]\n + } + } + } + } + p* { + # procedure + foreach arg $args { + if { + ![llength [set procs [info proc $arg]]] && + ([string match *::* $arg] && + [llength [set ps [namespace eval \ + [namespace qualifier $arg] \ + info procs [namespace tail $arg]]]]) + } { + set procs {} + set namesp [namespace qualifier $arg] + foreach p $ps { + lappend procs ${namesp}::$p + } + } + if {[llength $procs]} { + foreach p [lsort $procs] { + 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 {![llength [info command winfo]]} { + return -code error "winfo not present, cannot dump widgets" + } + if {![info exists fltr]} { set fltr .* } + foreach arg $args { + if {[llength [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 + ## Check to see that the option does + ## not match the default, then check + ## the item against the user filter + if {[string compare [lindex $c 3] \ + [lindex $c 4]] && \ + [regexp -nocase -- $fltr $c]} { + append res " \\\n\t[list [lindex $c 0]\ + [lindex $c 4]]" + } + } + append res \n + } + } + } + } elseif {$whine} { + append res "\#\# No known widget $arg\n" + set code error + } + } + } + a* { + ## see if we recognize it, other complain + if {[regexp {(var|com|proc|widget)} \ + [set types [uplevel 1 what $args]]]} { + foreach type $types { + if {[regexp {(var|com|proc|widget)} $type]} { + append res "[uplevel 1 dump $type $args]\n" + } + } + } else { + set res "dump was unable to resolve type for \"$args\"" + set code error + } + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"$type\": must be variable, command, procedure,\ + or widget" + } + } + return -code $code [string trimright $res \n] +} + +## idebug - interactive debugger +# +# 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 +# +# 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|{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|{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. +# +## +proc idebug {opt args} { + global IDEBUG + + if {![info exists IDEBUG(on)]} { + array set IDEBUG { on 0 id * debugging 0 } + } + set level [expr {[info level]-1}] + switch -glob -- $opt { + on { + # id is just arg0 [bug #50] + if {[llength $args]} { set IDEBUG(id) [lindex $args 0] } + return [set IDEBUG(on) 1] + } + off { return [set IDEBUG(on) 0] } + id { + if {![llength $args]} { + return $IDEBUG(id) + } else { return [set IDEBUG(id) [lindex $args 0]] } + } + break { + if {!$IDEBUG(on) || $IDEBUG(debugging) || \ + ([llength $args] && \ + ![string match $IDEBUG(id) $args]) || [info level]<1} { + return + } + set IDEBUG(debugging) 1 + puts stderr "idebug at level \#$level: [lindex [info level -1] 0]" + set tkcon [llength [info command tkcon]] + if {$tkcon} { + tkcon master eval set ::tkcon::OPT(prompt2) \$::tkcon::OPT(prompt1) + tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(debugPrompt) + set slave [tkcon set ::tkcon::OPT(exec)] + set event [tkcon set ::tkcon::PRIV(event)] + tkcon set ::tkcon::OPT(exec) [tkcon master interp create debugger] + tkcon set ::tkcon::PRIV(event) 1 + } + set max $level + while 1 { + set err {} + if {$tkcon} { + # tkcon's overload of gets is advanced enough to not need + # this, but we get a little better control this way. + tkcon evalSlave set level $level + tkcon prompt + set line [tkcon getcommand] + tkcon console mark set output end + } else { + puts -nonewline stderr "(level \#$level) debug > " + gets stdin line + while {![info complete $line]} { + puts -nonewline "> " + append line "\n[gets stdin]" + } + } + if {[string match {} $line]} continue + set key [regexp -inline {\S+} $line] + if {![regexp {^\s*\S+\s+([#-]?[0-9]+)} $line -> lvl]} { + set lvl \#$level + } + set res {}; set c 0 + switch -- $key { + + { + ## Allow for jumping multiple levels + if {$level < $max} { + idebug trace [incr level] $level 0 VERBOSE + } + } + - { + ## Allow for jumping multiple levels + if {$level > 1} { + idebug trace [incr level -1] $level 0 VERBOSE + } + } + . { set c [catch {idebug trace $level $level 0 VERBOSE} res] } + v { set c [catch {idebug show vars $lvl } res] } + V { set c [catch {idebug show vars $lvl VERBOSE} res] } + l { set c [catch {idebug show locals $lvl } res] } + L { set c [catch {idebug show locals $lvl VERBOSE} res] } + g { set c [catch {idebug show globals $lvl } res] } + G { set c [catch {idebug show globals $lvl VERBOSE} res] } + t { set c [catch {idebug trace 1 $max $level } res] } + T { set c [catch {idebug trace 1 $max $level VERBOSE} res]} + b { set c [catch {idebug body $lvl} res] } + o { set res [set IDEBUG(on) [expr {!$IDEBUG(on)}]] } + h - ? { + puts stderr " + Move down in call stack + - Move up in call stack + . Show current proc name and params + + v Show names of variables currently in scope + V Show names of variables currently in scope with values + l Show names of local (transient) variables + L Show names of local (transient) variables with values + g Show names of declared global variables + G Show names of declared global variables with values + t Show a stack trace + T Show a verbose stack trace + + b Show body of current proc + o Toggle on/off any further debugging + c,q Continue regular execution (Quit debugger) + h,? Print this help + default Evaluate line at current level (\#$level)" + } + c - q break + default { set c [catch {uplevel \#$level $line} res] } + } + if {$tkcon} { + tkcon set ::tkcon::PRIV(event) \ + [tkcon evalSlave eval history add [list $line]\ + \; history nextid] + } + if {$c} { + puts stderr $res + } elseif {[string compare {} $res]} { + puts $res + } + } + set IDEBUG(debugging) 0 + if {$tkcon} { + tkcon master interp delete debugger + tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(prompt2) + tkcon set ::tkcon::OPT(exec) $slave + tkcon set ::tkcon::PRIV(event) $event + tkcon prompt + } + } + bo* { + if {[regexp {^([#-]?[0-9]+)} $args level]} { + return [uplevel $level {dump c -no [lindex [info level 0] 0]}] + } + } + t* { + if {[llength $args]<2} return + set min [set max [set lvl $level]] + set exp {^#?([0-9]+)? ?#?([0-9]+) ?#?([0-9]+)? ?(VERBOSE)?} + if {![regexp $exp $args junk min max lvl verbose]} return + for {set i $max} { + $i>=$min && ![catch {uplevel \#$i info level 0} info] + } {incr i -1} { + if {$i==$lvl} { + puts -nonewline stderr "* \#$i:\t" + } else { + puts -nonewline stderr " \#$i:\t" + } + set name [lindex $info 0] + if {[string compare VERBOSE $verbose] || \ + ![llength [info procs $name]]} { + puts $info + } else { + puts "proc $name {[info args $name]} { ... }" + set idx 0 + foreach arg [info args $name] { + if {[string match args $arg]} { + puts "\t$arg = [lrange $info [incr idx] end]" + break + } else { + puts "\t$arg = [lindex $info [incr idx]]" + } + } + } + } + } + s* { + #var, local, global + set level \#$level + if {![regexp {^([vgl][^ ]*) ?([#-]?[0-9]+)? ?(VERBOSE)?} \ + $args junk type level verbose]} return + switch -glob -- $type { + v* { set vars [uplevel $level {lsort [info vars]}] } + l* { set vars [uplevel $level {lsort [info locals]}] } + g* { set vars [lremove [uplevel $level {info vars}] \ + [uplevel $level {info locals}]] } + } + if {[string match VERBOSE $verbose]} { + return [uplevel $level dump var -nocomplain $vars] + } else { + return $vars + } + } + e* - pu* { + if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} { + set id [lindex [info level 0] 0] + } else { + set id [lindex $opt 1] + } + if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} { + if {[string match e* $opt]} { + puts [concat $args] + } else { eval puts $args } + } + } + default { + return -code error "bad [lindex [info level 0] 0] option \"$opt\",\ + must be: [join [lsort [list on off id break print body\ + trace show puts echo]] {, }]" + } + } +} + +## observe - like trace, but not +# ARGS: opt - option +# name - name of variable or command +## +proc observe {opt name args} { + global tcl_observe + switch -glob -- $opt { + co* { + if {[regexp {^(catch|lreplace|set|puts|for|incr|info|uplevel)$} \ + $name]} { + return -code error "cannot observe \"$name\":\ + infinite eval loop will occur" + } + set old ${name}@ + while {[llength [info command $old]]} { append old @ } + rename $name $old + set max 4 + regexp {^[0-9]+} $args max + # handle the observe'ing of 'proc' + set proccmd "proc" + if {[string match "proc" $name]} { set proccmd $old } + ## idebug trace could be used here + $proccmd $name args " + for {set i \[info level\]; set max \[expr \[info level\]-$max\]} { + \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\] + } {incr i -1} { + puts -nonewline stderr \" \#\$i:\t\" + puts \$info + } + uplevel \[lreplace \[info level 0\] 0 0 $old\] + " + set tcl_observe($name) $old + } + cd* { + if {[info exists tcl_observe($name)] && [catch { + rename $name {} + rename $tcl_observe($name) $name + unset tcl_observe($name) + } err]} { return -code error $err } + } + ci* { + ## What a useless method... + if {[info exists tcl_observe($name)]} { + set i $tcl_observe($name) + set res "\"$name\" observes true command \"$i\"" + while {[info exists tcl_observe($i)]} { + append res "\n\"$name\" observes true command \"$i\"" + set i $tcl_observe($name) + } + return $res + } + } + va* - vd* { + set type [lindex $args 0] + set args [lrange $args 1 end] + if {![regexp {^[rwu]} $type type]} { + return -code error "bad [lindex [info level 0] 0] $opt type\ + \"$type\", must be: read, write or unset" + } + if {![llength $args]} { set args observe_var } + foreach c [uplevel 1 [list trace vinfo $name]] { + # don't double up on the traces + if {[list $type $args] == $c} { return } + } + uplevel 1 [list trace $opt $name $type $args] + } + vi* { + uplevel 1 [list trace vinfo $name] + } + default { + return -code error "bad [lindex [info level 0] 0] option\ + \"[lindex $args 0]\", must be: [join [lsort \ + [list command cdelete cinfo variable vdelete vinfo]] {, }]" + } + } +} + +## observe_var - auxilary function for observing vars, called by trace +## via observe +# ARGS: name - variable name +# el - array element name, if any +# op - operation type (rwu) +## +proc observe_var {name el op} { + if {[string match u $op]} { + if {[string compare {} $el]} { + puts "unset \"${name}($el)\"" + } else { + puts "unset \"$name\"" + } + } else { + upvar 1 $name $name + if {[info exists ${name}($el)]} { + puts [dump v ${name}($el)] + } else { + puts [dump v $name] + } + } +} + +## which - tells you where a command is found +# ARGS: cmd - command name +# Returns: where command is found (internal / external / unknown) +## +proc which cmd { + ## This tries to auto-load a command if not recognized + set types [uplevel 1 [list what $cmd 1]] + if {[llength $types]} { + set out {} + + foreach type $types { + switch -- $type { + alias { set res "$cmd: aliased to [alias $cmd]" } + procedure { set res "$cmd: procedure" } + command { set res "$cmd: internal command" } + executable { lappend out [auto_execok $cmd] } + variable { lappend out "$cmd: $type" } + } + if {[info exists res]} { + global auto_index + if {[info exists auto_index($cmd)]} { + ## This tells you where the command MIGHT have come from - + ## not true if the command was redefined interactively or + ## existed before it had to be auto_loaded. This is just + ## provided as a hint at where it MAY have come from + append res " ($auto_index($cmd))" + } + lappend out $res + unset res + } + } + return [join $out \n] + } else { + return -code error "$cmd: command not found" + } +} + +## what - tells you what a string is recognized as +# ARGS: str - string to id +# Returns: id types of command as list +## +proc what {str {autoload 0}} { + set types {} + if {[llength [info commands $str]] || ($autoload && \ + [auto_load $str] && [llength [info commands $str]])} { + if {[lsearch -exact [interp aliases] $str] > -1} { + lappend types "alias" + } elseif { + [llength [info procs $str]] || + ([string match *::* $str] && + [llength [namespace eval [namespace qualifier $str] \ + info procs [namespace tail $str]]]) + } { + lappend types "procedure" + } else { + lappend types "command" + } + } + if {[llength [uplevel 1 info vars $str]]} { + upvar 1 $str var + if {[array exists var]} { + lappend types array variable + } else { + lappend types scalar variable + } + } + if {[file isdirectory $str]} { + lappend types "directory" + } + if {[file isfile $str]} { + lappend types "file" + } + if {[llength [info commands winfo]] && [winfo exists $str]} { + lappend types "widget" + } + if {[string compare {} [auto_execok $str]]} { + lappend types "executable" + } + return $types +} + +## 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 {![llength $args]} { set args [list [pwd]] } + if {$::tcl_version >= 8.3} { + # Newer glob args allow safer dir processing. The user may still + # want glob chars, but really only for file matching. + foreach arg $args { + if {[file isdirectory $arg]} { + if {$s(all)} { + lappend out [list $arg [lsort \ + [glob -nocomplain -directory $arg .* *]]] + } else { + lappend out [list $arg [lsort \ + [glob -nocomplain -directory $arg *]]] + } + } else { + set dir [file dirname $arg] + lappend out [list $dir$sep [lsort \ + [glob -nocomplain -directory $dir [file tail $arg]]]] + } + } + } else { + foreach arg $args { + if {[file isdirectory $arg]} { + set arg [string trimright $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%9ld %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 %03o [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 80 + ## This gets the number of cols in the tkcon console widget + if {[llength [info commands tkcon]]} { + set j [expr {[tkcon master set ::tkcon::OPT(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 {$j == 0 || [incr k]%$j == 0} { + set res [string trimright $res]\n + } + } + append res \n\n + } + } + return [string trimright $res] +} +interp alias {} ::ls {} ::dir -full + +## lremove - remove items from a list +# OPTS: +# -all remove all instances of each item +# -glob remove all instances matching glob pattern +# -regexp remove all instances matching regexp pattern +# ARGS: l a list to remove items from +# args items to remove (these are 'join'ed together) +## +proc lremove {args} { + array set opts {-all 0 pattern -exact} + while {[string match -* [lindex $args 0]]} { + switch -glob -- [lindex $args 0] { + -a* { set opts(-all) 1 } + -g* { set opts(pattern) -glob } + -r* { set opts(pattern) -regexp } + -- { set args [lreplace $args 0 0]; break } + default {return -code error "unknown option \"[lindex $args 0]\""} + } + set args [lreplace $args 0 0] + } + set l [lindex $args 0] + foreach i [join [lreplace $args 0 0]] { + if {[set ix [lsearch $opts(pattern) $l $i]] == -1} continue + set l [lreplace $l $ix $ix] + if {$opts(-all)} { + while {[set ix [lsearch $opts(pattern) $l $i]] != -1} { + set l [lreplace $l $ix $ix] + } + } + } + return $l +} + +if {!$::tkcon::PRIV(WWW)} {; + +## Unknown changed to get output into tkcon window +# unknown: +# Invoked automatically whenever an unknown command is encountered. +# Works through a list of "unknown handlers" that have been registered +# to deal with unknown commands. Extensions can integrate their own +# handlers into the 'unknown' facility via 'unknown_handler'. +# +# 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 1 $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 + global errorCode errorInfo + + # If the command word has the form "namespace inscope ns cmd" + # then concatenate its arguments onto the end and evaluate it. + + set cmd [lindex $args 0] + if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] \ + && [llength $cmd] == 4} { + set arglist [lrange $args 1 end] + set ret [catch {uplevel 1 $cmd $arglist} result] + if {$ret == 0} { + return $result + } else { + return -code $ret -errorcode $errorCode $result + } + } + + # 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)]} { + return -code error "self-referential recursion in \"unknown\" for command \"$name\"" + } + set unknown_pending($name) pending + if {[llength [info args auto_load]]==1} { + set ret [catch {auto_load $name} msg] + } else { + set ret [catch {auto_load $name [uplevel 1 {namespace current}]} 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 1 $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 {[string compare {} $new]} { + set errorCode $savedErrorCode + set errorInfo $savedErrorInfo + if {[info exists ::tkcon::EXPECT] && $::tkcon::EXPECT && [package provide Expect] != ""} { + return [tkcon expect [concat $new [lrange $args 1 end]]] + } else { + return [uplevel 1 exec $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 ::tkcon::EvalCmd + ## + if {[string compare $name "::"] == 0} { + set name "" + } + if {$ret != 0} { + return -code $ret -errorcode $errorCode \ + "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg" + } + set cmds [info commands $name*] + if {[llength $cmds] == 1} { + return [uplevel 1 [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]" + } + } + ## We've got nothing so far + ## Check and see if Tk wasn't loaded, but it appears to be a Tk cmd + if {![uplevel \#0 info exists tk_version]} { + lappend tkcmds bell bind bindtags button \ + canvas checkbutton clipboard destroy \ + entry event focus font frame grab grid image \ + label labelframe listbox lower menu menubutton message \ + option pack panedwindow place radiobutton raise \ + scale scrollbar selection send spinbox \ + text tk tkwait toplevel winfo wm + if {[lsearch -exact $tkcmds $name] >= 0 && \ + [tkcon master tk_messageBox -icon question -parent . \ + -title "Load Tk?" -type retrycancel -default retry \ + -message "This appears to be a Tk command, but Tk\ + has not yet been loaded. Shall I retry the command\ + with loading Tk first?"] == "retry"} { + return [uplevel 1 "load {} Tk; $args"] + } + } + } + return -code continue +} + +} ; # end exclusionary code for WWW + +proc ::tkcon::Bindings {} { + variable PRIV + global tcl_platform tk_version + + #----------------------------------------------------------------------- + # Elements of tk::Priv that are used in this file: + # + # mouseMoved - Non-zero means the mouse has moved a significant + # amount since the button went down (so, for example, + # start dragging out a selection). + #----------------------------------------------------------------------- + + ## Get all Text bindings into TkConsole + foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] } + ## We really didn't want the newline insertion + bind TkConsole {} + + ## in 8.6b3, the virtual events <> and <> + # mess up our history feature + bind TkConsole <> {} + bind TkConsole <> {} + + ## Now make all our virtual event bindings + set bindings { + <> <$PRIV(CTRL)-q> + <> <$PRIV(CTRL)-N> + <> <$PRIV(CTRL)-T> + <> + <> + <> <$PRIV(CTRL)-w> + <> <$PRIV(CTRL)-A> + <> <$PRIV(CTRL)F> + <> <$PRIV(CTRL)Key-1> + <> <$PRIV(CTRL)Key-2> + <> <$PRIV(CTRL)Key-3> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + <> + } + if {$PRIV(AQUA)} { + lappend bindings <> \ + <> + } else { + lappend bindings <> + } + foreach {ev key} [subst -nocommand -noback $bindings] { + event add $ev $key + ## Make sure the specific key won't be defined + bind TkConsole $key {} + } + + ## Make the ROOT bindings + bind $PRIV(root) <> exit + bind $PRIV(root) <> { ::tkcon::New } + bind $PRIV(root) <> { ::tkcon::NewTab } + bind $PRIV(root) <> { ::tkcon::GotoTab 1 ; break } + bind $PRIV(root) <> { ::tkcon::GotoTab -1 ; break } + bind $PRIV(root) <> { ::tkcon::Destroy } + bind $PRIV(root) <> { ::tkcon::About } + bind $PRIV(root) <> { ::tkcon::FindBox $::tkcon::PRIV(console) } + bind $PRIV(root) <> { + ::tkcon::Attach {} + ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] + } + bind $PRIV(root) <> { + if {[string compare {} $::tkcon::PRIV(name)]} { + ::tkcon::Attach $::tkcon::PRIV(name) + } else { + ::tkcon::Attach Main + } + ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] + } + bind $PRIV(root) <> { + ::tkcon::Attach Main + ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)] + } + bind $PRIV(root) <> { + ::tkcon::PopupMenu %X %Y + } + + ## Menu items need null TkConsolePost bindings to avoid the TagProc + ## + foreach ev [bind $PRIV(root)] { + bind TkConsolePost $ev { + # empty + } + } + + + # ::tkcon::ClipboardKeysyms -- + # 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 ::tkcon::ClipboardKeysyms {copy cut paste} { + bind TkConsole <$copy> {::tkcon::Copy %W} + bind TkConsole <$cut> {::tkcon::Cut %W} + bind TkConsole <$paste> {::tkcon::Paste %W} + } + + proc ::tkcon::GetSelection {w} { + if { + ![catch {selection get -displayof $w -type UTF8_STRING} txt] || + ![catch {selection get -displayof $w} txt] || + ![catch {selection get -displayof $w -selection CLIPBOARD} txt] + } { + return $txt + } + return -code error "could not find default selection" + } + + proc ::tkcon::Cut w { + if {[string match $w [selection own -displayof $w]]} { + clipboard clear -displayof $w + catch { + set txt [selection get -displayof $w] + clipboard append -displayof $w $txt + if {[$w compare sel.first >= limit]} { + $w delete sel.first sel.last + } + } + } + } + proc ::tkcon::Copy w { + if {[string match $w [selection own -displayof $w]]} { + clipboard clear -displayof $w + catch { + set txt [selection get -displayof $w] + clipboard append -displayof $w $txt + } + } + } + proc ::tkcon::Paste w { + if {![catch {GetSelection $w} txt]} { + catch { + if {[$w compare sel.first >= limit]} { + $w delete sel.first sel.last + } + } + if {[$w compare insert < limit]} { $w mark set insert end } + $w insert insert $txt + $w see insert + if {[string match *\n* $txt]} { ::tkcon::Eval $w } + } + } + + ## Redefine for TkConsole what we need + ## + event delete <> <$PRIV(CTRL)V> + ::tkcon::ClipboardKeysyms + + bind TkConsole { + catch { ::tkcon::Insert %W [::tkcon::GetSelection %W] } + } + + bind TkConsole {+ + catch { + eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last] + eval %W tag remove sel sel.last-1c + %W mark set insert sel.first + } + } + + ## binding editor needed + ## binding for .tkconrc + + bind TkConsole <> { + if {[%W compare insert > limit]} {::tkcon::Expand %W path} + break ; # could check "%K" == "Tab" + } + bind TkConsole <> { + if {[%W compare insert > limit]} {::tkcon::Expand %W proc} + break ; # could check "%K" == "Tab" + } + bind TkConsole <> { + if {[%W compare insert > limit]} {::tkcon::Expand %W var} + break ; # could check "%K" == "Tab" + } + bind TkConsole <> { + if {[%W compare insert > limit]} {::tkcon::Expand %W} + break ; # could check "%K" == "Tab" + } + bind TkConsole <> { + if {[%W compare insert >= limit]} { + ::tkcon::Insert %W \t + } + } + bind TkConsole <> { + if {[%W compare insert >= limit]} { + ::tkcon::Insert %W \n + } + } + bind TkConsole <> { + ::tkcon::Eval %W + } + bind TkConsole { + if {[llength [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert >= limit]} { + %W delete insert + %W see insert + } + } + bind TkConsole { + if {[llength [%W tag nextrange sel 1.0 end]] \ + && [%W compare sel.first >= limit]} { + %W delete sel.first sel.last + } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} { + %W delete insert-1c + %W see insert + } + } + bind TkConsole [bind TkConsole ] + + bind TkConsole { + ::tkcon::Insert %W %A + } + + bind TkConsole { + if {[%W compare {limit linestart} == {insert linestart}]} { + tk::TextSetCursor %W limit + } else { + tk::TextSetCursor %W {insert linestart} + } + } + bind TkConsole [bind TkConsole ] + bind TkConsole { + if {[%W compare insert < limit]} break + %W delete insert + } + bind TkConsole { + if {[%W compare insert < limit]} break + if {[%W compare insert == {insert lineend}]} { + %W delete insert + } else { + %W delete insert {insert lineend} + } + } + bind TkConsole <> { + ## Clear console buffer, without losing current command line input + set ::tkcon::PRIV(tmp) [::tkcon::CmdGet %W] + clear + ::tkcon::Prompt {} $::tkcon::PRIV(tmp) + } + bind TkConsole <> { + if {[%W compare {insert linestart} != {limit linestart}]} { + tk::TextSetCursor %W [tk::TextUpDownLine %W -1] + } else { + ::tkcon::Event -1 + } + } + bind TkConsole <> { + if {[%W compare {insert linestart} != {end-1c linestart}]} { + tk::TextSetCursor %W [tk::TextUpDownLine %W 1] + } else { + ::tkcon::Event 1 + } + } + bind TkConsole <> { ::tkcon::Event 1 } + bind TkConsole <> { ::tkcon::Event -1 } + bind TkConsole <> { + ::tkcon::Event -1 [::tkcon::CmdGet %W] + } + bind TkConsole <> { + ::tkcon::Event 1 [::tkcon::CmdGet %W] + } + bind TkConsole <> { + ## Transpose current and previous chars + if {[%W compare insert > "limit+1c"]} { tk::TextTranspose %W } + } + bind TkConsole <> { + ## Clear command line (Unix shell staple) + %W delete limit end + } + bind TkConsole <> { + ## Save command buffer (swaps with current command) + set ::tkcon::PRIV(tmp) $::tkcon::PRIV(cmdsave) + set ::tkcon::PRIV(cmdsave) [::tkcon::CmdGet %W] + if {[string match {} $::tkcon::PRIV(cmdsave)]} { + set ::tkcon::PRIV(cmdsave) $::tkcon::PRIV(tmp) + } else { + %W delete limit end-1c + } + ::tkcon::Insert %W $::tkcon::PRIV(tmp) + %W see end + } + catch {bind TkConsole { tk::TextScrollPages %W -1 }} + catch {bind TkConsole { tk::TextScrollPages %W -1 }} + catch {bind TkConsole { tk::TextScrollPages %W 1 }} + catch {bind TkConsole { tk::TextScrollPages %W 1 }} + bind TkConsole { + if {[%W compare insert >= limit]} { + %W delete insert {insert wordend} + } + } + bind TkConsole { + if {[%W compare {insert -1c wordstart} >= limit]} { + %W delete {insert -1c wordstart} insert + } + } + bind TkConsole { + if {[%W compare insert >= limit]} { + %W delete insert {insert wordend} + } + } + bind TkConsole { + if { + (!$tk::Priv(mouseMoved) || $tk_strictMotif) && + ![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)] + } { + if {[%W compare @%x,%y < limit]} { + %W insert end $::tkcon::PRIV(tmp) + } else { + %W insert @%x,%y $::tkcon::PRIV(tmp) + } + if {[string match *\n* $::tkcon::PRIV(tmp)]} {::tkcon::Eval %W} + } + } + + ## + ## End TkConsole bindings + ## + + ## + ## Bindings for doing special things based on certain keys + ## + bind TkConsolePost { + if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ + [string compare \\ [%W get insert-2c]]} { + ::tkcon::MatchPair %W \( \) limit + } + set ::tkcon::PRIV(StatusCursor) [%W index insert] + } + bind TkConsolePost { + if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ + [string compare \\ [%W get insert-2c]]} { + ::tkcon::MatchPair %W \[ \] limit + } + set ::tkcon::PRIV(StatusCursor) [%W index insert] + } + bind TkConsolePost { + if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ + [string compare \\ [%W get insert-2c]]} { + ::tkcon::MatchPair %W \{ \} limit + } + set ::tkcon::PRIV(StatusCursor) [%W index insert] + } + bind TkConsolePost { + if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \ + [string compare \\ [%W get insert-2c]]} { + ::tkcon::MatchQuote %W limit + } + set ::tkcon::PRIV(StatusCursor) [%W index insert] + } + + bind TkConsolePost { + if {[winfo exists "%W"]} { + if {$::tkcon::OPT(lightcmd) && [string compare {} %A]} { + ::tkcon::TagProc %W + } + set ::tkcon::PRIV(StatusCursor) [%W index insert] + } + } + + bind TkConsolePost { + set ::tkcon::PRIV(StatusCursor) [%W index insert] + } + bind TkConsolePost { + set ::tkcon::PRIV(StatusCursor) [%W index insert] + } + +} + +## +# ::tkcon::PopupMenu - what to do when the popup menu is requested +## +proc ::tkcon::PopupMenu {X Y} { + variable PRIV + variable OPT + + set w $PRIV(console) + if {[string compare $w [winfo containing $X $Y]]} { + tk_popup $PRIV(popup) $X $Y + return + } + set x [expr {$X-[winfo rootx $w]}] + set y [expr {$Y-[winfo rooty $w]}] + if {[llength [set tags [$w tag names @$x,$y]]]} { + if {[lsearch -exact $tags "proc"] >= 0} { + lappend type "proc" + foreach {first last} [$w tag prevrange proc @$x,$y] { + set word [$w get $first $last]; break + } + } + if {[lsearch -exact $tags "var"] >= 0} { + lappend type "var" + foreach {first last} [$w tag prevrange var @$x,$y] { + set word [$w get $first $last]; break + } + } + } + if {![info exists type]} { + set exp "(^|\[^\\\\\]\[ \t\n\r\])" + set exp2 "\[\[\\\\\\?\\*\]" + set i [$w search -backwards -regexp $exp @$x,$y "@$x,$y linestart"] + if {[string compare {} $i]} { + if {![string match *.0 $i]} {append i +2c} + if {[string compare {} \ + [set j [$w search -regexp $exp $i "$i lineend"]]]} { + append j +1c + } else { + set j "$i lineend" + } + regsub -all $exp2 [$w get $i $j] {\\\0} word + set word [string trim $word {\"$[]{}',?#*}] + if {[llength [EvalAttached [list info commands $word]]]} { + lappend type "proc" + } + if {[llength [EvalAttached [list info vars $word]]]} { + lappend type "var" + } + if {[EvalAttached [list file isfile $word]]} { + lappend type "file" + } + } + } + if {![info exists type] || ![info exists word]} { + tk_popup $PRIV(popup) $X $Y + return + } + $PRIV(context) delete 0 end + $PRIV(context) add command -label "$word" -state disabled + $PRIV(context) add separator + set app [Attach] + if {[lsearch $type proc] != -1} { + $PRIV(context) add command -label "View Procedure" \ + -command [list $OPT(edit) -attach $app -type proc -- $word] + } + if {[lsearch $type var] != -1} { + $PRIV(context) add command -label "View Variable" \ + -command [list $OPT(edit) -attach $app -type var -- $word] + } + if {[lsearch $type file] != -1} { + $PRIV(context) add command -label "View File" \ + -command [list $OPT(edit) -attach $app -type file -- $word] + } + tk_popup $PRIV(context) $X $Y +} + +## ::tkcon::TagProc - tags a procedure in the console if it's recognized +## This procedure is not perfect. However, making it perfect wastes +## too much CPU time... +## +proc ::tkcon::TagProc w { + set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]" + set i [$w search -backwards -regexp $exp insert-1c limit-1c] + if {[string compare {} $i]} {append i +2c} else {set i limit} + regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c + if {[llength [EvalAttached [list info commands $c]]]} { + $w tag add proc $i "insert-1c wordend" + } else { + $w tag remove proc $i "insert-1c wordend" + } + if {[llength [EvalAttached [list info vars $c]]]} { + $w tag add var $i "insert-1c wordend" + } else { + $w tag remove var $i "insert-1c wordend" + } +} + +## ::tkcon::MatchPair - 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: ::tkcon::Blink +## +proc ::tkcon::MatchPair {w c1 c2 {lim 1.0}} { + if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} { + while { + [string match {\\} [$w get $ix-1c]] && + [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]] + } {} + set i1 insert-1c + while {[string compare {} $ix]} { + set i0 $ix + set j 0 + while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} { + append i0 +1c + if {[string match {\\} [$w get $i0-2c]]} continue + incr j + } + if {!$j} break + set i1 $ix + while {$j && [string compare {} \ + [set ix [$w search -back $c1 $ix $lim]]]} { + if {[string match {\\} [$w get $ix-1c]]} continue + incr j -1 + } + } + if {[string match {} $ix]} { set ix [$w index $lim] } + } else { set ix [$w index $lim] } + if {$::tkcon::OPT(blinkrange)} { + Blink $w $ix [$w index insert] + } else { + Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert] + } +} + +## ::tkcon::MatchQuote - 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: ::tkcon::Blink +## +proc ::tkcon::MatchQuote {w {lim 1.0}} { + set i insert-1c + set j 0 + while {[string compare [set i [$w search -back \" $i $lim]] {}]} { + if {[string match {\\} [$w get $i-1c]]} continue + if {!$j} {set i0 $i} + incr j + } + if {$j&1} { + if {$::tkcon::OPT(blinkrange)} { + Blink $w $i0 [$w index insert] + } else { + Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert] + } + } else { + Blink $w [$w index insert-1c] [$w index insert] + } +} + +## ::tkcon::Blink - blinks between n index pairs for a specified duration. +# ARGS: w - console text widget +# i1 - start index to blink region +# i2 - end index of blink region +# dur - duration in usecs to blink for +# Outputs: blinks selected characters in $w +## +proc ::tkcon::Blink {w args} { + eval [list $w tag add blink] $args + after $::tkcon::OPT(blinktime) [list $w] tag remove blink $args + return +} + + +## ::tkcon::Insert +## 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 ::tkcon::Insert {w s} { + if {[string match {} $s] || [string match disabled [$w cget -state]]} { + return + } + variable EXP + if {[info exists EXP(spawn_id)]} { + exp_send -i $EXP(spawn_id) -- $s + return + } + if {[$w comp insert < limit]} { + $w mark set insert end + } + if {[llength [$w tag ranges sel]] && \ + [$w comp sel.first <= insert] && [$w comp sel.last >= insert]} { + $w delete sel.first sel.last + } + $w insert insert $s + $w see insert +} + +## ::tkcon::Expand - +# ARGS: w - text widget in which to expand str +# type - type of expansion (path / proc / variable) +# Calls: ::tkcon::Expand(Pathname|Procname|Variable) +# Outputs: The string to match is expanded to the longest possible match. +# If ::tkcon::OPT(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 ::tkcon::Expand {w {type ""}} { + set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"$\]" + set tmp [$w search -backwards -regexp $exp insert-1c limit-1c] + if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit} + set str [$w get $tmp insert] + # Expand procs can return "break" to indicate not to try further + # matches, otherwise "continue" says "I got nothing, continue on" + # We can ignore return codes from the specific expand type checks + switch -glob $type { + pa* { set code [catch {ExpandPathname $str} res] } + pr* { set code [catch {ExpandProcname $str} res] } + v* { set code [catch {ExpandVariable $str} res] } + default { + # XXX could be extended to allow the results of all matches + # XXX to be amalgamted ... may be confusing to user + set res {} + foreach t $::tkcon::OPT(expandorder) { + set code [catch {Expand$t $str} res] + if {$code == 0 || $code == 3} { break } + set res {} + } + } + } + set len [llength $res] + if {$len} { + $w delete $tmp insert + $w insert $tmp [lindex $res 0] + if {$len > 1} { + if {$::tkcon::OPT(showmultiple) && \ + ![string compare [lindex $res 0] $str]} { + puts stdout [lsort [lreplace $res 0 0]] + } + } + } else { bell } + return [incr len -1] +} + +## ::tkcon::ExpandPathname - expand a file pathname based on $str +## This is based on UNIX file name conventions +# ARGS: str - partial file pathname to expand +# Calls: ::tkcon::ExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc ::tkcon::ExpandPathname str { + + # require at least a single character, otherwise continue + if {$str eq ""} {return -code continue} + + set pwd [EvalAttached pwd] + # Cause a string like {C:/Program\ Files/} to become "C:/Program Files/" + regsub -all {\\([][ ])} $str {\1} str + if {[catch {EvalAttached [list cd [file dirname $str]]} err]} { + return -code error $err + } + set dir [file tail $str] + ## Check to see if it was known to be a directory and keep the trailing + ## slash if so (file tail cuts it off) + if {[string match */ $str]} { append dir / } + # Create a safely glob-able name + regsub -all {([][])} $dir {\\\1} safedir + if {[catch {lsort [EvalAttached [list glob $safedir*]]} m]} { + set match {} + } else { + if {[llength $m] > 1} { + global tcl_platform + if {[string match windows $tcl_platform(platform)]} { + ## Windows is screwy because it's case insensitive + set tmp [ExpandBestMatch [string tolower $m] \ + [string tolower $dir]] + ## Don't change case if we haven't changed the word + if {[string length $dir]==[string length $tmp]} { + set tmp $dir + } + } else { + set tmp [ExpandBestMatch $m $dir] + } + if {[string match */* $str]} { + set tmp [string trimright [file dirname $str] /]/$tmp + } + regsub -all {([^\\])([][ ])} $tmp {\1\\\2} 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 isdirectory $match]} {append match /} + if {[string match */* $str]} { + set match [string trimright [file dirname $str] /]/$match + } + regsub -all {([^\\])([][ ])} $match {\1\\\2} match + ## Why is this one needed and the ones below aren't!! + set match [list $match] + } + } + EvalAttached [list cd $pwd] + return -code [expr {$match eq "" ? "continue" : "break"}] $match +} + +## ::tkcon::ExpandProcname - expand a tcl proc name based on $str +# ARGS: str - partial proc name to expand +# Calls: ::tkcon::ExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc ::tkcon::ExpandProcname str { + + # require at least a single character, otherwise continue + if {$str eq ""} {return -code continue} + + set match [EvalAttached [list info commands $str*]] + if {[llength $match] == 0} { + set ns [EvalAttached \ + "namespace children \[namespace current\] [list $str*]"] + if {[llength $ns]==1} { + set match [EvalAttached [list info commands ${ns}::*]] + } else { + set match $ns + } + } + if {[llength $match] > 1} { + regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all {([^\\]) } $match {\1\\ } match + } + return -code [expr {$match eq "" ? "continue" : "break"}] $match +} + +## ::tkcon::ExpandMethodname - expand an NSF/XOTcl method name based on $str +# ARGS: str - partial proc name to expand +# Calls: ::tkcon::ExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc ::tkcon::ExpandMethodname str { + + # In a first step, obtain the typed-in cmd from the console + set typedCmd [::tkcon::CmdGet $::tkcon::PRIV(console)] + set obj [lindex $typedCmd 0] + if {$obj eq $typedCmd} { + # just a single word, can't be a method expansion + return -code continue + } + # Get the full string after the object + set sub [string trimleft [string range $typedCmd [string length [list $obj]] end]] + if {[EvalAttached [list info exists ::nsf::version]]} { + # Next Scripting Framework is loaded + if {![EvalAttached [list ::nsf::object::exists $obj]]} {return -code continue} + if {[string match ::* $sub]} { + # NSF allows dispatch of unregistered methods via absolute + # paths + set cmd "concat \[info commands $sub*\] \[namespace children \[namespace qualifiers $sub\] $sub*\]" + } else { + set cmd [list $obj ::nsf::methods::object::info::lookupmethods -callprotection public -path -- $sub*] + } + } elseif {[EvalAttached [list info exists ::xotcl::version]]} { + # XOTcl < 2.* is loaded + if {![EvalAttached [list ::xotcl::Object isobject $obj]]} {return -code continue} + set cmd [list $obj info methods $sub*] + } else { + # No NSF/XOTcl loaded + return -code continue + } + + set match [EvalAttached $cmd] + if {[llength $match] > 1} { + regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } bestMatch + if {$str eq "" && [string match "* " $bestMatch]} { + set match [linsert $match 0 ""] + } else { + regsub -all {\\ } $bestMatch { } bestMatch + set match [linsert $match 0 [lindex $bestMatch end]] + } + } else { + set match [lindex [lindex $match 0] end] + } + return -code break $match +} + +## ::tkcon::ExpandVariable - expand a tcl variable name based on $str +# ARGS: str - partial tcl var name to expand +# Calls: ::tkcon::ExpandBestMatch +# Returns: list containing longest unique match followed by all the +# possible further matches +## +proc ::tkcon::ExpandVariable str { + + # require at least a single character, otherwise continue + if {$str eq ""} {return -code continue} + + if {[regexp {([^\(]*)\((.*)} $str junk ary str]} { + ## Looks like they're trying to expand an array. + set match [EvalAttached [list array names $ary $str*]] + if {[llength $match] > 1} { + set vars $ary\([ExpandBestMatch $match $str] + foreach var $match {lappend vars $ary\($var\)} + return $vars + } elseif {[llength $match] == 1} { + set match $ary\($match\) + } + ## Space transformation avoided for array names. + } else { + set match [EvalAttached [list info vars $str*]] + if {[llength $match] > 1} { + regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str + set match [linsert $match 0 $str] + } else { + regsub -all {([^\\]) } $match {\1\\ } match + } + } + return -code [expr {$match eq "" ? "continue" : "break"}] $match +} + +## ::tkcon::ExpandBestMatch2 - 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 ::tkcon::ExpandBestMatch2 {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 +} + +## ::tkcon::ExpandBestMatch - 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 ::tkcon::ExpandBestMatch {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 +} + +# Here is a group of functions that is only used when Tkcon is +# executed in a safe interpreter. It provides safe versions of +# missing functions. For example: +# +# - "tk appname" returns "tkcon.tcl" but cannot be set +# - "toplevel" is equivalent to 'frame', only it is automatically +# packed. +# - The 'source', 'load', 'open', 'file' and 'exit' functions are +# mapped to corresponding functions in the parent interpreter. +# +# Further on, Tk cannot be really loaded. Still the safe 'load' +# provedes a speciall case. The Tk can be divided into 4 groups, +# that each has a safe handling procedure. +# +# - "::tkcon::SafeItem" handles commands like 'button', 'canvas' ...... +# Each of these functions has the window name as first argument. +# - "::tkcon::SafeManage" handles commands like 'pack', 'place', 'grid', +# 'winfo', which can have multiple window names as arguments. +# - "::tkcon::SafeWindow" handles all windows, such as '.'. For every +# window created, a new alias is formed which also is handled by +# this function. +# - Other (e.g. bind, bindtag, image), which need their own function. +# +## These functions courtesy Jan Nijtmans +## +if {![llength [info commands tk]]} { + proc tk {option args} { + if {![string match app* $option]} { + error "wrong option \"$option\": should be appname" + } + return "tkcon.tcl" + } +} + +if {![llength [info command toplevel]]} { + proc toplevel {name args} { + eval [linsert $args 0 frame $name] + grid $name -sticky news + } +} + +proc ::tkcon::SafeSource {i f} { + set fd [open $f r] + set r [read $fd] + close $fd + if {[catch {interp eval $i $r} msg]} { + error $msg + } +} + +proc ::tkcon::SafeOpen {i f {m r}} { + set fd [open $f $m] + interp transfer {} $fd $i + return $fd +} + +proc ::tkcon::SafeLoad {i f p} { + global tk_version tk_patchLevel tk_library auto_path + if {[string compare $p Tk]} { + load $f $p $i + } else { + foreach command {button canvas checkbutton entry frame label + listbox message radiobutton scale scrollbar spinbox text toplevel} { + $i alias $command ::tkcon::SafeItem $i $command + } + $i alias image ::tkcon::SafeImage $i + foreach command {pack place grid destroy winfo} { + $i alias $command ::tkcon::SafeManage $i $command + } + if {[llength [info command event]]} { + $i alias event ::tkcon::SafeManage $i $command + } + frame .${i}_dot -width 300 -height 300 -relief raised + pack .${i}_dot -side left + $i alias tk tk + $i alias bind ::tkcon::SafeBind $i + $i alias bindtags ::tkcon::SafeBindtags $i + $i alias . ::tkcon::SafeWindow $i {} + foreach var {tk_version tk_patchLevel tk_library auto_path} { + $i eval [list set $var [set $var]] + } + $i eval { + package provide Tk $tk_version + if {[lsearch -exact $auto_path $tk_library] < 0} { + lappend auto_path $tk_library + } + } + return "" + } +} + +proc ::tkcon::SafeSubst {i a} { + set arg1 "" + foreach {arg value} $a { + if {![string compare $arg -textvariable] || + ![string compare $arg -variable]} { + set newvalue "[list $i] $value" + global $newvalue + if {[interp eval $i info exists $value]} { + set $newvalue [interp eval $i set $value] + } else { + catch {unset $newvalue} + } + $i eval trace variable $value rwu \{[list tkcon set $newvalue $i]\} + set value $newvalue + } elseif {![string compare $arg -command]} { + set value [list $i eval $value] + } + lappend arg1 $arg $value + } + return $arg1 +} + +proc ::tkcon::SafeItem {i command w args} { + set args [::tkcon::SafeSubst $i $args] + set code [catch "$command [list .${i}_dot$w] $args" msg] + $i alias $w ::tkcon::SafeWindow $i $w + regsub -all .${i}_dot $msg {} msg + return -code $code $msg +} + +proc ::tkcon::SafeManage {i command args} { + set args1 "" + foreach arg $args { + if {[string match . $arg]} { + set arg .${i}_dot + } elseif {[string match .* $arg]} { + set arg ".${i}_dot$arg" + } + lappend args1 $arg + } + set code [catch "$command $args1" msg] + regsub -all .${i}_dot $msg {} msg + return -code $code $msg +} + +# +# FIX: this function doesn't work yet if the binding starts with '+'. +# +proc ::tkcon::SafeBind {i w args} { + if {[string match . $w]} { + set w .${i}_dot + } elseif {[string match .* $w]} { + set w ".${i}_dot$w" + } + if {[llength $args] > 1} { + set args [list [lindex $args 0] \ + "[list $i] eval [list [lindex $args 1]]"] + } + set code [catch "bind $w $args" msg] + if {[llength $args] <2 && $code == 0} { + set msg [lindex $msg 3] + } + return -code $code $msg +} + +proc ::tkcon::SafeImage {i option args} { + set code [catch "image $option $args" msg] + if {[string match cr* $option]} { + $i alias $msg $msg + } + return -code $code $msg +} + +proc ::tkcon::SafeBindtags {i w {tags {}}} { + if {[string match . $w]} { + set w .${i}_dot + } elseif {[string match .* $w]} { + set w ".${i}_dot$w" + } + set newtags {} + foreach tag $tags { + if {[string match . $tag]} { + lappend newtags .${i}_dot + } elseif {[string match .* $tag]} { + lappend newtags ".${i}_dot$tag" + } else { + lappend newtags $tag + } + } + if {[string match $tags {}]} { + set code [catch {bindtags $w} msg] + regsub -all \\.${i}_dot $msg {} msg + } else { + set code [catch {bindtags $w $newtags} msg] + } + return -code $code $msg +} + +proc ::tkcon::SafeWindow {i w option args} { + if {[string match conf* $option] && [llength $args] > 1} { + set args [::tkcon::SafeSubst $i $args] + } elseif {[string match itemco* $option] && [llength $args] > 2} { + set args "[list [lindex $args 0]] [::tkcon::SafeSubst $i [lrange $args 1 end]]" + } elseif {[string match cr* $option]} { + if {[llength $args]%2} { + set args "[list [lindex $args 0]] [::tkcon::SafeSubst $i [lrange $args 1 end]]" + } else { + set args [::tkcon::SafeSubst $i $args] + } + } elseif {[string match bi* $option] && [llength $args] > 2} { + set args [list [lindex $args 0] [lindex $args 1] "[list $i] eval [list [lindex $args 2]]"] + } + set code [catch ".${i}_dot$w $option $args" msg] + if {$code} { + regsub -all .${i}_dot $msg {} msg + } elseif {[string match conf* $option] || [string match itemco* $option]} { + if {[llength $args] == 1} { + switch -- $args { + -textvariable - -variable { + set msg "[lrange $msg 0 3] [list [lrange [lindex $msg 4] 1 end]]" + } + -command - updatecommand { + set msg "[lrange $msg 0 3] [list [lindex [lindex $msg 4] 2]]" + } + } + } elseif {[llength $args] == 0} { + set args1 "" + foreach el $msg { + switch -- [lindex $el 0] { + -textvariable - -variable { + set el "[lrange $el 0 3] [list [lrange [lindex $el 4] 1 end]]" + } + -command - updatecommand { + set el "[lrange $el 0 3] [list [lindex [lindex $el 4] 2]]" + } + } + lappend args1 $el + } + set msg $args1 + } + } elseif {[string match cg* $option] || [string match itemcg* $option]} { + switch -- $args { + -textvariable - -variable { + set msg [lrange $msg 1 end] + } + -command - updatecommand { + set msg [lindex $msg 2] + } + } + } elseif {[string match bi* $option]} { + if {[llength $args] == 2 && $code == 0} { + set msg [lindex $msg 2] + } + } + return -code $code $msg +} + +proc ::tkcon::RetrieveFilter {host} { + variable PRIV + set result {} + if {[info exists PRIV(proxy)]} { + if {![regexp "^(localhost|127\.0\.0\.1)" $host]} { + set result [lrange [split [lindex $PRIV(proxy) 0] :] 0 1] + } + } + return $result +} + +proc ::tkcon::RetrieveAuthentication {} { + package require Tk + if {[catch {package require base64}]} { + if {[catch {package require Trf}]} { + error "base64 support not available" + } else { + set local64 "base64 -mode enc" + } + } else { + set local64 "base64::encode" + } + + set dlg [toplevel .auth] + catch {wm attributes $dlg -type dialog} + wm title $dlg "Authenticating Proxy Configuration" + set f1 [frame ${dlg}.f1] + set f2 [frame ${dlg}.f2] + button $f2.b -text "OK" -command "destroy $dlg" + pack $f2.b -side right + label $f1.l2 -text "Username" + label $f1.l3 -text "Password" + entry $f1.e2 -textvariable "[namespace current]::conf_userid" + entry $f1.e3 -textvariable "[namespace current]::conf_passwd" -show * + grid $f1.l2 -column 0 -row 0 -sticky e + grid $f1.l3 -column 0 -row 1 -sticky e + grid $f1.e2 -column 1 -row 0 -sticky news + grid $f1.e3 -column 1 -row 1 -sticky news + grid columnconfigure $f1 1 -weight 1 + pack $f2 -side bottom -fill x + pack $f1 -side top -anchor n -fill both -expand 1 + tkwait window $dlg + set result {} + if {[info exists [namespace current]::conf_userid]} { + set data [subst $[namespace current]::conf_userid] + append data : [subst $[namespace current]::conf_passwd] + set data [$local64 $data] + set result [list "Proxy-Authorization" "Basic $data"] + } + unset [namespace current]::conf_passwd + return $result +} + +proc ::tkcon::Retrieve {} { + # A little bit'o'magic to grab the latest tkcon from CVS and + # save it locally. It doesn't support proxies though... + variable PRIV + + set defExt "" + if {[string match "windows" $::tcl_platform(platform)]} { + set defExt ".tcl" + } + set file [tk_getSaveFile -title "Save Latest tkcon to ..." \ + -defaultextension $defExt \ + -initialdir [file dirname $PRIV(SCRIPT)] \ + -initialfile [file tail $PRIV(SCRIPT)] \ + -parent $PRIV(root) \ + -filetypes {{"Tcl Files" {.tcl .tk}} {"All Files" {*.*}}}] + if {[string compare $file ""]} { + package require http 2 + set headers {} + if {[info exists PRIV(proxy)]} { + ::http::config -proxyfilter [namespace origin RetrieveFilter] + if {[lindex $PRIV(proxy) 1] != {}} { + set headers [RetrieveAuthentication] + } + } + set token [::http::geturl $PRIV(HEADURL) \ + -headers $headers -timeout 30000] + ::http::wait $token + set code [catch { + set ncode [::http::ncode $token] + set i 0 + while {(($ncode >= 301) && ($ncode <= 307)) && [incr i] < 5} { + # redirect to meta Location + array set meta [::http::meta $token] + ::http::cleanup $token + if {![info exists meta(Location)]} { break } + set url $meta(Location) + if {![string match "http*" $url] + && [regexp {https?://[^/]+} $PRIV(HEADURL) srvr]} { + # attach the same http server info + set url $srvr/$url + } + set token [::http::geturl $url -headers $headers -timeout 30000] + ::http::wait $token + set ncode [::http::ncode $token] + } + if {$ncode != 200} { + return "expected http return code 200, received $ncode" + } + set status [::http::status $token] + if {$status == "ok"} { + set data [::http::data $token] + regexp {Id: tkcon.tcl,v (\d+\.\d+)} $data -> rcsVersion + regexp {VERSION\s+"(\d+\.\d+[^\"]*)"} $data -> tkconVersion + if {(![info exists rcsVersion] || ![info exists tkconVersion]) + && [tk_messageBox -type yesno -icon warning \ + -parent $PRIV(root) \ + -title "Invalid tkcon source code" \ + -message "Source code retrieved does not appear\ + to be correct.\nContinue with save to \"$file\"?"] \ + == "no"} { + return "invalid tkcon source code retrieved" + } + set fid [open $file w] + # We don't want newline mode to change + fconfigure $fid -translation binary + puts -nonewline $fid $data + close $fid + } else { + return "expected http status ok, received $status" + } + } err] + ::http::cleanup $token + if {$code == 2} { + tk_messageBox -type ok -icon info -parent $PRIV(root) \ + -title "Failed to retrieve source" \ + -message "Failed to retrieve latest tkcon source:\n$err\n$PRIV(HEADURL)" + } elseif {$code} { + return -code error $err + } else { + if {![info exists rcsVersion]} { set rcsVersion "UNKNOWN" } + if {![info exists tkconVersion]} { set tkconVersion "UNKNOWN" } + if {[tk_messageBox -type yesno -icon info -parent $PRIV(root) \ + -title "Retrieved tkcon v$tkconVersion, RCS $rcsVersion" \ + -message "Successfully retrieved tkcon v$tkconVersion,\ + RCS $rcsVersion. Shall I resource (not restart) this\ + version now?"] == "yes"} { + set PRIV(SCRIPT) $file + set PRIV(version) $tkconVersion.$rcsVersion + ::tkcon::Resource + } + } + } +} + +## 'send' package that handles multiple communication variants +## +# Try using Tk send first, then look for a winsend interp, +# then try dde and finally have a go at comm +namespace eval ::send {} +proc ::send::send {args} { + set winfoInterpCmd [list ::winfo interps] + array set opts [list displayof {} async 0] + while {[string match -* [lindex $args 0]]} { + switch -exact -- [lindex $args 0] { + -displayof { + set opts(displayof) [Pop args 1] + lappend winfoInterpCmd -displayof $opts(displayof) + } + -async { set opts(async) 1 } + -- { Pop args ; break } + default { + return -code error "bad option \"[lindex $args 0]\":\ + should be -displayof, -async or --" + } + } + Pop args + } + set app [Pop args] + + if {[llength [info commands ::winfo]] + && [lsearch -exact [eval $winfoInterpCmd] $app] > -1} { + set cmd [list ::send] + if {$opts(async) == 1} {lappend cmd -async} + if {$opts(displayof) != {}} {lappend cmd -displayof $opts(displayof)} + lappend cmd $app + eval $cmd $args + } elseif {[llength [info commands ::winsend]] + && [lsearch -exact [::winsend interps] $app] > -1} { + eval [list ::winsend send $app] $args + } elseif {[llength [info commands ::dde]] + && [lsearch -exact [dde services TclEval {}] \ + [list TclEval $app]] > -1} { + eval [list ::dde eval $app] $args + } elseif {[package provide comm] != {} + && [regexp {^[0-9]+$} [lindex $app 0]]} { + #if {$opts(displayof) != {} && [llength $app] == 1} { + # lappend app $opts(displayof) + #} + eval [list ::comm::comm send $app] $args + } else { + return -code error "bad interp: \"$app\" could not be found" + } +} + +proc ::send::interps {args} { + set winfoInterpCmd [list ::winfo interps] + array set opts [list displayof {}] + while {[string match -* [lindex $args 0]]} { + switch -exact -- [lindex $args 0] { + -displayof { + set opts(displayof) [Pop args 1] + lappend winfoInterpCmd -displayof $opts(displayof) + } + -- { Pop args ; break } + default { + return -code error "bad option \"[lindex $args 0]\":\ + should be -displayof or --" + } + } + Pop args + } + + set interps {} + if {[llength [info commands ::winfo]]} { + set interps [concat $interps [eval $winfoInterpCmd]] + } + if {[llength [info commands ::winsend]]} { + set interps [concat $interps [::winsend interps]] + } + if {[llength [info commands ::dde]]} { + set servers {} + foreach server [::dde services TclEval {}] { + lappend servers [lindex $server 1] + } + set interps [concat $interps $servers] + } + if {[package provide comm] != {}} { + set interps [concat $interps [::comm::comm interps]] + } + return $interps +} + +proc ::send::appname {args} { + set appname {} + if {[llength [info commands ::tk]]} { + set appname [eval ::tk appname $args] + } + if {[llength [info commands ::winsend]]} { + set appname [concat $appname [eval ::winsend appname $args]] + } + if {[llength [info commands ::dde]]} { + set appname [concat $appname [eval ::dde servername $args]] + } + # comm? can set port num and local/global interface. + return [lsort -unique $appname] +} + +proc ::send::Pop {varname {nth 0}} { + upvar $varname args + set r [lindex $args $nth] + set args [lreplace $args $nth $nth] + return $r +} +## +## end 'send' package + +## special case 'tk appname' in Tcl plugin +if {$::tkcon::PRIV(WWW)} { + rename tk ::tkcon::_tk + proc tk {cmd args} { + if {$cmd == "appname"} { + return "tkcon/WWW" + } else { + return [uplevel 1 ::tkcon::_tk [list $cmd] $args] + } + } +} + +## ::tkcon::Resource - 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. +## +proc ::tkcon::Resource {} { + uplevel \#0 { + if {[catch {source -rsrc tkcon}]} { source $::tkcon::PRIV(SCRIPT) } + } + Bindings + InitSlave $::tkcon::OPT(exec) +} + +## Initialize only if we haven't yet, and do other stuff that prepares to +## run. It only actually inits (and runs) tkcon if it is the main script. +## +proc ::tkcon::AtSource {} { + variable PRIV + + # the info script assumes we always call this while being sourced + set PRIV(SCRIPT) [info script] + if {!$PRIV(WWW) && [string length $PRIV(SCRIPT)]} { + if {[info tclversion] >= 8.4} { + set PRIV(SCRIPT) [file normalize $PRIV(SCRIPT)] + } else { + # we use a catch here because some wrap apps choke on 'file type' + # because TclpLstat wasn't wrappable until 8.4. + catch { + while {[string match link [file type $PRIV(SCRIPT)]]} { + set link [file readlink $PRIV(SCRIPT)] + if {[string match relative [file pathtype $link]]} { + set PRIV(SCRIPT) \ + [file join [file dirname $PRIV(SCRIPT)] $link] + } else { + set PRIV(SCRIPT) $link + } + } + catch {unset link} + if {[string match relative [file pathtype $PRIV(SCRIPT)]]} { + set PRIV(SCRIPT) [file join [pwd] $PRIV(SCRIPT)] + } + } + } + } + # normalize argv0 if it was tkcon to ensure that we'll be able + # to load slaves correctly. + if {[info exists ::argv0] && [info script] == $::argv0} { + set ::argv0 $PRIV(SCRIPT) + } + + if {(![info exists PRIV(root)] || ![winfo exists $PRIV(root)]) \ + && ([info exists ::argv0] && $PRIV(SCRIPT) == $::argv0)} { + global argv + if {[info exists argv]} { + eval ::tkcon::Init $argv + } else { + ::tkcon::Init + } + } +} +tkcon::AtSource + +package provide tkcon $::tkcon::VERSION -- cgit v0.12