source: trunk/tkcon/tkcon.tcl @ 931

Last change on this file since 931 was 931, checked in by toby, 11 years ago

include rest of files

  • Property svn:executable set to *
File size: 157.4 KB
RevLine 
[931]1#!/bin/sh
2# \
3exec wish "$0" ${1+"$@"}
4
5#
6## tkcon.tcl
7## Enhanced Tk Console, part of the VerTcl system
8##
9## Originally based off Brent Welch's Tcl Shell Widget
10## (from "Practical Programming in Tcl and Tk")
11##
12## Thanks to the following (among many) for early bug reports & code ideas:
13## Steven Wahl <steven@indra.com>, Jan Nijtmans <nijtmans@nici.kun.nl>
14## Crimmins <markcrim@umich.edu>, Wart <wart@ugcs.caltech.edu>
15##
16## Copyright 1995-2001 Jeffrey Hobbs
17## Initiated: Thu Aug 17 15:36:47 PDT 1995
18##
19## jeff.hobbs@acm.org, jeff@hobbs.org
20##
21## source standard_disclaimer.tcl
22## source bourbon_ware.tcl
23##
24
25# Proxy support for retrieving the current version of Tkcon.
26#
27# Mon Jun 25 12:19:56 2001 - Pat Thoyts <Pat.Thoyts@bigfoot.com>
28#
29# In your tkcon.cfg or .tkconrc file put your proxy details into the
30# `proxy' member of the `PRIV' array. e.g.:
31#
32#    set ::tkcon::PRIV(proxy) wwwproxy:8080
33#
34# If you want to be prompted for proxy authentication details (eg for
35# an NT proxy server) make the second element of this variable non-nil - eg:
36#
37#    set ::tkcon::PRIV(proxy) {wwwproxy:8080 1}
38#
39# Or you can set the above variable from within tkcon by calling
40#
41#    tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080
42#
43
44if {$tcl_version < 8.0} {
45    return -code error "tkcon requires at least Tcl/Tk8"
46} else {
47    package require -exact Tk $tcl_version
48}
49
50catch {package require bogus-package-name}
51foreach pkg [info loaded {}] {
52    set file [lindex $pkg 0]
53    set name [lindex $pkg 1]
54    if {![catch {set version [package require $name]}]} {
55        if {[string match {} [package ifneeded $name $version]]} {
56            package ifneeded $name $version [list load $file $name]
57        }
58    }
59}
60catch {unset pkg file name version}
61
62# Tk 8.4 makes previously exposed stuff private.
63# FIX: Update tkcon to not rely on the private Tk code.
64#
65if {![llength [info globals tkPriv]]} {
66    ::tk::unsupported::ExposePrivateVariable tkPriv
67}
68foreach cmd {SetCursor UpDownLine Transpose ScrollPages} {
69    if {![llength [info commands tkText$cmd]]} {
70        ::tk::unsupported::ExposePrivateCommand tkText$cmd
71    }
72}
73
74# Initialize the ::tkcon namespace
75#
76namespace eval ::tkcon {
77    # The OPT variable is an array containing most of the optional
78    # info to configure.  COLOR has the color data.
79    variable OPT
80    variable COLOR
81
82    # PRIV is used for internal data that only tkcon should fiddle with.
83    variable PRIV
84    set PRIV(WWW) [info exists embed_args]
85}
86
87## ::tkcon::Init - inits tkcon
88#
89# Calls:        ::tkcon::InitUI
90# Outputs:      errors found in tkcon's resource file
91##
92proc ::tkcon::Init {} {
93    variable OPT
94    variable COLOR
95    variable PRIV
96    global tcl_platform env argc argv tcl_interactive errorInfo
97
98    if {![info exists argv]} {
99        set argv {}
100        set argc 0
101    }
102
103    set tcl_interactive 1
104
105    if {[info exists PRIV(name)]} {
106        set title $PRIV(name)
107    } else {
108        MainInit
109        # some main initialization occurs later in this proc,
110        # to go after the UI init
111        set MainInit 1
112        set title Main
113    }
114
115    ##
116    ## When setting up all the default values, we always check for
117    ## prior existence.  This allows users who embed tkcon to modify
118    ## the initial state before tkcon initializes itself.
119    ##
120
121    # bg == {} will get bg color from the main toplevel (in InitUI)
122    foreach {key default} {
123        bg              {}
124        blink           \#FFFF00
125        cursor          \#000000
126        disabled        \#4D4D4D
127        proc            \#008800
128        var             \#FFC0D0
129        prompt          \#8F4433
130        stdin           \#000000
131        stdout          \#0000FF
132        stderr          \#FF0000
133    } {
134        if {![info exists COLOR($key)]} { set COLOR($key) $default }
135    }
136
137    foreach {key default} {
138        autoload        {}
139        blinktime       500
140        blinkrange      1
141        buffer          512
142        calcmode        0
143        cols            80
144        debugPrompt     {(level \#$level) debug [history nextid] > }
145        dead            {}
146        expandorder     {Pathname Variable Procname}
147        font            {}
148        history         48
149        hoterrors       1
150        library         {}
151        lightbrace      1
152        lightcmd        1
153        maineval        {}
154        maxmenu         15
155        nontcl          0
156        prompt1         {ignore this, it's set below}
157        rows            20
158        scrollypos      right
159        showmenu        1
160        showmultiple    1
161        showstatusbar   0
162        slaveeval       {}
163        slaveexit       close
164        subhistory      1
165        gc-delay        60000
166        gets            {congets}
167        usehistory      1
168
169        exec            slave
170    } {
171        if {![info exists OPT($key)]} { set OPT($key) $default }
172    }
173
174    foreach {key default} {
175        app             {}
176        appname         {}
177        apptype         slave
178        namesp          ::
179        cmd             {}
180        cmdbuf          {}
181        cmdsave         {}
182        event           1
183        deadapp         0
184        deadsock        0
185        debugging       0
186        displayWin      .
187        histid          0
188        find            {}
189        find,case       0
190        find,reg        0
191        errorInfo       {}
192        showOnStartup   1
193        slavealias      { edit more less tkcon }
194        slaveprocs      {
195            alias clear dir dump echo idebug lremove
196            tkcon_puts tkcon_gets observe observe_var unalias which what
197        }
198        version         2.3
199        RCS             {RCS: @(#) $Id: tkcon.tcl,v 1.52 2002/01/24 19:50:36 hobbs Exp $}
200        HEADURL         {http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tkcon/tkcon/tkcon.tcl?rev=HEAD}
201        docs            "http://tkcon.sourceforge.net/"
202        email           {jeff@hobbs.org}
203        root            .
204    } {
205        if {![info exists PRIV($key)]} { set PRIV($key) $default }
206    }
207
208    ## NOTES FOR STAYING IN PRIMARY INTERPRETER:
209    ##
210    ## If you set ::tkcon::OPT(exec) to {}, then instead of a multiple
211    ## interp model, you get tkcon operating in the main interp by default.
212    ## This can be useful when attaching to programs that like to operate
213    ## in the main interpter (for example, based on special wish'es).
214    ## You can set this from the command line with -exec ""
215    ## A side effect is that all tkcon command line args will be used
216    ## by the first console only.
217    #set OPT(exec) {}
218
219    if {$PRIV(WWW)} {
220        lappend PRIV(slavealias) history
221        set OPT(prompt1) {[history nextid] % }
222    } else {
223        lappend PRIV(slaveprocs) tcl_unknown unknown
224        set OPT(prompt1) {([file tail [pwd]]) [history nextid] % }
225    }
226
227    ## If we are using the default '.' toplevel, and there appear to be
228    ## children of '.', then make sure we use a disassociated toplevel.
229    if {$PRIV(root) == "." && [llength [winfo children .]]} {
230        set PRIV(root) .tkcon
231    }
232
233    ## Do platform specific configuration here, other than defaults
234    ### Use tkcon.cfg filename for resource filename on non-unix systems
235    ### Determine what directory the resource file should be in
236    switch $tcl_platform(platform) {
237        macintosh       {
238            if {![interp issafe]} {cd [file dirname [info script]]}
239            set envHome         PREF_FOLDER
240            set rcfile          tkcon.cfg
241            set histfile        tkcon.hst
242            catch {console hide}
243        }
244        windows         {
245            set envHome         HOME
246            set rcfile          tkcon.cfg
247            set histfile        tkcon.hst
248        }
249        unix            {
250            set envHome         HOME
251            set rcfile          .tkconrc
252            set histfile        .tkcon_history
253        }
254    }
255    if {[info exists env($envHome)]} {
256        if {![info exists PRIV(rcfile)]} {
257            set PRIV(rcfile)    [file join $env($envHome) $rcfile]
258        }
259        if {![info exists PRIV(histfile)]} {
260            set PRIV(histfile)  [file join $env($envHome) $histfile]
261        }
262    }
263
264    ## Handle command line arguments before sourcing resource file to
265    ## find if resource file is being specified (let other args pass).
266    if {[set i [lsearch -exact $argv -rcfile]] != -1} {
267        set PRIV(rcfile) [lindex $argv [incr i]]
268    }
269
270    if {!$PRIV(WWW) && [file exists $PRIV(rcfile)]} {
271        set code [catch {uplevel \#0 [list source $PRIV(rcfile)]} err]
272    }
273
274    if {[info exists env(TK_CON_LIBRARY)]} {
275        lappend ::auto_path $env(TK_CON_LIBRARY)
276    } else {
277        lappend ::auto_path $OPT(library)
278    }
279
280    if {![info exists ::tcl_pkgPath]} {
281        set dir [file join [file dirname [info nameofexec]] lib]
282        if {[llength [info commands @scope]]} {
283            set dir [file join $dir itcl]
284        }
285        catch {source [file join $dir pkgIndex.tcl]}
286    }
287    catch {tclPkgUnknown dummy-name dummy-version}
288
289    ## Handle rest of command line arguments after sourcing resource file
290    ## and slave is created, but before initializing UI or setting packages.
291    set slaveargs {}
292    set slavefiles {}
293    set truth {^(1|yes|true|on)$}
294    for {set i 0} {$i < $argc} {incr i} {
295        set arg [lindex $argv $i]
296        if {[string match {-*} $arg]} {
297            set val [lindex $argv [incr i]]
298            ## Handle arg based options
299            switch -glob -- $arg {
300                -- - -argv      {
301                    set argv [concat -- [lrange $argv $i end]]
302                    set argc [llength $argv]
303                    break
304                }
305                -color-*        { set COLOR([string range $arg 7 end]) $val }
306                -exec           { set OPT(exec) $val }
307                -main - -e - -eval      { append OPT(maineval) \n$val\n }
308                -package - -load        { lappend OPT(autoload) $val }
309                -slave          { append OPT(slaveeval) \n$val\n }
310                -nontcl         { set OPT(nontcl) [regexp -nocase $truth $val]}
311                -root           { set PRIV(root) $val }
312                -font           { set OPT(font) $val }
313                -rcfile {}
314                default { lappend slaveargs $arg; incr i -1 }
315            }
316        } elseif {[file isfile $arg]} {
317            lappend slavefiles $arg
318        } else {
319            lappend slaveargs $arg
320        }
321    }
322
323    ## Create slave executable
324    if {[string compare {} $OPT(exec)]} {
325        uplevel \#0 ::tkcon::InitSlave $OPT(exec) $slaveargs
326    } else {
327        set argc [llength $slaveargs]
328        set argv $slaveargs
329        uplevel \#0 $slaveargs
330    }
331
332    ## Attach to the slave, EvalAttached will then be effective
333    Attach $PRIV(appname) $PRIV(apptype)
334    InitUI $title
335
336    ## swap puts and gets with the tkcon versions to make sure all
337    ## input and output is handled by tkcon
338    if {![catch {rename ::puts ::tkcon_tcl_puts}]} {
339        interp alias {} ::puts {} ::tkcon_puts
340    }
341    if {($OPT(gets) != "") && ![catch {rename ::gets ::tkcon_tcl_gets}]} {
342        interp alias {} ::gets {} ::tkcon_gets
343    }
344
345    EvalSlave history keep $OPT(history)
346    if {[info exists MainInit]} {
347        # Source history file only for the main console, as all slave
348        # consoles will adopt from the main's history, but still
349        # keep separate histories
350        if {!$PRIV(WWW) && $OPT(usehistory) && [file exists $PRIV(histfile)]} {
351            puts -nonewline "loading history file ... "
352            # The history file is built to be loaded in and
353            # understood by tkcon
354            if {[catch {uplevel \#0 [list source $PRIV(histfile)]} herr]} {
355                puts stderr "error:\n$herr"
356                append PRIV(errorInfo) $errorInfo\n
357            }
358            set PRIV(event) [EvalSlave history nextid]
359            puts "[expr {$PRIV(event)-1}] events added"
360        }
361    }
362
363    ## Autoload specified packages in slave
364    set pkgs [EvalSlave package names]
365    foreach pkg $OPT(autoload) {
366        puts -nonewline "autoloading package \"$pkg\" ... "
367        if {[lsearch -exact $pkgs $pkg]>-1} {
368            if {[catch {EvalSlave package require [list $pkg]} pkgerr]} {
369                puts stderr "error:\n$pkgerr"
370                append PRIV(errorInfo) $errorInfo\n
371            } else { puts "OK" }
372        } else {
373            puts stderr "error: package does not exist"
374        }
375    }
376
377    ## Evaluate maineval in slave
378    if {[string compare {} $OPT(maineval)] && \
379            [catch {uplevel \#0 $OPT(maineval)} merr]} {
380        puts stderr "error in eval:\n$merr"
381        append PRIV(errorInfo) $errorInfo\n
382    }
383
384    ## Source extra command line argument files into slave executable
385    foreach fn $slavefiles {
386        puts -nonewline "slave sourcing \"$fn\" ... "
387        if {[catch {EvalSlave source [list $fn]} fnerr]} {
388            puts stderr "error:\n$fnerr"
389            append PRIV(errorInfo) $errorInfo\n
390        } else { puts "OK" }
391    }
392
393    ## Evaluate slaveeval in slave
394    if {[string compare {} $OPT(slaveeval)] && \
395            [catch {interp eval $OPT(exec) $OPT(slaveeval)} serr]} {
396        puts stderr "error in slave eval:\n$serr"
397        append PRIV(errorInfo) $errorInfo\n
398    }
399    ## Output any error/output that may have been returned from rcfile
400    if {[info exists code] && $code && [string compare {} $err]} {
401        puts stderr "error in $PRIV(rcfile):\n$err"
402        append PRIV(errorInfo) $errorInfo
403    }
404    if {[string compare {} $OPT(exec)]} {
405        StateCheckpoint [concat $PRIV(name) $OPT(exec)] slave
406    }
407    StateCheckpoint $PRIV(name) slave
408
409    Prompt "$title console display active (Tcl$::tcl_patchLevel / Tk$::tk_patchLevel)\n"
410}
411
412## ::tkcon::InitSlave - inits the slave by placing key procs and aliases in it
413## It's arg[cv] are based on passed in options, while argv0 is the same as
414## the master.  tcl_interactive is the same as the master as well.
415# ARGS: slave   - name of slave to init.  If it does not exist, it is created.
416#       args    - args to pass to a slave as argv/argc
417##
418proc ::tkcon::InitSlave {slave args} {
419    variable OPT
420    variable COLOR
421    variable PRIV
422    global argv0 tcl_interactive tcl_library env auto_path
423
424    if {[string match {} $slave]} {
425        return -code error "Don't init the master interpreter, goofball"
426    }
427    if {![interp exists $slave]} { interp create $slave }
428    if {[interp eval $slave info command source] == ""} {
429        $slave alias source SafeSource $slave
430        $slave alias load SafeLoad $slave
431        $slave alias open SafeOpen $slave
432        $slave alias file file
433        interp eval $slave [dump var -nocomplain tcl_library auto_path env]
434        interp eval $slave { catch {source [file join $tcl_library init.tcl]} }
435        interp eval $slave { catch unknown }
436    }
437    $slave alias exit exit
438    interp eval $slave {
439        # Do package require before changing around puts/gets
440        catch {package require bogus-package-name}
441        catch {rename ::puts ::tkcon_tcl_puts}
442    }
443    foreach cmd $PRIV(slaveprocs) { $slave eval [dump proc $cmd] }
444    foreach cmd $PRIV(slavealias) { $slave alias $cmd $cmd }
445    interp alias $slave ::ls $slave ::dir -full
446    interp alias $slave ::puts $slave ::tkcon_puts
447    if {$OPT(gets) != ""} {
448        interp eval $slave { catch {rename ::gets ::tkcon_tcl_gets} }
449        interp alias $slave ::gets $slave ::tkcon_gets
450    }
451    if {[info exists argv0]} {interp eval $slave [list set argv0 $argv0]}
452    interp eval $slave set tcl_interactive $tcl_interactive \; \
453            set auto_path [list $auto_path] \; \
454            set argc [llength $args] \; \
455            set argv  [list $args] \; {
456        if {![llength [info command bgerror]]} {
457            proc bgerror err {
458                global errorInfo
459                set body [info body bgerror]
460                rename ::bgerror {}
461                if {[auto_load bgerror]} { return [bgerror $err] }
462                proc bgerror err $body
463                tkcon bgerror $err $errorInfo
464            }
465        }
466    }
467
468    foreach pkg [lremove [package names] Tcl] {
469        foreach v [package versions $pkg] {
470            interp eval $slave [list package ifneeded $pkg $v \
471                    [package ifneeded $pkg $v]]
472        }
473    }
474}
475
476## ::tkcon::InitInterp - inits an interpreter by placing key
477## procs and aliases in it.
478# ARGS: name    - interp name
479#       type    - interp type (slave|interp)
480##
481proc ::tkcon::InitInterp {name type} {
482    variable OPT
483    variable PRIV
484
485    ## Don't allow messing up a local master interpreter
486    if {[string match namespace $type] || ([string match slave $type] && \
487            [regexp {^([Mm]ain|Slave[0-9]+)$} $name])} return
488    set old [Attach]
489    set oldname $PRIV(namesp)
490    catch {
491        Attach $name $type
492        EvalAttached { catch {rename ::puts ::tkcon_tcl_puts} }
493        foreach cmd $PRIV(slaveprocs) { EvalAttached [dump proc $cmd] }
494        switch -exact $type {
495            slave {
496                foreach cmd $PRIV(slavealias) {
497                    Main interp alias $name ::$cmd $PRIV(name) ::$cmd
498                }
499            }
500            interp {
501                set thistkcon [tk appname]
502                foreach cmd $PRIV(slavealias) {
503                    EvalAttached "proc $cmd args { send [list $thistkcon] $cmd \$args }"
504                }
505            }
506        }
507        ## Catch in case it's a 7.4 (no 'interp alias') interp
508        EvalAttached {
509            catch {interp alias {} ::ls {} ::dir -full}
510            if {[catch {interp alias {} ::puts {} ::tkcon_puts}]} {
511                catch {rename ::tkcon_puts ::puts}
512            }
513        }
514        if {$OPT(gets) != ""} {
515            EvalAttached {
516                catch {rename ::gets ::tkcon_tcl_gets}
517                if {[catch {interp alias {} ::gets {} ::tkcon_gets}]} {
518                    catch {rename ::tkcon_gets ::gets}
519                }
520            }
521        }
522        return
523    } {err}
524    eval Attach $old
525    AttachNamespace $oldname
526    if {[string compare {} $err]} { return -code error $err }
527}
528
529## ::tkcon::InitUI - inits UI portion (console) of tkcon
530## Creates all elements of the console window and sets up the text tags
531# ARGS: root    - widget pathname of the tkcon console root
532#       title   - title for the console root and main (.) windows
533# Calls:        ::tkcon::InitMenus, ::tkcon::Prompt
534##
535proc ::tkcon::InitUI {title} {
536    variable OPT
537    variable PRIV
538    variable COLOR
539
540    set root $PRIV(root)
541    if {[string match . $root]} { set w {} } else { set w [toplevel $root] }
542    if {!$PRIV(WWW)} {
543        wm withdraw $root
544        wm protocol $root WM_DELETE_WINDOW exit
545    }
546    set PRIV(base) $w
547
548    ## Text Console
549    set PRIV(console) [set con $w.text]
550    text $con -wrap char -yscrollcommand [list $w.sy set] \
551            -foreground $COLOR(stdin) \
552            -insertbackground $COLOR(cursor)
553    $con mark set output 1.0
554    $con mark set limit 1.0
555    if {[string compare {} $COLOR(bg)]} {
556        $con configure -background $COLOR(bg)
557    }
558    set COLOR(bg) [$con cget -background]
559    if {[string compare {} $OPT(font)]} {
560        ## Set user-requested font, if any
561        $con configure -font $OPT(font)
562    } else {
563        ## otherwise make sure the font is monospace
564        set font [$con cget -font]
565        if {![font metrics $font -fixed]} {
566            font create tkconfixed -family Courier -size 12
567            $con configure -font tkconfixed
568        }
569    }
570    set OPT(font) [$con cget -font]
571    if {!$PRIV(WWW)} {
572        $con configure -setgrid 1 -width $OPT(cols) -height $OPT(rows)
573    }
574    bindtags $con [list $con TkConsole TkConsolePost $root all]
575    ## Menus
576    ## catch against use in plugin
577    if {[catch {menu $w.mbar} PRIV(menubar)]} {
578        set PRIV(menubar) [frame $w.mbar -relief raised -bd 1]
579    }
580    ## Scrollbar
581    set PRIV(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 \
582            -command [list $con yview]]
583
584    InitMenus $PRIV(menubar) $title
585    Bindings
586
587    if {$OPT(showmenu)} {
588        $root configure -menu $PRIV(menubar)
589    }
590    pack $w.sy -side $OPT(scrollypos) -fill y
591    pack $con -fill both -expand 1
592
593    set PRIV(statusbar) [set sbar [frame $w.sbar]]
594    label $sbar.attach -relief sunken -bd 1 -anchor w \
595            -textvariable ::tkcon::PRIV(StatusAttach)
596    label $sbar.mode -relief sunken -bd 1 -anchor w  \
597            -textvariable ::tkcon::PRIV(StatusMode)
598    label $sbar.cursor -relief sunken -bd 1 -anchor w -width 6 \
599            -textvariable ::tkcon::PRIV(StatusCursor)
600    grid $sbar.attach $sbar.mode $sbar.cursor -sticky news -padx 1
601    grid columnconfigure $sbar 0 -weight 1
602    grid columnconfigure $sbar 1 -weight 1
603    grid columnconfigure $sbar 2 -weight 0
604
605    if {$OPT(showstatusbar)} {
606        pack $sbar -side bottom -fill x -before $::tkcon::PRIV(scrolly)
607    }
608
609    foreach col {prompt stdout stderr stdin proc} {
610        $con tag configure $col -foreground $COLOR($col)
611    }
612    $con tag configure var -background $COLOR(var)
613    $con tag raise sel
614    $con tag configure blink -background $COLOR(blink)
615    $con tag configure find -background $COLOR(blink)
616
617    if {!$PRIV(WWW)} {
618        wm title $root "tkcon $PRIV(version) $title"
619        bind $con <Configure> {
620            scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \
621                    ::tkcon::OPT(cols) ::tkcon::OPT(rows)
622        }
623        if {$PRIV(showOnStartup)} { wm deiconify $root }
624    }
625    if {$PRIV(showOnStartup)} { focus -force $PRIV(console) }
626    if {$OPT(gc-delay)} {
627        after $OPT(gc-delay) ::tkcon::GarbageCollect
628    }
629}
630
631## ::tkcon::GarbageCollect - do various cleanup ops periodically to our setup
632##
633proc ::tkcon::GarbageCollect {} {
634    variable OPT
635    variable PRIV
636
637    set w $PRIV(console)
638    ## Remove error tags that no longer span anything
639    ## Make sure the tag pattern matches the unique tag prefix
640    foreach tag [$w tag names] {
641        if {[string match _tag* $tag] && ![llength [$w tag ranges $tag]]} {
642            $w tag delete $tag
643        }
644    }
645    if {$OPT(gc-delay)} {
646        after $OPT(gc-delay) ::tkcon::GarbageCollect
647    }
648}
649
650## ::tkcon::Eval - evaluates commands input into console window
651## This is the first stage of the evaluating commands in the console.
652## They need to be broken up into consituent commands (by ::tkcon::CmdSep) in
653## case a multiple commands were pasted in, then each is eval'ed (by
654## ::tkcon::EvalCmd) in turn.  Any uncompleted command will not be eval'ed.
655# ARGS: w       - console text widget
656# Calls:        ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd
657##
658proc ::tkcon::Eval {w} {
659    set incomplete [CmdSep [CmdGet $w] cmds last]
660    $w mark set insert end-1c
661    $w insert end \n
662    if {[llength $cmds]} {
663        foreach c $cmds {EvalCmd $w $c}
664        $w insert insert $last {}
665    } elseif {!$incomplete} {
666        EvalCmd $w $last
667    }
668    $w see insert
669}
670
671## ::tkcon::EvalCmd - evaluates a single command, adding it to history
672# ARGS: w       - console text widget
673#       cmd     - the command to evaluate
674# Calls:        ::tkcon::Prompt
675# Outputs:      result of command to stdout (or stderr if error occured)
676# Returns:      next event number
677##
678proc ::tkcon::EvalCmd {w cmd} {
679    variable OPT
680    variable PRIV
681
682    $w mark set output end
683    if {[string compare {} $cmd]} {
684        set code 0
685        if {$OPT(subhistory)} {
686            set ev [EvalSlave history nextid]
687            incr ev -1
688            if {[string match !! $cmd]} {
689                set code [catch {EvalSlave history event $ev} cmd]
690                if {!$code} {$w insert output $cmd\n stdin}
691            } elseif {[regexp {^!(.+)$} $cmd dummy event]} {
692                ## Check last event because history event is broken
693                set code [catch {EvalSlave history event $ev} cmd]
694                if {!$code && ![string match ${event}* $cmd]} {
695                    set code [catch {EvalSlave history event $event} cmd]
696                }
697                if {!$code} {$w insert output $cmd\n stdin}
698            } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} {
699                set code [catch {EvalSlave history event $ev} cmd]
700                if {!$code} {
701                    regsub -all -- $old $cmd $new cmd
702                    $w insert output $cmd\n stdin
703                }
704            } elseif {$OPT(calcmode) && ![catch {expr $cmd} err]} {
705                EvalSlave history add $cmd
706                set cmd $err
707                set code -1
708            }
709        }
710        if {$code} {
711            $w insert output $cmd\n stderr
712        } else {
713            ## We are about to evaluate the command, so move the limit
714            ## mark to ensure that further <Return>s don't cause double
715            ## evaluation of this command - for cases like the command
716            ## has a vwait or something in it
717            $w mark set limit end
718            if {$OPT(nontcl) && [string match interp $PRIV(apptype)]} {
719                set code [catch {EvalSend $cmd} res]
720                if {$code == 1} {
721                    set PRIV(errorInfo) "Non-Tcl errorInfo not available"
722                }
723            } elseif {[string match socket $PRIV(apptype)]} {
724                set code [catch {EvalSocket $cmd} res]
725                if {$code == 1} {
726                    set PRIV(errorInfo) "Socket-based errorInfo not available"
727                }
728            } else {
729                set code [catch {EvalAttached $cmd} res]
730                if {$code == 1} {
731                    if {[catch {EvalAttached [list set errorInfo]} err]} {
732                        set PRIV(errorInfo) "Error getting errorInfo:\n$err"
733                    } else {
734                        set PRIV(errorInfo) $err
735                    }
736                }
737            }
738            EvalSlave history add $cmd
739            if {$code} {
740                if {$OPT(hoterrors)} {
741                    set tag [UniqueTag $w]
742                    $w insert output $res [list stderr $tag] \n stderr
743                    $w tag bind $tag <Enter> \
744                            [list $w tag configure $tag -under 1]
745                    $w tag bind $tag <Leave> \
746                            [list $w tag configure $tag -under 0]
747                    $w tag bind $tag <ButtonRelease-1> \
748                            "if {!\[info exists tkPriv(mouseMoved)\] || !\$tkPriv(mouseMoved)} \
749                            {[list edit -attach [Attach] -type error -- $PRIV(errorInfo)]}"
750                } else {
751                    $w insert output $res\n stderr
752                }
753            } elseif {[string compare {} $res]} {
754                $w insert output $res\n stdout
755            }
756        }
757    }
758    Prompt
759    set PRIV(event) [EvalSlave history nextid]
760}
761
762## ::tkcon::EvalSlave - evaluates the args in the associated slave
763## args should be passed to this procedure like they would be at
764## the command line (not like to 'eval').
765# ARGS: args    - the command and args to evaluate
766##
767proc ::tkcon::EvalSlave args {
768    interp eval $::tkcon::OPT(exec) $args
769}
770
771## ::tkcon::EvalOther - evaluate a command in a foreign interp or slave
772## without attaching to it.  No check for existence is made.
773# ARGS: app     - interp/slave name
774#       type    - (slave|interp)
775##
776proc ::tkcon::EvalOther { app type args } {
777    if {[string compare slave $type]==0} {
778        return [Slave $app $args]
779    } else {
780        return [uplevel 1 send [list $app] $args]
781    }
782}
783
784## ::tkcon::EvalSend - sends the args to the attached interpreter
785## Varies from 'send' by determining whether attachment is dead
786## when an error is received
787# ARGS: cmd     - the command string to send across
788# Returns:      the result of the command
789##
790proc ::tkcon::EvalSend cmd {
791    variable OPT
792    variable PRIV
793
794    if {$PRIV(deadapp)} {
795        if {[lsearch -exact [winfo interps] $PRIV(app)]<0} {
796            return
797        } else {
798            set PRIV(appname) [string range $PRIV(appname) 5 end]
799            set PRIV(deadapp) 0
800            Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)]
801        }
802    }
803    set code [catch {send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result]
804    if {$code && [lsearch -exact [winfo interps] $PRIV(app)]<0} {
805        ## Interpreter disappeared
806        if {[string compare leave $OPT(dead)] && \
807                ([string match ignore $OPT(dead)] || \
808                [tk_dialog $PRIV(base).dead "Dead Attachment" \
809                "\"$PRIV(app)\" appears to have died.\
810                \nReturn to primary slave interpreter?" questhead 0 OK No])} {
811            set PRIV(appname) "DEAD:$PRIV(appname)"
812            set PRIV(deadapp) 1
813        } else {
814            set err "Attached Tk interpreter \"$PRIV(app)\" died."
815            Attach {}
816            set PRIV(deadapp) 0
817            EvalSlave set errorInfo $err
818        }
819        Prompt \n [CmdGet $PRIV(console)]
820    }
821    return -code $code $result
822}
823
824## ::tkcon::EvalSocket - sends the string to an interpreter attached via
825## a tcp/ip socket
826##
827## In the EvalSocket case, ::tkcon::PRIV(app) is the socket id
828##
829## Must determine whether socket is dead when an error is received
830# ARGS: cmd     - the data string to send across
831# Returns:      the result of the command
832##
833proc ::tkcon::EvalSocket cmd {
834    variable OPT
835    variable PRIV
836    global tcl_version
837
838    if {$PRIV(deadapp)} {
839        if {![info exists PRIV(app)] || \
840                [catch {eof $PRIV(app)} eof] || $eof} {
841            return
842        } else {
843            set PRIV(appname) [string range $PRIV(appname) 5 end]
844            set PRIV(deadapp) 0
845            Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)]
846        }
847    }
848    # Sockets get \'s interpreted, so that users can
849    # send things like \n\r or explicit hex values
850    set cmd [subst -novariables -nocommands $cmd]
851    #puts [list $PRIV(app) $cmd]
852    set code [catch {puts $PRIV(app) $cmd ; flush $PRIV(app)} result]
853    if {$code && [eof $PRIV(app)]} {
854        ## Interpreter died or disappeared
855        puts "$code eof [eof $PRIV(app)]"
856        EvalSocketClosed
857    }
858    return -code $code $result
859}
860
861## ::tkcon::EvalSocketEvent - fileevent command for an interpreter attached
862## via a tcp/ip socket
863## Must determine whether socket is dead when an error is received
864# ARGS: args    - the args to send across
865# Returns:      the result of the command
866##
867proc ::tkcon::EvalSocketEvent {} {
868    variable PRIV
869
870    if {[gets $PRIV(app) line] == -1} {
871        if {[eof $PRIV(app)]} {
872            EvalSocketClosed
873        }
874        return
875    }
876    puts $line
877}
878
879## ::tkcon::EvalSocketClosed - takes care of handling a closed eval socket
880##
881# ARGS: args    - the args to send across
882# Returns:      the result of the command
883##
884proc ::tkcon::EvalSocketClosed {} {
885    variable OPT
886    variable PRIV
887
888    catch {close $PRIV(app)}
889    if {[string compare leave $OPT(dead)] && \
890            ([string match ignore $OPT(dead)] || \
891            [tk_dialog $PRIV(base).dead "Dead Attachment" \
892            "\"$PRIV(app)\" appears to have died.\
893            \nReturn to primary slave interpreter?" questhead 0 OK No])} {
894        set PRIV(appname) "DEAD:$PRIV(appname)"
895        set PRIV(deadapp) 1
896    } else {
897        set err "Attached Tk interpreter \"$PRIV(app)\" died."
898        Attach {}
899        set PRIV(deadapp) 0
900        EvalSlave set errorInfo $err
901    }
902    Prompt \n [CmdGet $PRIV(console)]
903}
904
905## ::tkcon::EvalNamespace - evaluates the args in a particular namespace
906## This is an override for ::tkcon::EvalAttached for when the user wants
907## to attach to a particular namespace of the attached interp
908# ARGS: attached       
909#       namespace       the namespace to evaluate in
910#       args            the args to evaluate
911# RETURNS:      the result of the command
912##
913proc ::tkcon::EvalNamespace { attached namespace args } {
914    if {[llength $args]} {
915        uplevel \#0 $attached \
916                [list [concat [list namespace eval $namespace] $args]]
917    }
918}
919
920
921## ::tkcon::Namespaces - return all the namespaces descendent from $ns
922##
923#
924##
925proc ::tkcon::Namespaces {{ns ::} {l {}}} {
926    if {[string compare {} $ns]} { lappend l $ns }
927    foreach i [EvalAttached [list namespace children $ns]] {
928        set l [Namespaces $i $l]
929    }
930    return $l
931}
932
933## ::tkcon::CmdGet - gets the current command from the console widget
934# ARGS: w       - console text widget
935# Returns:      text which compromises current command line
936##
937proc ::tkcon::CmdGet w {
938    if {![llength [$w tag nextrange prompt limit end]]} {
939        $w tag add stdin limit end-1c
940        return [$w get limit end-1c]
941    }
942}
943
944## ::tkcon::CmdSep - separates multiple commands into a list and remainder
945# ARGS: cmd     - (possible) multiple command to separate
946#       list    - varname for the list of commands that were separated.
947#       last    - varname of any remainder (like an incomplete final command).
948#               If there is only one command, it's placed in this var.
949# Returns:      constituent command info in varnames specified by list & rmd.
950##
951proc ::tkcon::CmdSep {cmd list last} {
952    upvar 1 $list cmds $last inc
953    set inc {}
954    set cmds {}
955    foreach c [split [string trimleft $cmd] \n] {
956        if {[string compare $inc {}]} {
957            append inc \n$c
958        } else {
959            append inc [string trimleft $c]
960        }
961        if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
962            if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
963            set inc {}
964        }
965    }
966    set i [string compare $inc {}]
967    if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} {
968        set inc [lindex $cmds end]
969        set cmds [lreplace $cmds end end]
970    }
971    return $i
972}
973
974## ::tkcon::CmdSplit - splits multiple commands into a list
975# ARGS: cmd     - (possible) multiple command to separate
976# Returns:      constituent commands in a list
977##
978proc ::tkcon::CmdSplit {cmd} {
979    set inc {}
980    set cmds {}
981    foreach cmd [split [string trimleft $cmd] \n] {
982        if {[string compare {} $inc]} {
983            append inc \n$cmd
984        } else {
985            append inc [string trimleft $cmd]
986        }
987        if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
988            #set inc [string trimright $inc]
989            if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
990            set inc {}
991        }
992    }
993    if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
994    return $cmds
995}
996
997## ::tkcon::UniqueTag - creates a uniquely named tag, reusing names
998## Called by ::tkcon::EvalCmd
999# ARGS: w       - text widget
1000# Outputs:      tag name guaranteed unique in the widget
1001##
1002proc ::tkcon::UniqueTag {w} {
1003    set tags [$w tag names]
1004    set idx 0
1005    while {[lsearch -exact $tags _tag[incr idx]] != -1} {}
1006    return _tag$idx
1007}
1008
1009## ::tkcon::ConstrainBuffer - This limits the amount of data in the text widget
1010## Called by ::tkcon::Prompt and in tkcon proc buffer/console switch cases
1011# ARGS: w       - console text widget
1012#       size    - # of lines to constrain to
1013# Outputs:      may delete data in console widget
1014##
1015proc ::tkcon::ConstrainBuffer {w size} {
1016    if {[$w index end] > $size} {
1017        $w delete 1.0 [expr {int([$w index end])-$size}].0
1018    }
1019}
1020
1021## ::tkcon::Prompt - displays the prompt in the console widget
1022# ARGS: w       - console text widget
1023# Outputs:      prompt (specified in ::tkcon::OPT(prompt1)) to console
1024##
1025proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} {
1026    variable OPT
1027    variable PRIV
1028
1029    set w $PRIV(console)
1030    if {[string compare {} $pre]} { $w insert end $pre stdout }
1031    set i [$w index end-1c]
1032    if {!$OPT(showstatusbar)} {
1033        if {[string compare {} $PRIV(appname)]} {
1034            $w insert end ">$PRIV(appname)< " prompt
1035        }
1036        if {[string compare :: $PRIV(namesp)]} {
1037            $w insert end "<$PRIV(namesp)> " prompt
1038        }
1039    }
1040    if {[string compare {} $prompt]} {
1041        $w insert end $prompt prompt
1042    } else {
1043        $w insert end [EvalSlave subst $OPT(prompt1)] prompt
1044    }
1045    $w mark set output $i
1046    $w mark set insert end
1047    $w mark set limit insert
1048    $w mark gravity limit left
1049    if {[string compare {} $post]} { $w insert end $post stdin }
1050    ConstrainBuffer $w $OPT(buffer)
1051    set ::tkcon::PRIV(StatusCursor) [$w index insert]
1052    $w see end
1053}
1054
1055## ::tkcon::About - gives about info for tkcon
1056##
1057proc ::tkcon::About {} {
1058    variable OPT
1059    variable PRIV
1060    variable COLOR
1061
1062    set w $PRIV(base).about
1063    if {[winfo exists $w]} {
1064        wm deiconify $w
1065    } else {
1066        global tk_patchLevel tcl_patchLevel tcl_version
1067        toplevel $w
1068        wm title $w "About tkcon v$PRIV(version)"
1069        button $w.b -text Dismiss -command [list wm withdraw $w]
1070        text $w.text -height 9 -bd 1 -width 60 \
1071                -foreground $COLOR(stdin) \
1072                -background $COLOR(bg) \
1073                -font $OPT(font)
1074        pack $w.b -fill x -side bottom
1075        pack $w.text -fill both -side left -expand 1
1076        $w.text tag config center -justify center
1077        $w.text tag config title -justify center -font {Courier -18 bold}
1078        # strip down the RCS info displayed in the about box
1079        regexp {,v ([0-9\./: ]*)} $PRIV(RCS) -> RCS
1080        $w.text insert 1.0 "About tkcon v$PRIV(version)" title \
1081                "\n\nCopyright 1995-2001 Jeffrey Hobbs, $PRIV(email)\
1082                \nRelease Info: v$PRIV(version), CVS v$RCS\
1083                \nDocumentation available at:\n$PRIV(docs)\
1084                \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
1085        $w.text config -state disabled
1086    }
1087}
1088
1089## ::tkcon::InitMenus - inits the menubar and popup for the console
1090# ARGS: w       - console text widget
1091##
1092proc ::tkcon::InitMenus {w title} {
1093    variable OPT
1094    variable PRIV
1095    variable COLOR
1096    global tcl_platform
1097
1098    if {[catch {menu $w.pop -tearoff 0}]} {
1099        label $w.label -text "Menus not available in plugin mode"
1100        pack $w.label
1101        return
1102    }
1103    menu $w.context -tearoff 0 -disabledforeground $COLOR(disabled)
1104    set PRIV(context) $w.context
1105    set PRIV(popup) $w.pop
1106
1107    proc MenuButton {w m l} {
1108        $w add cascade -label $m -underline 0 -menu $w.$l
1109        return $w.$l
1110    }
1111
1112    foreach m [list File Console Edit Interp Prefs History Help] {
1113        set l [string tolower $m]
1114        MenuButton $w $m $l
1115        $w.pop add cascade -label $m -underline 0 -menu $w.pop.$l
1116    }
1117
1118    ## File Menu
1119    ##
1120    foreach m [list [menu $w.file -disabledforeground $COLOR(disabled)] \
1121            [menu $w.pop.file -disabledforeground $COLOR(disabled)]] {
1122        $m add command -label "Load File" -underline 0 -command ::tkcon::Load
1123        $m add cascade -label "Save ..."  -underline 0 -menu $m.save
1124        $m add separator
1125        $m add command -label "Quit" -underline 0 -accel Ctrl-q -command exit
1126
1127        ## Save Menu
1128        ##
1129        set s $m.save
1130        menu $s -disabledforeground $COLOR(disabled) -tearoff 0
1131        $s add command -label "All"     -underline 0 \
1132                -command {::tkcon::Save {} all}
1133        $s add command -label "History" -underline 0 \
1134                -command {::tkcon::Save {} history}
1135        $s add command -label "Stdin"   -underline 3 \
1136                -command {::tkcon::Save {} stdin}
1137        $s add command -label "Stdout"  -underline 3 \
1138                -command {::tkcon::Save {} stdout}
1139        $s add command -label "Stderr"  -underline 3 \
1140                -command {::tkcon::Save {} stderr}
1141    }
1142
1143    ## Console Menu
1144    ##
1145    foreach m [list [menu $w.console -disabledfore $COLOR(disabled)] \
1146            [menu $w.pop.console -disabledfore $COLOR(disabled)]] {
1147        $m add command -label "$title Console"  -state disabled
1148        $m add command -label "New Console"     -underline 0 -accel Ctrl-N \
1149                -command ::tkcon::New
1150        $m add command -label "Close Console"   -underline 0 -accel Ctrl-w \
1151                -command ::tkcon::Destroy
1152        $m add command -label "Clear Console"   -underline 1 -accel Ctrl-l \
1153                -command { clear; ::tkcon::Prompt }
1154        if {[string match unix $tcl_platform(platform)]} {
1155            $m add separator
1156            $m add command -label "Make Xauth Secure" -und 5 \
1157                    -command ::tkcon::XauthSecure
1158        }
1159        $m add separator
1160        $m add cascade -label "Attach To ..."   -underline 0 -menu $m.attach
1161
1162        ## Attach Console Menu
1163        ##
1164        set sub [menu $m.attach -disabledforeground $COLOR(disabled)]
1165        $sub add cascade -label "Interpreter"   -underline 0 -menu $sub.apps
1166        $sub add cascade -label "Namespace" -underline 1 -menu $sub.name
1167        $sub add cascade -label "Socket" -underline 1 -menu $sub.sock \
1168                -state [expr {([info tclversion] < 8.3)?"disabled":"normal"}]
1169
1170        ## Attach Console Menu
1171        ##
1172        menu $sub.apps -disabledforeground $COLOR(disabled) \
1173                -postcommand [list ::tkcon::AttachMenu $sub.apps]
1174
1175        ## Attach Namespace Menu
1176        ##
1177        menu $sub.name -disabledforeground $COLOR(disabled) -tearoff 0 \
1178                -postcommand [list ::tkcon::NamespaceMenu $sub.name]
1179
1180        if {$::tcl_version >= 8.3} {
1181            # This uses [file channels] to create the menu, so we only
1182            # want it for newer versions of Tcl.
1183
1184            ## Attach Socket Menu
1185            ##
1186            menu $sub.sock -disabledforeground $COLOR(disabled) -tearoff 0 \
1187                    -postcommand [list ::tkcon::SocketMenu $sub.sock]
1188        }
1189
1190        ## Attach Display Menu
1191        ##
1192        if {![string compare "unix" $tcl_platform(platform)]} {
1193            $sub add cascade -label "Display" -und 1 -menu $sub.disp
1194            menu $sub.disp -disabledforeground $COLOR(disabled) \
1195                    -tearoff 0 \
1196                    -postcommand [list ::tkcon::DisplayMenu $sub.disp]
1197        }
1198    }
1199
1200    ## Edit Menu
1201    ##
1202    set text $PRIV(console)
1203    foreach m [list [menu $w.edit] [menu $w.pop.edit]] {
1204        $m add command -label "Cut"   -underline 2 -accel Ctrl-x \
1205                -command [list ::tkcon::Cut $text]
1206        $m add command -label "Copy"  -underline 0 -accel Ctrl-c \
1207                -command [list ::tkcon::Copy $text]
1208        $m add command -label "Paste" -underline 0 -accel Ctrl-v \
1209                 -command [list ::tkcon::Paste $text]
1210        $m add separator
1211        $m add command -label "Find"  -underline 0 -accel Ctrl-F \
1212                -command [list ::tkcon::FindBox $text]
1213    }
1214
1215    ## Interp Menu
1216    ##
1217    foreach m [list $w.interp $w.pop.interp] {
1218        menu $m -disabledforeground $COLOR(disabled) \
1219                -postcommand [list ::tkcon::InterpMenu $m]
1220    }
1221
1222    ## Prefs Menu
1223    ##
1224    foreach m [list [menu $w.prefs] [menu $w.pop.prefs]] {
1225        $m add check -label "Brace Highlighting" \
1226                -underline 0 -variable ::tkcon::OPT(lightbrace)
1227        $m add check -label "Command Highlighting" \
1228                -underline 0 -variable ::tkcon::OPT(lightcmd)
1229        $m add check -label "History Substitution" \
1230                -underline 0 -variable ::tkcon::OPT(subhistory)
1231        $m add check -label "Hot Errors" \
1232                -underline 0 -variable ::tkcon::OPT(hoterrors)
1233        $m add check -label "Non-Tcl Attachments" \
1234                -underline 0 -variable ::tkcon::OPT(nontcl)
1235        $m add check -label "Calculator Mode" \
1236                -underline 1 -variable ::tkcon::OPT(calcmode)
1237        $m add check -label "Show Multiple Matches" \
1238                -underline 0 -variable ::tkcon::OPT(showmultiple)
1239        $m add check -label "Show Menubar" \
1240                -underline 5 -variable ::tkcon::OPT(showmenu) \
1241                -command {$::tkcon::PRIV(root) configure -menu [expr \
1242                {$::tkcon::OPT(showmenu) ? $::tkcon::PRIV(menubar) : {}}]}
1243        $m add check -label "Show Statusbar" \
1244                -underline 5 -variable ::tkcon::OPT(showstatusbar) \
1245                -command {
1246            if {$::tkcon::OPT(showstatusbar)} {
1247                pack $::tkcon::PRIV(statusbar) -side bottom -fill x \
1248                        -before $::tkcon::PRIV(scrolly)
1249            } else { pack forget $::tkcon::PRIV(statusbar) }
1250        }
1251        $m add cascade -label "Scrollbar" -underline 2 -menu $m.scroll
1252
1253        ## Scrollbar Menu
1254        ##
1255        set m [menu $m.scroll -tearoff 0]
1256        $m add radio -label "Left" -value left \
1257                -variable ::tkcon::OPT(scrollypos) \
1258                -command { pack config $::tkcon::PRIV(scrolly) -side left }
1259        $m add radio -label "Right" -value right \
1260                -variable ::tkcon::OPT(scrollypos) \
1261                -command { pack config $::tkcon::PRIV(scrolly) -side right }
1262    }
1263
1264    ## History Menu
1265    ##
1266    foreach m [list $w.history $w.pop.history] {
1267        menu $m -disabledforeground $COLOR(disabled) \
1268                -postcommand [list ::tkcon::HistoryMenu $m]
1269    }
1270
1271    ## Help Menu
1272    ##
1273    foreach m [list [menu $w.help] [menu $w.pop.help]] {
1274        $m add command -label "About " -underline 0 -accel Ctrl-A \
1275                -command ::tkcon::About
1276        $m add command -label "Retrieve Latest Version" -underline 0 \
1277                -command ::tkcon::Retrieve
1278    }
1279}
1280
1281## ::tkcon::HistoryMenu - dynamically build the menu for attached interpreters
1282##
1283# ARGS: m       - menu widget
1284##
1285proc ::tkcon::HistoryMenu m {
1286    variable PRIV
1287
1288    if {![winfo exists $m]} return
1289    set id [EvalSlave history nextid]
1290    if {$PRIV(histid)==$id} return
1291    set PRIV(histid) $id
1292    $m delete 0 end
1293    while {($id>1) && ($id>$PRIV(histid)-10) && \
1294            ![catch {EvalSlave history event [incr id -1]} tmp]} {
1295        set lbl $tmp
1296        if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... }
1297        $m add command -label "$id: $lbl" -command "
1298        $::tkcon::PRIV(console) delete limit end
1299        $::tkcon::PRIV(console) insert limit [list $tmp]
1300        $::tkcon::PRIV(console) see end
1301        ::tkcon::Eval $::tkcon::PRIV(console)"
1302    }
1303}
1304
1305## ::tkcon::InterpMenu - dynamically build the menu for attached interpreters
1306##
1307# ARGS: w       - menu widget
1308##
1309proc ::tkcon::InterpMenu w {
1310    variable OPT
1311    variable PRIV
1312    variable COLOR
1313
1314    if {![winfo exists $w]} return
1315    $w delete 0 end
1316    foreach {app type} [Attach] break
1317    $w add command -label "[string toupper $type]: $app" -state disabled
1318    if {($OPT(nontcl) && [string match interp $type]) || $PRIV(deadapp)} {
1319        $w add separator
1320        $w add command -state disabled -label "Communication disabled to"
1321        $w add command -state disabled -label "dead or non-Tcl interps"
1322        return
1323    }
1324
1325    ## Show Last Error
1326    ##
1327    $w add separator
1328    $w add command -label "Show Last Error" \
1329            -command [list tkcon error $app $type]
1330
1331    ## Packages Cascaded Menu
1332    ##
1333    $w add separator
1334    $w add cascade -label Packages -underline 0 -menu $w.pkg
1335    set m $w.pkg
1336    if {![winfo exists $m]} {
1337        menu $m -tearoff no -disabledforeground $COLOR(disabled) \
1338                -postcommand [list ::tkcon::PkgMenu $m $app $type]
1339    }
1340
1341    ## State Checkpoint/Revert
1342    ##
1343    $w add separator
1344    $w add command -label "Checkpoint State" \
1345            -command [list ::tkcon::StateCheckpoint $app $type]
1346    $w add command -label "Revert State" \
1347            -command [list ::tkcon::StateRevert $app $type]
1348    $w add command -label "View State Change" \
1349            -command [list ::tkcon::StateCompare $app $type]
1350
1351    ## Init Interp
1352    ##
1353    $w add separator
1354    $w add command -label "Send tkcon Commands" \
1355            -command [list ::tkcon::InitInterp $app $type]
1356}
1357
1358## ::tkcon::PkgMenu - fill in  in the applications sub-menu
1359## with a list of all the applications that currently exist.
1360##
1361proc ::tkcon::PkgMenu {m app type} {
1362    # just in case stuff has been added to the auto_path
1363    # we have to make sure that the errorInfo doesn't get screwed up
1364    EvalAttached {
1365        set __tkcon_error $errorInfo
1366        catch {package require bogus-package-name}
1367        set errorInfo ${__tkcon_error}
1368        unset __tkcon_error
1369    }
1370    $m delete 0 end
1371    foreach pkg [EvalAttached [list info loaded {}]] {
1372        set loaded([lindex $pkg 1]) [package provide $pkg]
1373    }
1374    foreach pkg [lremove [EvalAttached {package names}] Tcl] {
1375        set version [EvalAttached [list package provide $pkg]]
1376        if {[string compare {} $version]} {
1377            set loaded($pkg) $version
1378        } elseif {![info exists loaded($pkg)]} {
1379            set loadable($pkg) [list package require $pkg]
1380        }
1381    }
1382    foreach pkg [EvalAttached {info loaded}] {
1383        set pkg [lindex $pkg 1]
1384        if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} {
1385            set loadable($pkg) [list load {} $pkg]
1386        }
1387    }
1388    set npkg 0
1389    foreach pkg [lsort -dictionary [array names loadable]] {
1390        foreach v [EvalAttached [list package version $pkg]] {
1391            set brkcol [expr {([incr npkg]%16)==0}]
1392            $m add command -label "Load $pkg ($v)" -command \
1393                    "::tkcon::EvalOther [list $app] $type $loadable($pkg) $v" \
1394                    -columnbreak $brkcol
1395        }
1396    }
1397    if {[info exists loaded] && [info exists loadable]} {
1398        $m add separator
1399    }
1400    foreach pkg [lsort -dictionary [array names loaded]] {
1401        $m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled
1402    }
1403}
1404
1405## ::tkcon::AttachMenu - fill in  in the applications sub-menu
1406## with a list of all the applications that currently exist.
1407##
1408proc ::tkcon::AttachMenu m {
1409    variable OPT
1410    variable PRIV
1411
1412    array set interps [set tmp [Interps]]
1413    foreach {i j} $tmp { set tknames($j) {} }
1414
1415    $m delete 0 end
1416    set cmd {::tkcon::Prompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1417    $m add radio -label {None (use local slave) } -accel Ctrl-1 \
1418            -variable ::tkcon::PRIV(app) \
1419            -value [concat $::tkcon::PRIV(name) $::tkcon::OPT(exec)] \
1420            -command "::tkcon::Attach {}; $cmd"
1421    $m add separator
1422    $m add command -label "Foreign Tk Interpreters" -state disabled
1423    foreach i [lsort [lremove [winfo interps] [array names tknames]]] {
1424        $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \
1425                -command "::tkcon::Attach [list $i] interp; $cmd"
1426    }
1427    $m add separator
1428
1429    $m add command -label "tkcon Interpreters" -state disabled
1430    foreach i [lsort [array names interps]] {
1431        if {[string match {} $interps($i)]} { set interps($i) "no Tk" }
1432        if {[regexp {^Slave[0-9]+} $i]} {
1433            set opts [list -label "$i ($interps($i))" \
1434                    -variable ::tkcon::PRIV(app) -value $i \
1435                    -command "::tkcon::Attach [list $i] slave; $cmd"]
1436            if {[string match $PRIV(name) $i]} {
1437                append opts " -accel Ctrl-2"
1438            }
1439            eval $m add radio $opts
1440        } else {
1441            set name [concat Main $i]
1442            if {[string match Main $name]} {
1443                $m add radio -label "$name ($interps($i))" -accel Ctrl-3 \
1444                        -variable ::tkcon::PRIV(app) -value Main \
1445                        -command "::tkcon::Attach [list $name] slave; $cmd"
1446            } else {
1447                $m add radio -label "$name ($interps($i))" \
1448                        -variable ::tkcon::PRIV(app) -value $i \
1449                        -command "::tkcon::Attach [list $name] slave; $cmd"
1450            }
1451        }
1452    }
1453}
1454
1455## Displays Cascaded Menu
1456##
1457proc ::tkcon::DisplayMenu m {
1458    $m delete 0 end
1459    set cmd {::tkcon::Prompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1460
1461    $m add command -label "New Display" -command ::tkcon::NewDisplay
1462    foreach disp [Display] {
1463        $m add separator
1464        $m add command -label $disp -state disabled
1465        set res [Display $disp]
1466        set win [lindex $res 0]
1467        foreach i [lsort [lindex $res 1]] {
1468            $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \
1469                    -command "::tkcon::Attach [list $i] [list dpy:$win]; $cmd"
1470        }
1471    }
1472}
1473
1474## Sockets Cascaded Menu
1475##
1476proc ::tkcon::SocketMenu m {
1477    $m delete 0 end
1478    set cmd {::tkcon::Prompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1479
1480    $m add command -label "Create Connection" \
1481            -command "::tkcon::NewSocket; $cmd"
1482    foreach sock [file channels sock*] {
1483        $m add radio -label $sock -variable ::tkcon::PRIV(app) -value $sock \
1484                -command "::tkcon::Attach $sock socket; $cmd"
1485    }
1486}
1487
1488## Namepaces Cascaded Menu
1489##
1490proc ::tkcon::NamespaceMenu m {
1491    variable PRIV
1492    variable OPT
1493
1494    $m delete 0 end
1495    if {($PRIV(deadapp) || [string match socket $PRIV(apptype)] || \
1496            ($OPT(nontcl) && [string match interp $PRIV(apptype)]))} {
1497        $m add command -label "No Namespaces" -state disabled
1498        return
1499    }
1500
1501    ## Same command as for ::tkcon::AttachMenu items
1502    set cmd {::tkcon::Prompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1503
1504    set names [lsort [Namespaces ::]]
1505    if {[llength $names] > $OPT(maxmenu)} {
1506        $m add command -label "Attached to $PRIV(namesp)" -state disabled
1507        $m add command -label "List Namespaces" \
1508                -command [list ::tkcon::NamespacesList $names]
1509    } else {
1510        foreach i $names {
1511            if {[string match :: $i]} {
1512                $m add radio -label "Main" -value $i \
1513                        -variable ::tkcon::PRIV(namesp) \
1514                        -command "::tkcon::AttachNamespace [list $i]; $cmd"
1515            } else {
1516                $m add radio -label $i -value $i \
1517                        -variable ::tkcon::PRIV(namesp) \
1518                        -command "::tkcon::AttachNamespace [list $i]; $cmd"
1519            }
1520        }
1521    }
1522}
1523
1524## Namepaces List
1525##
1526proc ::tkcon::NamespacesList {names} {
1527    variable PRIV
1528
1529    set f $PRIV(base).namespaces
1530    catch {destroy $f}
1531    toplevel $f
1532    listbox $f.names -width 30 -height 15 -selectmode single \
1533            -yscrollcommand [list $f.scrollv set] \
1534            -xscrollcommand [list $f.scrollh set]
1535    scrollbar $f.scrollv -command [list $f.names yview]
1536    scrollbar $f.scrollh -command [list $f.names xview] -orient horizontal
1537    frame $f.buttons
1538    button $f.cancel -text "Cancel" -command [list destroy $f]
1539
1540    grid $f.names $f.scrollv -sticky nesw
1541    grid $f.scrollh -sticky ew
1542    grid $f.buttons -sticky nesw
1543    grid $f.cancel -in $f.buttons -pady 6
1544
1545    grid columnconfigure $f 0 -weight 1
1546    grid rowconfigure $f  0 -weight 1
1547    #fill the listbox
1548    foreach i $names {
1549        if {[string match :: $i]} {
1550            $f.names insert 0 Main
1551        } else {
1552            $f.names insert end $i
1553        }
1554    }
1555    #Bindings
1556    bind $f.names <Double-1> {
1557        ## Catch in case the namespace disappeared on us
1558        catch { ::tkcon::AttachNamespace [%W get [%W nearest %y]] }
1559        ::tkcon::Prompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
1560        destroy [winfo toplevel %W]
1561    }
1562}
1563
1564# ::tkcon::XauthSecure --
1565#
1566#   This removes all the names in the xhost list, and secures
1567#   the display for Tk send commands.  Of course, this prevents
1568#   what might have been otherwise allowable X connections
1569#
1570# Arguments:
1571#   none
1572# Results:
1573#   Returns nothing
1574#
1575proc ::tkcon::XauthSecure {} {
1576    global tcl_platform
1577
1578    if {[string compare unix $tcl_platform(platform)]} {
1579        # This makes no sense outside of Unix
1580        return
1581    }
1582    set hosts [exec xhost]
1583    # the first line is info only
1584    foreach host [lrange [split $hosts \n] 1 end] {
1585        exec xhost -$host
1586    }
1587    exec xhost -
1588    tk_messageBox -title "Xhost secured" -message "Xhost secured" -icon info
1589}
1590
1591## ::tkcon::FindBox - creates minimal dialog interface to ::tkcon::Find
1592# ARGS: w       - text widget
1593#       str     - optional seed string for ::tkcon::PRIV(find)
1594##
1595proc ::tkcon::FindBox {w {str {}}} {
1596    variable PRIV
1597
1598    set base $PRIV(base).find
1599    if {![winfo exists $base]} {
1600        toplevel $base
1601        wm withdraw $base
1602        wm title $base "tkcon Find"
1603
1604        pack [frame $base.f] -fill x -expand 1
1605        label $base.f.l -text "Find:"
1606        entry $base.f.e -textvariable ::tkcon::PRIV(find)
1607        pack [frame $base.opt] -fill x
1608        checkbutton $base.opt.c -text "Case Sensitive" \
1609                -variable ::tkcon::PRIV(find,case)
1610        checkbutton $base.opt.r -text "Use Regexp" -variable ::tkcon::PRIV(find,reg)
1611        pack $base.f.l -side left
1612        pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
1613        pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
1614        pack [frame $base.btn] -fill both
1615        button $base.btn.fnd -text "Find" -width 6
1616        button $base.btn.clr -text "Clear" -width 6
1617        button $base.btn.dis -text "Dismiss" -width 6
1618        eval pack [winfo children $base.btn] -padx 4 -pady 2 \
1619                -side left -fill both
1620
1621        focus $base.f.e
1622
1623        bind $base.f.e <Return> [list $base.btn.fnd invoke]
1624        bind $base.f.e <Escape> [list $base.btn.dis invoke]
1625    }
1626    $base.btn.fnd config -command "::tkcon::Find [list $w] \$::tkcon::PRIV(find) \
1627            -case \$::tkcon::PRIV(find,case) -reg \$::tkcon::PRIV(find,reg)"
1628    $base.btn.clr config -command "
1629    [list $w] tag remove find 1.0 end
1630    set ::tkcon::PRIV(find) {}
1631    "
1632    $base.btn.dis config -command "
1633    [list $w] tag remove find 1.0 end
1634    wm withdraw [list $base]
1635    "
1636    if {[string compare {} $str]} {
1637        set PRIV(find) $str
1638        $base.btn.fnd invoke
1639    }
1640
1641    if {[string compare normal [wm state $base]]} {
1642        wm deiconify $base
1643    } else { raise $base }
1644    $base.f.e select range 0 end
1645}
1646
1647## ::tkcon::Find - searches in text widget $w for $str and highlights it
1648## If $str is empty, it just deletes any highlighting
1649# ARGS: w       - text widget
1650#       str     - string to search for
1651#       -case   TCL_BOOLEAN     whether to be case sensitive    DEFAULT: 0
1652#       -regexp TCL_BOOLEAN     whether to use $str as pattern  DEFAULT: 0
1653##
1654proc ::tkcon::Find {w str args} {
1655    $w tag remove find 1.0 end
1656    set truth {^(1|yes|true|on)$}
1657    set opts  {}
1658    foreach {key val} $args {
1659        switch -glob -- $key {
1660            -c* { if {[regexp -nocase $truth $val]} { set case 1 } }
1661            -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } }
1662            default { return -code error "Unknown option $key" }
1663        }
1664    }
1665    if {![info exists case]} { lappend opts -nocase }
1666    if {[string match {} $str]} return
1667    $w mark set findmark 1.0
1668    while {[string compare {} [set ix [eval $w search $opts -count numc -- \
1669            [list $str] findmark end]]]} {
1670        $w tag add find $ix ${ix}+${numc}c
1671        $w mark set findmark ${ix}+1c
1672    }
1673    $w tag configure find -background $::tkcon::COLOR(blink)
1674    catch {$w see find.first}
1675    return [expr {[llength [$w tag ranges find]]/2}]
1676}
1677
1678## ::tkcon::Attach - called to attach tkcon to an interpreter
1679# ARGS: name    - application name to which tkcon sends commands
1680#                 This is either a slave interperter name or tk appname.
1681#       type    - (slave|interp) type of interpreter we're attaching to
1682#                 slave means it's a tkcon interpreter
1683#                 interp means we'll need to 'send' to it.
1684# Results:      ::tkcon::EvalAttached is recreated to evaluate in the
1685#               appropriate interpreter
1686##
1687proc ::tkcon::Attach {{name <NONE>} {type slave}} {
1688    variable PRIV
1689    variable OPT
1690
1691    if {[llength [info level 0]] == 1} {
1692        # no args were specified, return the attach info instead
1693        if {[string match {} $PRIV(appname)]} {
1694            return [list [concat $PRIV(name) $OPT(exec)] $PRIV(apptype)]
1695        } else {
1696            return [list $PRIV(appname) $PRIV(apptype)]
1697        }
1698    }
1699    set path [concat $PRIV(name) $OPT(exec)]
1700
1701    set PRIV(displayWin) .
1702    if {[string match namespace $type]} {
1703        return [uplevel 1 ::tkcon::AttachNamespace $name]
1704    } elseif {[string match dpy:* $type]} {
1705        set PRIV(displayWin) [string range $type 4 end]
1706    } elseif {[string match sock* $type]} {
1707        global tcl_version
1708        if {[catch {eof $name} res]} {
1709            return -code error "No known channel \"$name\""
1710        } elseif {$res} {
1711            catch {close $name}
1712            return -code error "Channel \"$name\" returned EOF"
1713        }
1714        set app $name
1715        set type socket
1716    } elseif {[string compare {} $name]} {
1717        array set interps [Interps]
1718        if {[string match {[Mm]ain} [lindex $name 0]]} {
1719            set name [lrange $name 1 end]
1720        }
1721        if {[string match $path $name]} {
1722            set name {}
1723            set app $path
1724            set type slave
1725        } elseif {[info exists interps($name)]} {
1726            if {[string match {} $name]} { set name Main; set app Main }
1727            set type slave
1728        } elseif {[interp exists $name]} {
1729            set name [concat $PRIV(name) $name]
1730            set type slave
1731        } elseif {[interp exists [concat $OPT(exec) $name]]} {
1732            set name [concat $path $name]
1733            set type slave
1734        } elseif {[lsearch -exact [winfo interps] $name] > -1} {
1735            if {[EvalSlave info exists tk_library] \
1736                    && [string match $name [EvalSlave tk appname]]} {
1737                set name {}
1738                set app $path
1739                set type slave
1740            } elseif {[set i [lsearch -exact \
1741                    [Main set ::tkcon::PRIV(interps)] $name]] != -1} {
1742                set name [lindex [Main set ::tkcon::PRIV(slaves)] $i]
1743                if {[string match {[Mm]ain} $name]} { set app Main }
1744                set type slave
1745            } else {
1746                set type interp
1747            }
1748        } else {
1749            return -code error "No known interpreter \"$name\""
1750        }
1751    } else {
1752        set app $path
1753    }
1754    if {![info exists app]} { set app $name }
1755    array set PRIV [list app $app appname $name apptype $type deadapp 0]
1756
1757    ## ::tkcon::EvalAttached - evaluates the args in the attached interp
1758    ## args should be passed to this procedure as if they were being
1759    ## passed to the 'eval' procedure.  This procedure is dynamic to
1760    ## ensure evaluation occurs in the right interp.
1761    # ARGS:     args    - the command and args to evaluate
1762    ##
1763    switch -glob -- $type {
1764        slave {
1765            if {[string match {} $name]} {
1766                interp alias {} ::tkcon::EvalAttached {} \
1767                        ::tkcon::EvalSlave uplevel \#0
1768            } elseif {[string match Main $PRIV(app)]} {
1769                interp alias {} ::tkcon::EvalAttached {} ::tkcon::Main
1770            } elseif {[string match $PRIV(name) $PRIV(app)]} {
1771                interp alias {} ::tkcon::EvalAttached {} uplevel \#0
1772            } else {
1773                interp alias {} ::tkcon::EvalAttached {} \
1774                        ::tkcon::Slave $::tkcon::PRIV(app)
1775            }
1776        }
1777        sock* {
1778            interp alias {} ::tkcon::EvalAttached {} \
1779                    ::tkcon::EvalSlave uplevel \#0
1780            # The file event will just puts whatever data is found
1781            # into the interpreter
1782            fconfigure $name -buffering line -blocking 0
1783            fileevent $name readable ::tkcon::EvalSocketEvent
1784        }
1785        dpy:* -
1786        interp {
1787            if {$OPT(nontcl)} {
1788                interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSlave
1789                set PRIV(namesp) ::
1790            } else {
1791                interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSend
1792            }
1793        }
1794        default {
1795            return -code error "[lindex [info level 0] 0] did not specify\
1796                    a valid type: must be slave or interp"
1797        }
1798    }
1799    if {[string match slave $type] || \
1800            (!$OPT(nontcl) && [regexp {^(interp|dpy)} $type])} {
1801        set PRIV(namesp) ::
1802    }
1803    set PRIV(StatusAttach) "$PRIV(app) ($PRIV(apptype))"
1804    return
1805}
1806
1807## ::tkcon::AttachNamespace - called to attach tkcon to a namespace
1808# ARGS: name    - namespace name in which tkcon should eval commands
1809# Results:      ::tkcon::EvalAttached will be modified
1810##
1811proc ::tkcon::AttachNamespace { name } {
1812    variable PRIV
1813    variable OPT
1814
1815    if {($OPT(nontcl) && [string match interp $PRIV(apptype)]) \
1816            || [string match socket $PRIV(apptype)] \
1817            || $PRIV(deadapp)} {
1818        return -code error "can't attach to namespace in attached environment"
1819    }
1820    if {[string match Main $name]} {set name ::}
1821    if {[string compare {} $name] && \
1822            [lsearch [Namespaces ::] $name] == -1} {
1823        return -code error "No known namespace \"$name\""
1824    }
1825    if {[regexp {^(|::)$} $name]} {
1826        ## If name=={} || ::, we want the primary namespace
1827        set alias [interp alias {} ::tkcon::EvalAttached]
1828        if {[string match ::tkcon::EvalNamespace* $alias]} {
1829            eval [list interp alias {} ::tkcon::EvalAttached {}] \
1830                    [lindex $alias 1]
1831        }
1832        set name ::
1833    } else {
1834        interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalNamespace \
1835                [interp alias {} ::tkcon::EvalAttached] [list $name]
1836    }
1837    set PRIV(namesp) $name
1838    set PRIV(StatusAttach) "$PRIV(app) $PRIV(namesp) ($PRIV(apptype))"
1839}
1840
1841## ::tkcon::NewSocket - called to create a socket to connect to
1842# ARGS: none
1843# Results:      It will create a socket, and attach if requested
1844##
1845proc ::tkcon::NewSocket {} {
1846    variable PRIV
1847
1848    set t $PRIV(base).newsock
1849    if {![winfo exists $t]} {
1850        toplevel $t
1851        wm withdraw $t
1852        wm title $t "tkcon Create Socket"
1853        label $t.lhost -text "Host: "
1854        entry $t.host -width 20
1855        label $t.lport -text "Port: "
1856        entry $t.port -width 4
1857        button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1}
1858        bind $t.host <Return> [list focus $t.port]
1859        bind $t.port <Return> [list focus $t.ok]
1860        bind $t.ok   <Return> [list $t.ok invoke]
1861        grid $t.lhost $t.host $t.lport $t.port -sticky ew
1862        grid $t.ok      -       -       -        -sticky ew
1863        grid columnconfig $t 1 -weight 1
1864        grid rowconfigure $t 1 -weight 1
1865        wm transient $t $PRIV(root)
1866        wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
1867                reqwidth $t]) / 2}]+[expr {([winfo \
1868                screenheight $t]-[winfo reqheight $t]) / 2}]
1869    }
1870    #$t.host delete 0 end
1871    #$t.port delete 0 end
1872    wm deiconify $t
1873    raise $t
1874    grab $t
1875    focus $t.host
1876    vwait ::tkcon::PRIV(grab)
1877    grab release $t
1878    wm withdraw $t
1879    set host [$t.host get]
1880    set port [$t.port get]
1881    if {$host == ""} { return }
1882    if {[catch {
1883        set sock [socket $host $port]
1884    } err]} {
1885        tk_messageBox -title "Socket Connection Error" \
1886                -message "Unable to connect to \"$host:$port\":\n$err" \
1887                -icon error -type ok
1888    } else {
1889        Attach $sock socket
1890    }
1891}
1892
1893## ::tkcon::Load - sources a file into the console
1894## The file is actually sourced in the currently attached's interp
1895# ARGS: fn      - (optional) filename to source in
1896# Returns:      selected filename ({} if nothing was selected)
1897##
1898proc ::tkcon::Load { {fn ""} } {
1899    set types {
1900        {{Tcl Files}    {.tcl .tk}}
1901        {{Text Files}   {.txt}}
1902        {{All Files}    *}
1903    }
1904    if {
1905        [string match {} $fn] &&
1906        ([catch {tk_getOpenFile -filetypes $types \
1907            -title "Source File"} fn] || [string match {} $fn])
1908    } { return }
1909    EvalAttached [list source $fn]
1910}
1911
1912## ::tkcon::Save - saves the console or other widget buffer to a file
1913## This does not eval in a slave because it's not necessary
1914# ARGS: w       - console text widget
1915#       fn      - (optional) filename to save to
1916##
1917proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } {
1918    variable PRIV
1919
1920    if {![regexp -nocase {^(all|history|stdin|stdout|stderr|widget)$} $type]} {
1921        array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel }
1922        ## Allow user to specify what kind of stuff to save
1923        set type [tk_dialog $PRIV(base).savetype "Save Type" \
1924                "What part of the text do you want to save?" \
1925                questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)]
1926        if {$type == 5 || $type == -1} return
1927        set type $s($type)
1928    }
1929    if {[string match {} $fn]} {
1930        set types {
1931            {{Tcl Files}        {.tcl .tk}}
1932            {{Text Files}       {.txt}}
1933            {{All Files}        *}
1934        }
1935        if {[catch {tk_getSaveFile -defaultextension .tcl -filetypes $types \
1936                -title "Save $type"} fn] || [string match {} $fn]} return
1937    }
1938    set type [string tolower $type]
1939    switch $type {
1940        stdin - stdout - stderr {
1941            set data {}
1942            foreach {first last} [$PRIV(console) tag ranges $type] {
1943                lappend data [$PRIV(console) get $first $last]
1944            }
1945            set data [join $data \n]
1946        }
1947        history         { set data [tkcon history] }
1948        all - default   { set data [$PRIV(console) get 1.0 end-1c] }
1949        widget          {
1950            set data [$opt get 1.0 end-1c]
1951        }
1952    }
1953    if {[catch {open $fn $mode} fid]} {
1954        return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
1955    }
1956    puts -nonewline $fid $data
1957    close $fid
1958}
1959
1960## ::tkcon::MainInit
1961## This is only called for the main interpreter to include certain procs
1962## that we don't want to include (or rather, just alias) in slave interps.
1963##
1964proc ::tkcon::MainInit {} {
1965    variable PRIV
1966
1967    if {![info exists PRIV(slaves)]} {
1968        array set PRIV [list slave 0 slaves Main name {} \
1969                interps [list [tk appname]]]
1970    }
1971    interp alias {} ::tkcon::Main {} ::tkcon::InterpEval Main
1972    interp alias {} ::tkcon::Slave {} ::tkcon::InterpEval
1973
1974    proc ::tkcon::GetSlaveNum {} {
1975        set i -1
1976        while {[interp exists Slave[incr i]]} {
1977            # oh my god, an empty loop!
1978        }
1979        return $i
1980    }
1981
1982    ## ::tkcon::New - create new console window
1983    ## Creates a slave interpreter and sources in this script.
1984    ## All other interpreters also get a command to eval function in the
1985    ## new interpreter.
1986    ##
1987    proc ::tkcon::New {} {
1988        variable PRIV
1989        global argv0 argc argv
1990
1991        set tmp [interp create Slave[GetSlaveNum]]
1992        lappend PRIV(slaves) $tmp
1993        load {} Tk $tmp
1994        lappend PRIV(interps) [$tmp eval [list tk appname \
1995                "[tk appname] $tmp"]]
1996        if {[info exist argv0]} {$tmp eval [list set argv0 $argv0]}
1997        $tmp eval set argc $argc
1998        $tmp eval [list set argv $argv]
1999        $tmp eval [list namespace eval ::tkcon {}]
2000        $tmp eval [list set ::tkcon::PRIV(name) $tmp]
2001        $tmp eval [list set ::tkcon::PRIV(SCRIPT) $::tkcon::PRIV(SCRIPT)]
2002        $tmp alias exit                         ::tkcon::Exit $tmp
2003        $tmp alias ::tkcon::Destroy             ::tkcon::Destroy $tmp
2004        $tmp alias ::tkcon::New                 ::tkcon::New
2005        $tmp alias ::tkcon::Main                ::tkcon::InterpEval Main
2006        $tmp alias ::tkcon::Slave               ::tkcon::InterpEval
2007        $tmp alias ::tkcon::Interps             ::tkcon::Interps
2008        $tmp alias ::tkcon::NewDisplay          ::tkcon::NewDisplay
2009        $tmp alias ::tkcon::Display             ::tkcon::Display
2010        $tmp alias ::tkcon::StateCheckpoint     ::tkcon::StateCheckpoint
2011        $tmp alias ::tkcon::StateCleanup        ::tkcon::StateCleanup
2012        $tmp alias ::tkcon::StateCompare        ::tkcon::StateCompare
2013        $tmp alias ::tkcon::StateRevert         ::tkcon::StateRevert
2014        $tmp eval {
2015            if [catch {source -rsrc tkcon}] { source $::tkcon::PRIV(SCRIPT) }
2016        }
2017        return $tmp
2018    }
2019
2020    ## ::tkcon::Exit - full exit OR destroy slave console
2021    ## This proc should only be called in the main interpreter from a slave.
2022    ## The master determines whether we do a full exit or just kill the slave.
2023    ##
2024    proc ::tkcon::Exit {slave args} {
2025        variable PRIV
2026        variable OPT
2027
2028        ## Slave interpreter exit request
2029        if {[string match exit $OPT(slaveexit)]} {
2030            ## Only exit if it specifically is stated to do so
2031            uplevel 1 exit $args
2032        }
2033        ## Otherwise we will delete the slave interp and associated data
2034        set name [InterpEval $slave]
2035        set PRIV(interps) [lremove $PRIV(interps) [list $name]]
2036        set PRIV(slaves)  [lremove $PRIV(slaves) [list $slave]]
2037        interp delete $slave
2038        StateCleanup $slave
2039        return
2040    }
2041
2042    ## ::tkcon::Destroy - destroy console window
2043    ## This proc should only be called by the main interpreter.  If it is
2044    ## called from there, it will ask before exiting tkcon.  All others
2045    ## (slaves) will just have their slave interpreter deleted, closing them.
2046    ##
2047    proc ::tkcon::Destroy {{slave {}}} {
2048        variable PRIV
2049
2050        if {[string match {} $slave]} {
2051            ## Main interpreter close request
2052            if {[tk_dialog $PRIV(base).destroyme {Quit tkcon?} \
2053                    {Closing the Main console will quit tkcon} \
2054                    warning 0 "Don't Quit" "Quit tkcon"]} exit
2055        } else {
2056            ## Slave interpreter close request
2057            set name [InterpEval $slave]
2058            set PRIV(interps) [lremove $PRIV(interps) [list $name]]
2059            set PRIV(slaves)  [lremove $PRIV(slaves) [list $slave]]
2060            interp delete $slave
2061        }
2062        StateCleanup $slave
2063        return
2064    }
2065
2066    ## We want to do a couple things before exiting...
2067    if {[catch {rename ::exit ::tkcon::FinalExit} err]} {
2068        puts stderr "tkcon might panic:\n$err"
2069    }
2070    proc ::exit args {
2071        if {$::tkcon::OPT(usehistory)} {
2072            if {[catch {open $::tkcon::PRIV(histfile) w} fid]} {
2073                puts stderr "unable to save history file:\n$fid"
2074                # pause a moment, because we are about to die finally...
2075                after 1000
2076            } else {
2077                set max [::tkcon::EvalSlave history nextid]
2078                set id [expr {$max - $::tkcon::OPT(history)}]
2079                if {$id < 1} { set id 1 }
2080                ## FIX: This puts history in backwards!!
2081                while {($id < $max) && \
2082                        ![catch {::tkcon::EvalSlave history event $id} cmd]} {
2083                    if {[string compare {} $cmd]} {
2084                        puts $fid "::tkcon::EvalSlave history add [list $cmd]"
2085                    }
2086                    incr id
2087                }
2088                close $fid
2089            }
2090        }
2091        uplevel 1 ::tkcon::FinalExit $args
2092    }
2093
2094    ## ::tkcon::InterpEval - passes evaluation to another named interpreter
2095    ## If the interpreter is named, but no args are given, it returns the
2096    ## [tk appname] of that interps master (not the associated eval slave).
2097    ##
2098    proc ::tkcon::InterpEval {{slave {}} args} {
2099        variable PRIV
2100
2101        if {[string match {} $slave]} {
2102            return $PRIV(slaves)
2103        } elseif {[string match {[Mm]ain} $slave]} {
2104            set slave {}
2105        }
2106        if {[llength $args]} {
2107            return [interp eval $slave uplevel \#0 $args]
2108        } else {
2109            return [interp eval $slave tk appname]
2110        }
2111    }
2112
2113    proc ::tkcon::Interps {{ls {}} {interp {}}} {
2114        if {[string match {} $interp]} { lappend ls {} [tk appname] }
2115        foreach i [interp slaves $interp] {
2116            if {[string compare {} $interp]} { set i "$interp $i" }
2117            if {[string compare {} [interp eval $i package provide Tk]]} {
2118                lappend ls $i [interp eval $i tk appname]
2119            } else {
2120                lappend ls $i {}
2121            }
2122            set ls [Interps $ls $i]
2123        }
2124        return $ls
2125    }
2126
2127    proc ::tkcon::Display {{disp {}}} {
2128        variable DISP
2129
2130        set res {}
2131        if {$disp != ""} {
2132            if {![info exists DISP($disp)]} { return }
2133            return [list $DISP($disp) [winfo interps -displayof $DISP($disp)]]
2134        }
2135        return [lsort -dictionary [array names DISP]]
2136    }
2137
2138    proc ::tkcon::NewDisplay {} {
2139        variable PRIV
2140        variable DISP
2141
2142        set t $PRIV(base).newdisp
2143        if {![winfo exists $t]} {
2144            toplevel $t
2145            wm withdraw $t
2146            wm title $t "tkcon Attach to Display"
2147            label $t.gets -text "New Display: "
2148            entry $t.data -width 32
2149            button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1}
2150            bind $t.data <Return> [list $t.ok invoke]
2151            bind $t.ok   <Return> [list $t.ok invoke]
2152            grid $t.gets $t.data -sticky ew
2153            grid $t.ok   -       -sticky ew
2154            grid columnconfig $t 1 -weight 1
2155            grid rowconfigure $t 1 -weight 1
2156            wm transient $t $PRIV(root)
2157            wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
2158                    reqwidth $t]) / 2}]+[expr {([winfo \
2159                    screenheight $t]-[winfo reqheight $t]) / 2}]
2160        }
2161        $t.data delete 0 end
2162        wm deiconify $t
2163        raise $t
2164        grab $t
2165        focus $t.data
2166        vwait ::tkcon::PRIV(grab)
2167        grab release $t
2168        wm withdraw $t
2169        set disp [$t.data get]
2170        if {$disp == ""} { return }
2171        regsub -all {\.} [string tolower $disp] ! dt
2172        set dt $PRIV(base).$dt
2173        destroy $dt
2174        if {[catch {
2175            toplevel $dt -screen $disp
2176            set interps [winfo interps -displayof $dt]
2177            if {![llength $interps]} {
2178                error "No other Tk interpreters on $disp"
2179            }
2180            send -displayof $dt [lindex $interps 0] [list info tclversion]
2181        } err]} {
2182            global env
2183            if {[info exists env(DISPLAY)]} {
2184                set myd $env(DISPLAY)
2185            } else {
2186                set myd "myDisplay:0"
2187            }
2188            tk_messageBox -title "Display Connection Error" \
2189                    -message "Unable to connect to \"$disp\":\n$err\
2190                    \nMake sure you have xauth-based permissions\
2191                    (xauth add $myd . `mcookie`), and xhost is disabled\
2192                    (xhost -) on \"$disp\"" \
2193                    -icon error -type ok
2194            destroy $dt
2195            return
2196        }
2197        set DISP($disp) $dt
2198        wm withdraw $dt
2199        bind $dt <Destroy> [subst {catch {unset ::tkcon::DISP($disp)}}]
2200        tk_messageBox -title "$disp Connection" \
2201                -message "Connected to \"$disp\", found:\n[join $interps \n]" \
2202                -type ok
2203    }
2204
2205    ##
2206    ## The following state checkpoint/revert procedures are very sketchy
2207    ## and prone to problems.  They do not track modifications to currently
2208    ## existing procedures/variables, and they can really screw things up
2209    ## if you load in libraries (especially Tk) between checkpoint and
2210    ## revert.  Only with this knowledge in mind should you use these.
2211    ##
2212
2213    ## ::tkcon::StateCheckpoint - checkpoints the current state of the system
2214    ## This allows you to return to this state with ::tkcon::StateRevert
2215    # ARGS:
2216    ##
2217    proc ::tkcon::StateCheckpoint {app type} {
2218        variable CPS
2219        variable PRIV
2220
2221        if {[info exists CPS($type,$app,cmd)] && \
2222                [tk_dialog $PRIV(base).warning "Overwrite Previous State?" \
2223                "Are you sure you want to lose previously checkpointed\
2224                state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return
2225        set CPS($type,$app,cmd) [EvalOther $app $type info commands *]
2226        set CPS($type,$app,var) [EvalOther $app $type info vars *]
2227        return
2228    }
2229
2230    ## ::tkcon::StateCompare - compare two states and output difference
2231    # ARGS:
2232    ##
2233    proc ::tkcon::StateCompare {app type {verbose 0}} {
2234        variable CPS
2235        variable PRIV
2236        variable OPT
2237        variable COLOR
2238
2239        if {![info exists CPS($type,$app,cmd)]} {
2240            return -code error \
2241                    "No previously checkpointed state for $type \"$app\""
2242        }
2243        set w $PRIV(base).compare
2244        if {[winfo exists $w]} {
2245            $w.text config -state normal
2246            $w.text delete 1.0 end
2247        } else {
2248            toplevel $w
2249            frame $w.btn
2250            scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
2251            text $w.text -yscrollcommand [list $w.sy set] -height 12 \
2252                    -foreground $COLOR(stdin) \
2253                    -background $COLOR(bg) \
2254                    -insertbackground $COLOR(cursor) \
2255                    -font $OPT(font)
2256            pack $w.btn -side bottom -fill x
2257            pack $w.sy -side right -fill y
2258            pack $w.text -fill both -expand 1
2259            button $w.btn.close -text "Dismiss" -width 11 \
2260                    -command [list destroy $w]
2261            button $w.btn.check  -text "Recheckpoint" -width 11
2262            button $w.btn.revert -text "Revert" -width 11
2263            button $w.btn.expand -text "Verbose" -width 11
2264            button $w.btn.update -text "Update" -width 11
2265            pack $w.btn.check $w.btn.revert $w.btn.expand $w.btn.update \
2266                    $w.btn.close -side left -fill x -padx 4 -pady 2 -expand 1
2267            $w.text tag config red -foreground red
2268        }
2269        wm title $w "Compare State: $type [list $app]"
2270
2271        $w.btn.check config \
2272                -command "::tkcon::StateCheckpoint [list $app] $type; \
2273                ::tkcon::StateCompare [list $app] $type $verbose"
2274        $w.btn.revert config \
2275                -command "::tkcon::StateRevert [list $app] $type; \
2276                ::tkcon::StateCompare [list $app] $type $verbose"
2277        $w.btn.update config -command [info level 0]
2278        if {$verbose} {
2279            $w.btn.expand config -text Brief \
2280                    -command [list ::tkcon::StateCompare $app $type 0]
2281        } else {
2282            $w.btn.expand config -text Verbose \
2283                    -command [list ::tkcon::StateCompare $app $type 1]
2284        }
2285        ## Don't allow verbose mode unless 'dump' exists in $app
2286        ## We're assuming this is tkcon's dump command
2287        set hasdump [llength [EvalOther $app $type info commands dump]]
2288        if {$hasdump} {
2289            $w.btn.expand config -state normal
2290        } else {
2291            $w.btn.expand config -state disabled
2292        }
2293
2294        set cmds [lremove [EvalOther $app $type info commands *] \
2295                $CPS($type,$app,cmd)]
2296        set vars [lremove [EvalOther $app $type info vars *] \
2297                $CPS($type,$app,var)]
2298
2299        if {$hasdump && $verbose} {
2300            set cmds [EvalOther $app $type eval dump c -nocomplain $cmds]
2301            set vars [EvalOther $app $type eval dump v -nocomplain $vars]
2302        }
2303        $w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \
2304                $cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {}
2305
2306        raise $w
2307        $w.text config -state disabled
2308    }
2309
2310    ## ::tkcon::StateRevert - reverts interpreter to previous state
2311    # ARGS:
2312    ##
2313    proc ::tkcon::StateRevert {app type} {
2314        variable CPS
2315        variable PRIV
2316
2317        if {![info exists CPS($type,$app,cmd)]} {
2318            return -code error \
2319                    "No previously checkpointed state for $type \"$app\""
2320        }
2321        if {![tk_dialog $PRIV(base).warning "Revert State?" \
2322                "Are you sure you want to revert the state in $type \"$app\"?"\
2323                questhead 1 "Do It" "Cancel"]} {
2324            foreach i [lremove [EvalOther $app $type info commands *] \
2325                    $CPS($type,$app,cmd)] {
2326                catch {EvalOther $app $type rename $i {}}
2327            }
2328            foreach i [lremove [EvalOther $app $type info vars *] \
2329                    $CPS($type,$app,var)] {
2330                catch {EvalOther $app $type unset $i}
2331            }
2332        }
2333    }
2334
2335    ## ::tkcon::StateCleanup - cleans up state information in master array
2336    #
2337    ##
2338    proc ::tkcon::StateCleanup {args} {
2339        variable CPS
2340
2341        if {![llength $args]} {
2342            foreach state [array names CPS slave,*] {
2343                if {![interp exists [string range $state 6 end]]} {
2344                    unset CPS($state)
2345                }
2346            }
2347        } else {
2348            set app  [lindex $args 0]
2349            set type [lindex $args 1]
2350            if {[regexp {^(|slave)$} $type]} {
2351                foreach state [array names CPS "slave,$app\[, \]*"] {
2352                    if {![interp exists [string range $state 6 end]]} {
2353                        unset CPS($state)
2354                    }
2355                }
2356            } else {
2357                catch {unset CPS($type,$app)}
2358            }
2359        }
2360    }
2361}
2362
2363## ::tkcon::Event - get history event, search if string != {}
2364## look forward (next) if $int>0, otherwise look back (prev)
2365# ARGS: W       - console widget
2366##
2367proc ::tkcon::Event {int {str {}}} {
2368    if {!$int} return
2369
2370    variable PRIV
2371    set w $PRIV(console)
2372
2373    set nextid [EvalSlave history nextid]
2374    if {[string compare {} $str]} {
2375        ## String is not empty, do an event search
2376        set event $PRIV(event)
2377        if {$int < 0 && $event == $nextid} { set PRIV(cmdbuf) $str }
2378        set len [string len $PRIV(cmdbuf)]
2379        incr len -1
2380        if {$int > 0} {
2381            ## Search history forward
2382            while {$event < $nextid} {
2383                if {[incr event] == $nextid} {
2384                    $w delete limit end
2385                    $w insert limit $PRIV(cmdbuf)
2386                    break
2387                } elseif {
2388                    ![catch {EvalSlave history event $event} res] &&
2389                    [set p [string first $PRIV(cmdbuf) $res]] > -1
2390                } {
2391                    set p2 [expr {$p + [string length $PRIV(cmdbuf)]}]
2392                    $w delete limit end
2393                    $w insert limit $res
2394                    Blink $w "limit + $p c" "limit + $p2 c"
2395                    break
2396                }
2397            }
2398            set PRIV(event) $event
2399        } else {
2400            ## Search history reverse
2401            while {![catch {EvalSlave history event [incr event -1]} res]} {
2402                if {[set p [string first $PRIV(cmdbuf) $res]] > -1} {
2403                    set p2 [expr {$p + [string length $PRIV(cmdbuf)]}]
2404                    $w delete limit end
2405                    $w insert limit $res
2406                    set PRIV(event) $event
2407                    Blink $w "limit + $p c" "limit + $p2 c"
2408                    break
2409                }
2410            }
2411        }
2412    } else {
2413        ## String is empty, just get next/prev event
2414        if {$int > 0} {
2415            ## Goto next command in history
2416            if {$PRIV(event) < $nextid} {
2417                $w delete limit end
2418                if {[incr PRIV(event)] == $nextid} {
2419                    $w insert limit $PRIV(cmdbuf)
2420                } else {
2421                    $w insert limit [EvalSlave history event $PRIV(event)]
2422                }
2423            }
2424        } else {
2425            ## Goto previous command in history
2426            if {$PRIV(event) == $nextid} {
2427                set PRIV(cmdbuf) [CmdGet $w]
2428            }
2429            if {[catch {EvalSlave history event [incr PRIV(event) -1]} res]} {
2430                incr PRIV(event)
2431            } else {
2432                $w delete limit end
2433                $w insert limit $res
2434            }
2435        }
2436    }
2437    $w mark set insert end
2438    $w see end
2439}
2440
2441## ::tkcon::ErrorHighlight - magic error highlighting
2442## beware: voodoo included
2443# ARGS:
2444##
2445proc ::tkcon::ErrorHighlight w {
2446    variable COLOR
2447
2448    ## do voodoo here
2449    set app [Attach]
2450    # we have to pull the text out, because text regexps are screwed on \n's.
2451    set info [$w get 1.0 end-1c]
2452    # Check for specific line error in a proc
2453    set exp(proc) "\"(\[^\"\]+)\"\n\[\t \]+\\\(procedure \"(\[^\"\]+)\""
2454    # Check for too few args to a proc
2455    set exp(param) "parameter \"(\[^\"\]+)\" to \"(\[^\"\]+)\""
2456    set start 1.0
2457    while {
2458        [regexp -indices -- $exp(proc) $info junk what cmd] ||
2459        [regexp -indices -- $exp(param) $info junk what cmd]
2460    } {
2461        foreach {w0 w1} $what {c0 c1} $cmd {break}
2462        set what [string range $info $w0 $w1]
2463        set cmd  [string range $info $c0 $c1]
2464        if {[string match *::* $cmd]} {
2465            set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \
2466                    [list [namespace qualifiers $cmd] \
2467                    [list info procs [namespace tail $cmd]]]]
2468        } else {
2469            set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]]
2470        }
2471        if {[llength $res]==1} {
2472            set tag [UniqueTag $w]
2473            $w tag add $tag $start+${c0}c $start+1c+${c1}c
2474            $w tag configure $tag -foreground $COLOR(stdout)
2475            $w tag bind $tag <Enter> [list $w tag configure $tag -under 1]
2476            $w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
2477            $w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
2478                    {[list edit -attach $app -type proc -find $what -- $cmd]}"
2479        }
2480        set info [string range $info $c1 end]
2481        set start [$w index $start+${c1}c]
2482    }
2483    ## Next stage, check for procs that start a line
2484    set start 1.0
2485    set exp(cmd) "^\"\[^\" \t\n\]+"
2486    while {
2487        [string compare {} [set ix \
2488                [$w search -regexp -count numc -- $exp(cmd) $start end]]]
2489    } {
2490        set start [$w index $ix+${numc}c]
2491        # +1c to avoid the first quote
2492        set cmd [$w get $ix+1c $start]
2493        if {[string match *::* $cmd]} {
2494            set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \
2495                    [list [namespace qualifiers $cmd] \
2496                    [list info procs [namespace tail $cmd]]]]
2497        } else {
2498            set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]]
2499        }
2500        if {[llength $res]==1} {
2501            set tag [UniqueTag $w]
2502            $w tag add $tag $ix+1c $start
2503            $w tag configure $tag -foreground $COLOR(proc)
2504            $w tag bind $tag <Enter> [list $w tag configure $tag -under 1]
2505            $w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
2506            $w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
2507                    {[list edit -attach $app -type proc -- $cmd]}"
2508        }
2509    }
2510}
2511
2512## tkcon - command that allows control over the console
2513## This always exists in the main interpreter, and is aliased into
2514## other connected interpreters
2515# ARGS: totally variable, see internal comments
2516##
2517proc tkcon {cmd args} {
2518    global errorInfo
2519
2520    switch -glob -- $cmd {
2521        buf* {
2522            ## 'buffer' Sets/Query the buffer size
2523            if {[llength $args]} {
2524                if {[regexp {^[1-9][0-9]*$} $args]} {
2525                    set ::tkcon::OPT(buffer) $args
2526                    # catch in case the console doesn't exist yet
2527                    catch {::tkcon::ConstrainBuffer $::tkcon::PRIV(console) \
2528                            $::tkcon::OPT(buffer)}
2529                } else {
2530                    return -code error "buffer must be a valid integer"
2531                }
2532            }
2533            return $::tkcon::OPT(buffer)
2534        }
2535        bg* {
2536            ## 'bgerror' Brings up an error dialog
2537            set errorInfo [lindex $args 1]
2538            bgerror [lindex $args 0]
2539        }
2540        cl* {
2541            ## 'close' Closes the console
2542            ::tkcon::Destroy
2543        }
2544        cons* {
2545            ## 'console' - passes the args to the text widget of the console.
2546            set result [uplevel 1 $::tkcon::PRIV(console) $args]
2547            ::tkcon::ConstrainBuffer $::tkcon::PRIV(console) \
2548                    $::tkcon::OPT(buffer)
2549            return $result
2550        }
2551        congets {
2552            ## 'congets' a replacement for [gets stdin]
2553            # Use the 'gets' alias of 'tkcon_gets' command instead of
2554            # calling the *get* methods directly for best compatability
2555            if {[llength $args]} {
2556                return -code error "wrong # args: must be \"tkcon congets\""
2557            }
2558            tkcon show
2559            set old [bind TkConsole <<TkCon_Eval>>]
2560            bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
2561            set w $::tkcon::PRIV(console)
2562            # Make sure to move the limit to get the right data
2563            $w mark set insert end
2564            $w mark set limit insert
2565            $w see end
2566            vwait ::tkcon::PRIV(wait)
2567            set line [::tkcon::CmdGet $w]
2568            $w insert end \n
2569            bind TkConsole <<TkCon_Eval>> $old
2570            return $line
2571        }
2572        getc* {
2573            ## 'getcommand' a replacement for [gets stdin]
2574            ## This forces a complete command to be input though
2575            if {[llength $args]} {
2576                return -code error "wrong # args: must be \"tkcon getcommand\""
2577            }
2578            tkcon show
2579            set old [bind TkConsole <<TkCon_Eval>>]
2580            bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
2581            set w $::tkcon::PRIV(console)
2582            # Make sure to move the limit to get the right data
2583            $w mark set insert end
2584            $w mark set limit insert
2585            $w see end
2586            vwait ::tkcon::PRIV(wait)
2587            set line [::tkcon::CmdGet $w]
2588            $w insert end \n
2589            while {![info complete $line] || [regexp {[^\\]\\$} $line]} {
2590                vwait ::tkcon::PRIV(wait)
2591                set line [::tkcon::CmdGet $w]
2592                $w insert end \n
2593                $w see end
2594            }
2595            bind TkConsole <<TkCon_Eval>> $old
2596            return $line
2597        }
2598        get - gets {
2599            ## 'gets' - a replacement for [gets stdin]
2600            ## This pops up a text widget to be used for stdin (local grabbed)
2601            if {[llength $args]} {
2602                return -code error "wrong # args: should be \"tkcon gets\""
2603            }
2604            set t $::tkcon::PRIV(base).gets
2605            if {![winfo exists $t]} {
2606                toplevel $t
2607                wm withdraw $t
2608                wm title $t "tkcon gets stdin request"
2609                label $t.gets -text "\"gets stdin\" request:"
2610                text $t.data -width 32 -height 5 -wrap none \
2611                        -xscrollcommand [list $t.sx set] \
2612                        -yscrollcommand [list $t.sy set]
2613                scrollbar $t.sx -orient h -takefocus 0 -highlightthick 0 \
2614                        -command [list $t.data xview]
2615                scrollbar $t.sy -orient v -takefocus 0 -highlightthick 0 \
2616                        -command [list $t.data yview]
2617                button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1}
2618                bind $t.ok <Return> { %W invoke }
2619                grid $t.gets -          -sticky ew
2620                grid $t.data $t.sy      -sticky news
2621                grid $t.sx              -sticky ew
2622                grid $t.ok   -          -sticky ew
2623                grid columnconfig $t 0 -weight 1
2624                grid rowconfig    $t 1 -weight 1
2625                wm transient $t $::tkcon::PRIV(root)
2626                wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
2627                        reqwidth $t]) / 2}]+[expr {([winfo \
2628                        screenheight $t]-[winfo reqheight $t]) / 2}]
2629            }
2630            $t.data delete 1.0 end
2631            wm deiconify $t
2632            raise $t
2633            grab $t
2634            focus $t.data
2635            vwait ::tkcon::PRIV(grab)
2636            grab release $t
2637            wm withdraw $t
2638            return [$t.data get 1.0 end-1c]
2639        }
2640        err* {
2641            ## Outputs stack caused by last error.
2642            ## error handling with pizazz (but with pizza would be nice too)
2643            if {[llength $args]==2} {
2644                set app  [lindex $args 0]
2645                set type [lindex $args 1]
2646                if {[catch {::tkcon::EvalOther $app $type set errorInfo} info]} {
2647                    set info "error getting info from $type $app:\n$info"
2648                }
2649            } else {
2650                set info $::tkcon::PRIV(errorInfo)
2651            }
2652            if {[string match {} $info]} { set info "errorInfo empty" }
2653            ## If args is empty, the -attach switch just ignores it
2654            edit -attach $args -type error -- $info
2655        }
2656        fi* {
2657            ## 'find' string
2658            ::tkcon::Find $::tkcon::PRIV(console) $args
2659        }
2660        fo* {
2661            ## 'font' ?fontname? - gets/sets the font of the console
2662            if {[llength $args]} {
2663                if {[info exists ::tkcon::PRIV(console)] && \
2664                        [winfo exists $::tkcon::PRIV(console)]} {
2665                    $::tkcon::PRIV(console) config -font $args
2666                    set ::tkcon::OPT(font) [$::tkcon::PRIV(console) cget -font]
2667                } else {
2668                    set ::tkcon::OPT(font) $args
2669                }
2670            }
2671            return $::tkcon::OPT(font)
2672        }
2673        hid* - with* {
2674            ## 'hide' 'withdraw' - hides the console.
2675            wm withdraw $::tkcon::PRIV(root)
2676        }
2677        his* {
2678            ## 'history'
2679            set sub {\2}
2680            if {[string match -new* $args]} { append sub "\n"}
2681            set h [::tkcon::EvalSlave history]
2682            regsub -all "( *\[0-9\]+  |\t)(\[^\n\]*\n?)" $h $sub h
2683            return $h
2684        }
2685        ico* {
2686            ## 'iconify' - iconifies the console with 'iconify'.
2687            wm iconify $::tkcon::PRIV(root)
2688        }
2689        mas* - eval {
2690            ## 'master' - evals contents in master interpreter
2691            uplevel \#0 $args
2692        }
2693        set {
2694            ## 'set' - set (or get, or unset) simple vars (not whole arrays)
2695            ## from the master console interpreter
2696            ## possible formats:
2697            ##    tkcon set <var>
2698            ##    tkcon set <var> <value>
2699            ##    tkcon set <var> <interp> <var1> <var2> w
2700            ##    tkcon set <var> <interp> <var1> <var2> u
2701            ##    tkcon set <var> <interp> <var1> <var2> r
2702            if {[llength $args]==5} {
2703                ## This is for use w/ 'tkcon upvar' and only works with slaves
2704                foreach {var i var1 var2 op} $args break
2705                if {[string compare {} $var2]} { append var1 "($var2)" }
2706                switch $op {
2707                    u { uplevel \#0 [list unset $var] }
2708                    w {
2709                        return [uplevel \#0 [list set $var \
2710                                [interp eval $i [list set $var1]]]]
2711                    }
2712                    r {
2713                        return [interp eval $i [list set $var1 \
2714                                [uplevel \#0 [list set $var]]]]
2715                    }
2716                }
2717            } elseif {[llength $args] == 1} {
2718                upvar \#0 [lindex $args 0] var
2719                if {[array exists var]} {
2720                    return [array get var]
2721                } else {
2722                    return $var
2723                }
2724            }
2725            return [uplevel \#0 set $args]
2726        }
2727        append {
2728            ## Modify a var in the master environment using append
2729            return [uplevel \#0 append $args]
2730        }
2731        lappend {
2732            ## Modify a var in the master environment using lappend
2733            return [uplevel \#0 lappend $args]
2734        }
2735        sh* - dei* {
2736            ## 'show|deiconify' - deiconifies the console.
2737            wm deiconify $::tkcon::PRIV(root)
2738            raise $::tkcon::PRIV(root)
2739            focus -force $::tkcon::PRIV(console)
2740        }
2741        ti* {
2742            ## 'title' ?title? - gets/sets the console's title
2743            if {[llength $args]} {
2744                return [wm title $::tkcon::PRIV(root) [join $args]]
2745            } else {
2746                return [wm title $::tkcon::PRIV(root)]
2747            }
2748        }
2749        upv* {
2750            ## 'upvar' masterVar slaveVar
2751            ## link slave variable slaveVar to the master variable masterVar
2752            ## only works masters<->slave
2753            set masterVar [lindex $args 0]
2754            set slaveVar  [lindex $args 1]
2755            if {[info exists $masterVar]} {
2756                interp eval $::tkcon::OPT(exec) \
2757                        [list set $slaveVar [set $masterVar]]
2758            } else {
2759                catch {interp eval $::tkcon::OPT(exec) [list unset $slaveVar]}
2760            }
2761            interp eval $::tkcon::OPT(exec) \
2762                    [list trace variable $slaveVar rwu \
2763                    [list tkcon set $masterVar $::tkcon::OPT(exec)]]
2764            return
2765        }
2766        v* {
2767            return $::tkcon::PRIV(version)
2768        }
2769        default {
2770            ## tries to determine if the command exists, otherwise throws error
2771            set new ::tkcon::[string toupper \
2772                    [string index $cmd 0]][string range $cmd 1 end]
2773            if {[llength [info command $new]]} {
2774                uplevel \#0 $new $args
2775            } else {
2776                return -code error "bad option \"$cmd\": must be\
2777                        [join [lsort [list attach close console destroy \
2778                        font hide iconify load main master new save show \
2779                        slave deiconify version title bgerror]] {, }]"
2780            }
2781        }
2782    }
2783}
2784
2785##
2786## Some procedures to make up for lack of built-in shell commands
2787##
2788
2789## tkcon_puts -
2790## This allows me to capture all stdout/stderr to the console window
2791## This will be renamed to 'puts' at the appropriate time during init
2792##
2793# ARGS: same as usual   
2794# Outputs:      the string with a color-coded text tag
2795##
2796proc tkcon_puts args {
2797    set len [llength $args]
2798    foreach {arg1 arg2 arg3} $args { break }
2799
2800    if {$len == 1} {
2801        tkcon console insert output "$arg1\n" stdout
2802    } elseif {$len == 2} {
2803        if {![string compare $arg1 -nonewline]} {
2804            tkcon console insert output $arg2 stdout
2805        } elseif {![string compare $arg1 stdout] \
2806                || ![string compare $arg1 stderr]} {
2807            tkcon console insert output "$arg2\n" $arg1
2808        } else {
2809            set len 0
2810        }
2811    } elseif {$len == 3} {
2812        if {![string compare $arg1 -nonewline] \
2813                && (![string compare $arg2 stdout] \
2814                || ![string compare $arg2 stderr])} {
2815            tkcon console insert output $arg3 $arg2
2816        } elseif {(![string compare $arg1 stdout] \
2817                || ![string compare $arg1 stderr]) \
2818                && ![string compare $arg3 nonewline]} {
2819            tkcon console insert output $arg2 $arg1
2820        } else {
2821            set len 0
2822        }
2823    } else {
2824        set len 0
2825    }
2826
2827    ## $len == 0 means it wasn't handled by tkcon above.
2828    ##
2829    if {$len == 0} {
2830        global errorCode errorInfo
2831        if {[catch "tkcon_tcl_puts $args" msg]} {
2832            regsub tkcon_tcl_puts $msg puts msg
2833            regsub -all tkcon_tcl_puts $errorInfo puts errorInfo
2834            return -code error $msg
2835        }
2836        return $msg
2837    }
2838
2839    ## WARNING: This update should behave well because it uses idletasks,
2840    ## however, if there are weird looping problems with events, or
2841    ## hanging in waits, try commenting this out.
2842    if {$len} {
2843        tkcon console see output
2844        update idletasks
2845    }
2846}
2847
2848## tkcon_gets -
2849## This allows me to capture all stdin input without needing to stdin
2850## This will be renamed to 'gets' at the appropriate time during init
2851##
2852# ARGS:         same as gets   
2853# Outputs:      same as gets
2854##
2855proc tkcon_gets args {
2856    set len [llength $args]
2857    if {$len != 1 && $len != 2} {
2858        return -code error \
2859                "wrong # args: should be \"gets channelId ?varName?\""
2860    }
2861    if {[string compare stdin [lindex $args 0]]} {
2862        return [uplevel 1 tkcon_tcl_gets $args]
2863    }
2864    set gtype [tkcon set ::tkcon::OPT(gets)]
2865    if {$gtype == ""} { set gtype congets }
2866    set data [tkcon $gtype]
2867    if {$len == 2} {
2868        upvar 1 [lindex $args 1] var
2869        set var $data
2870        return [string length $data]
2871    }
2872    return $data
2873}
2874
2875## edit - opens a file/proc/var for reading/editing
2876##
2877# Arguments:
2878#   type        proc/file/var
2879#   what        the actual name of the item
2880# Returns:      nothing
2881##
2882proc edit {args} {
2883    array set opts {-find {} -type {} -attach {}}
2884    while {[string match -* [lindex $args 0]]} {
2885        switch -glob -- [lindex $args 0] {
2886            -f* { set opts(-find) [lindex $args 1] }
2887            -a* { set opts(-attach) [lindex $args 1] }
2888            -t* { set opts(-type) [lindex $args 1] }
2889            --  { set args [lreplace $args 0 0]; break }
2890            default {return -code error "unknown option \"[lindex $args 0]\""}
2891        }
2892        set args [lreplace $args 0 1]
2893    }
2894    # determine who we are dealing with
2895    if {[llength $opts(-attach)]} {
2896        foreach {app type} $opts(-attach) {break}
2897    } else {
2898        foreach {app type} [tkcon attach] {break}
2899    }
2900
2901    set word [lindex $args 0]
2902    if {[string match {} $opts(-type)]} {
2903        if {[llength [::tkcon::EvalOther $app $type info commands [list $word]]]} {
2904            set opts(-type) "proc"
2905        } elseif {[llength [::tkcon::EvalOther $app $type info vars [list $word]]]} {
2906            set opts(-type) "var"
2907        } elseif {[::tkcon::EvalOther $app $type file isfile [list $word]]} {
2908            set opts(-type) "file"
2909        }
2910    }
2911    if {[string compare $opts(-type) {}]} {
2912        # Create unique edit window toplevel
2913        set w $::tkcon::PRIV(base).__edit
2914        set i 0
2915        while {[winfo exists $w[incr i]]} {}
2916        append w $i
2917        toplevel $w
2918        wm withdraw $w
2919        if {[string length $word] > 12} {
2920            wm title $w "tkcon Edit: [string range $word 0 9]..."
2921        } else {
2922            wm title $w "tkcon Edit: $word"
2923        }
2924
2925        text $w.text -wrap none \
2926                -xscrollcommand [list $w.sx set] \
2927                -yscrollcommand [list $w.sy set] \
2928                -foreground $::tkcon::COLOR(stdin) \
2929                -background $::tkcon::COLOR(bg) \
2930                -insertbackground $::tkcon::COLOR(cursor) \
2931                -font $::tkcon::OPT(font)
2932        scrollbar $w.sx -orient h -takefocus 0 -bd 1 \
2933                -command [list $w.text xview]
2934        scrollbar $w.sy -orient v -takefocus 0 -bd 1 \
2935                -command [list $w.text yview]
2936
2937        set menu [menu $w.mbar]
2938        $w configure -menu $menu
2939
2940        ## File Menu
2941        ##
2942        set m [menu [::tkcon::MenuButton $menu File file]]
2943        $m add command -label "Save As..."  -underline 0 \
2944                -command [list ::tkcon::Save {} widget $w.text]
2945        $m add command -label "Append To..."  -underline 0 \
2946                -command [list ::tkcon::Save {} widget $w.text a+]
2947        $m add separator
2948        $m add command -label "Dismiss" -underline 0 -accel "Ctrl-w" \
2949                -command [list destroy $w]
2950        bind $w <Control-w>                     [list destroy $w]
2951        bind $w <$::tkcon::PRIV(meta)-w>        [list destroy $w]
2952
2953        ## Edit Menu
2954        ##
2955        set text $w.text
2956        set m [menu [::tkcon::MenuButton $menu Edit edit]]
2957        $m add command -label "Cut"   -under 2 \
2958                -command [list tk_textCut $text]
2959        $m add command -label "Copy"  -under 0 \
2960                -command [list tk_textCopy $text]
2961        $m add command -label "Paste" -under 0 \
2962                -command [list tk_textPaste $text]
2963        $m add separator
2964        $m add command -label "Find" -under 0 \
2965                -command [list ::tkcon::FindBox $text]
2966
2967        ## Send To Menu
2968        ##
2969        set m [menu [::tkcon::MenuButton $menu "Send To..." send]]
2970        $m add command -label "Send To $app" -underline 0 \
2971                -command "::tkcon::EvalOther [list $app] $type \
2972                eval \[$w.text get 1.0 end-1c\]"
2973        set other [tkcon attach]
2974        if {[string compare $other [list $app $type]]} {
2975            $m add command -label "Send To [lindex $other 0]" \
2976                    -command "::tkcon::EvalOther $other \
2977                    eval \[$w.text get 1.0 end-1c\]"
2978        }
2979
2980        grid $w.text - $w.sy -sticky news
2981        grid $w.sx - -sticky ew
2982        grid columnconfigure $w 0 -weight 1
2983        grid columnconfigure $w 1 -weight 1
2984        grid rowconfigure $w 0 -weight 1
2985    } else {
2986        return -code error "unrecognized type '$word'"
2987    }
2988    switch -glob -- $opts(-type) {
2989        proc*   {
2990            $w.text insert 1.0 \
2991                    [::tkcon::EvalOther $app $type dump proc [list $word]]
2992        }
2993        var*    {
2994            $w.text insert 1.0 \
2995                    [::tkcon::EvalOther $app $type dump var [list $word]]
2996        }
2997        file    {
2998            $w.text insert 1.0 [::tkcon::EvalOther $app $type eval \
2999                    [subst -nocommands {
3000                set __tkcon(fid) [open $word r]
3001                set __tkcon(data) [read \$__tkcon(fid)]
3002                close \$__tkcon(fid)
3003                after 1000 unset __tkcon
3004                return \$__tkcon(data)
3005            }
3006            ]]
3007        }
3008        error*  {
3009            $w.text insert 1.0 [join $args \n]
3010            ::tkcon::ErrorHighlight $w.text
3011        }
3012        default {
3013            $w.text insert 1.0 [join $args \n]
3014        }
3015    }
3016    wm deiconify $w
3017    focus $w.text
3018    if {[string compare $opts(-find) {}]} {
3019        ::tkcon::Find $w.text $opts(-find) -case 1
3020    }
3021}
3022interp alias {} ::more {} ::edit
3023interp alias {} ::less {} ::edit
3024
3025## echo
3026## Relaxes the one string restriction of 'puts'
3027# ARGS: any number of strings to output to stdout
3028##
3029proc echo args { puts [concat $args] }
3030
3031## clear - clears the buffer of the console (not the history though)
3032## This is executed in the parent interpreter
3033##
3034proc clear {{pcnt 100}} {
3035    if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
3036        return -code error \
3037                "invalid percentage to clear: must be 1-100 (100 default)"
3038    } elseif {$pcnt == 100} {
3039        tkcon console delete 1.0 end
3040    } else {
3041        set tmp [expr {$pcnt/100.0*[tkcon console index end]}]
3042        tkcon console delete 1.0 "$tmp linestart"
3043    }
3044}
3045
3046## alias - akin to the csh alias command
3047## If called with no args, then it dumps out all current aliases
3048## If called with one arg, returns the alias of that arg (or {} if none)
3049# ARGS: newcmd  - (optional) command to bind alias to
3050#       args    - command and args being aliased
3051##
3052proc alias {{newcmd {}} args} {
3053    if {[string match {} $newcmd]} {
3054        set res {}
3055        foreach a [interp aliases] {
3056            lappend res [list $a -> [interp alias {} $a]]
3057        }
3058        return [join $res \n]
3059    } elseif {![llength $args]} {
3060        interp alias {} $newcmd
3061    } else {
3062        eval interp alias [list {} $newcmd {}] $args
3063    }
3064}
3065
3066## unalias - unaliases an alias'ed command
3067# ARGS: cmd     - command to unbind as an alias
3068##
3069proc unalias {cmd} {
3070    interp alias {} $cmd {}
3071}
3072
3073## dump - outputs variables/procedure/widget info in source'able form.
3074## Accepts glob style pattern matching for the names
3075#
3076# ARGS: type    - type of thing to dump: must be variable, procedure, widget
3077#
3078# OPTS: -nocomplain
3079#               don't complain if no items of the specified type are found
3080#       -filter pattern
3081#               specifies a glob filter pattern to be used by the variable
3082#               method as an array filter pattern (it filters down for
3083#               nested elements) and in the widget method as a config
3084#               option filter pattern
3085#       --      forcibly ends options recognition
3086#
3087# Returns:      the values of the requested items in a 'source'able form
3088##
3089proc dump {type args} {
3090    set whine 1
3091    set code  ok
3092    if {![llength $args]} {
3093        ## If no args, assume they gave us something to dump and
3094        ## we'll try anything
3095        set args $type
3096        set type any
3097    }
3098    while {[string match -* [lindex $args 0]]} {
3099        switch -glob -- [lindex $args 0] {
3100            -n* { set whine 0; set args [lreplace $args 0 0] }
3101            -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] }
3102            --  { set args [lreplace $args 0 0]; break }
3103            default {return -code error "unknown option \"[lindex $args 0]\""}
3104        }
3105    }
3106    if {$whine && ![llength $args]} {
3107        return -code error "wrong \# args: [lindex [info level 0] 0] type\
3108                ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?"
3109    }
3110    set res {}
3111    switch -glob -- $type {
3112        c* {
3113            # command
3114            # outputs commands by figuring out, as well as possible, what it is
3115            # this does not attempt to auto-load anything
3116            foreach arg $args {
3117                if {[llength [set cmds [info commands $arg]]]} {
3118                    foreach cmd [lsort $cmds] {
3119                        if {[lsearch -exact [interp aliases] $cmd] > -1} {
3120                            append res "\#\# ALIAS:   $cmd =>\
3121                                    [interp alias {} $cmd]\n"
3122                        } elseif {
3123                            [llength [info procs $cmd]] ||
3124                            ([string match *::* $cmd] &&
3125                            [llength [namespace eval [namespace qual $cmd] \
3126                                    info procs [namespace tail $cmd]]])
3127                        } {
3128                            if {[catch {dump p -- $cmd} msg] && $whine} {
3129                                set code error
3130                            }
3131                            append res $msg\n
3132                        } else {
3133                            append res "\#\# COMMAND: $cmd\n"
3134                        }
3135                    }
3136                } elseif {$whine} {
3137                    append res "\#\# No known command $arg\n"
3138                    set code error
3139                }
3140            }
3141        }
3142        v* {
3143            # variable
3144            # outputs variables value(s), whether array or simple.
3145            if {![info exists fltr]} { set fltr * }
3146            foreach arg $args {
3147                if {![llength [set vars [uplevel 1 info vars [list $arg]]]]} {
3148                    if {[uplevel 1 info exists $arg]} {
3149                        set vars $arg
3150                    } elseif {$whine} {
3151                        append res "\#\# No known variable $arg\n"
3152                        set code error
3153                        continue
3154                    } else { continue }
3155                }
3156                foreach var [lsort $vars] {
3157                    if {[uplevel 1 [list info locals $var]] == ""} {
3158                        # use the proper scope of the var, but
3159                        # namespace which won't id locals correctly
3160                        set var [uplevel 1 \
3161                                [list namespace which -variable $var]]
3162                    }
3163                    upvar 1 $var v
3164                    if {[array exists v] || [catch {string length $v}]} {
3165                        set nst {}
3166                        append res "array set [list $var] \{\n"
3167                        if {[array size v]} {
3168                            foreach i [lsort [array names v $fltr]] {
3169                                upvar 0 v\($i\) __a
3170                                if {[array exists __a]} {
3171                                    append nst "\#\# NESTED ARRAY ELEM: $i\n"
3172                                    append nst "upvar 0 [list $var\($i\)] __a;\
3173                                            [dump v -filter $fltr __a]\n"
3174                                } else {
3175                                    append res "    [list $i]\t[list $v($i)]\n"
3176                                }
3177                            }
3178                        } else {
3179                            ## empty array
3180                            append res "    empty array\n"
3181                            append nst "unset [list $var](empty)\n"
3182                        }
3183                        append res "\}\n$nst"
3184                    } else {
3185                        append res [list set $var $v]\n
3186                    }
3187                }
3188            }
3189        }
3190        p* {
3191            # procedure
3192            foreach arg $args {
3193                if {
3194                    ![llength [set procs [info proc $arg]]] &&
3195                    ([string match *::* $arg] &&
3196                    [llength [set ps [namespace eval \
3197                            [namespace qualifier $arg] \
3198                            info procs [namespace tail $arg]]]])
3199                } {
3200                    set procs {}
3201                    set namesp [namespace qualifier $arg]
3202                    foreach p $ps {
3203                        lappend procs ${namesp}::$p
3204                    }
3205                }
3206                if {[llength $procs]} {
3207                    foreach p [lsort $procs] {
3208                        set as {}
3209                        foreach a [info args $p] {
3210                            if {[info default $p $a tmp]} {
3211                                lappend as [list $a $tmp]
3212                            } else {
3213                                lappend as $a
3214                            }
3215                        }
3216                        append res [list proc $p $as [info body $p]]\n
3217                    }
3218                } elseif {$whine} {
3219                    append res "\#\# No known proc $arg\n"
3220                    set code error
3221                }
3222            }
3223        }
3224        w* {
3225            # widget
3226            ## The user should have Tk loaded
3227            if {![llength [info command winfo]]} {
3228                return -code error "winfo not present, cannot dump widgets"
3229            }
3230            if {![info exists fltr]} { set fltr .* }
3231            foreach arg $args {
3232                if {[llength [set ws [info command $arg]]]} {
3233                    foreach w [lsort $ws] {
3234                        if {[winfo exists $w]} {
3235                            if {[catch {$w configure} cfg]} {
3236                                append res "\#\# Widget $w\
3237                                        does not support configure method"
3238                                set code error
3239                            } else {
3240                                append res "\#\# [winfo class $w]\
3241                                        $w\n$w configure"
3242                                foreach c $cfg {
3243                                    if {[llength $c] != 5} continue
3244                                    ## Check to see that the option does
3245                                    ## not match the default, then check
3246                                    ## the item against the user filter
3247                                    if {[string compare [lindex $c 3] \
3248                                            [lindex $c 4]] && \
3249                                            [regexp -nocase -- $fltr $c]} {
3250                                        append res " \\\n\t[list [lindex $c 0]\
3251                                                [lindex $c 4]]"
3252                                    }
3253                                }
3254                                append res \n
3255                            }
3256                        }
3257                    }
3258                } elseif {$whine} {
3259                    append res "\#\# No known widget $arg\n"
3260                    set code error
3261                }
3262            }
3263        }
3264        a* {
3265            ## see if we recognize it, other complain
3266            if {[regexp {(var|com|proc|widget)} \
3267                    [set types [uplevel 1 what $args]]]} {
3268                foreach type $types {
3269                    if {[regexp {(var|com|proc|widget)} $type]} {
3270                        append res "[uplevel 1 dump $type $args]\n"
3271                    }
3272                }
3273            } else {
3274                set res "dump was unable to resolve type for \"$args\""
3275                set code error
3276            }
3277        }
3278        default {
3279            return -code error "bad [lindex [info level 0] 0] option\
3280                    \"$type\": must be variable, command, procedure,\
3281                    or widget"
3282        }
3283    }
3284    return -code $code [string trimright $res \n]
3285}
3286
3287## idebug - interactive debugger
3288#
3289# idebug body ?level?
3290#
3291#       Prints out the body of the command (if it is a procedure) at the
3292#       specified level.  <i>level</i> defaults to the current level.
3293#
3294# idebug break
3295#
3296#       Creates a breakpoint within a procedure.  This will only trigger
3297#       if idebug is on and the id matches the pattern.  If so, TkCon will
3298#       pop to the front with the prompt changed to an idebug prompt.  You
3299#       are given the basic ability to observe the call stack an query/set
3300#       variables or execute Tcl commands at any level.  A separate history
3301#       is maintained in debugging mode.
3302#
3303# idebug echo|{echo ?id?} ?args?
3304#
3305#       Behaves just like "echo", but only triggers when idebug is on.
3306#       You can specify an optional id to further restrict triggering.
3307#       If no id is specified, it defaults to the name of the command
3308#       in which the call was made.
3309#
3310# idebug id ?id?
3311#
3312#       Query or set the idebug id.  This id is used by other idebug
3313#       methods to determine if they should trigger or not.  The idebug
3314#       id can be a glob pattern and defaults to *.
3315#
3316# idebug off
3317#
3318#       Turns idebug off.
3319#
3320# idebug on ?id?
3321#
3322#       Turns idebug on.  If 'id' is specified, it sets the id to it.
3323#
3324# idebug puts|{puts ?id?} args
3325#
3326#       Behaves just like "puts", but only triggers when idebug is on.
3327#       You can specify an optional id to further restrict triggering.
3328#       If no id is specified, it defaults to the name of the command
3329#       in which the call was made.
3330#
3331# idebug show type ?level? ?VERBOSE?
3332#
3333#       'type' must be one of vars, locals or globals.  This method
3334#       will output the variables/locals/globals present in a particular
3335#       level.  If VERBOSE is added, then it actually 'dump's out the
3336#       values as well.  'level' defaults to the level in which this
3337#       method was called.
3338#
3339# idebug trace ?level?
3340#
3341#       Prints out the stack trace from the specified level up to the top
3342#       level.  'level' defaults to the current level.
3343#
3344##
3345proc idebug {opt args} {
3346    global IDEBUG
3347
3348    if {![info exists IDEBUG(on)]} {
3349        array set IDEBUG { on 0 id * debugging 0 }
3350    }
3351    set level [expr {[info level]-1}]
3352    switch -glob -- $opt {
3353        on      {
3354            if {[llength $args]} { set IDEBUG(id) $args }
3355            return [set IDEBUG(on) 1]
3356        }
3357        off     { return [set IDEBUG(on) 0] }
3358        id  {
3359            if {![llength $args]} {
3360                return $IDEBUG(id)
3361            } else { return [set IDEBUG(id) $args] }
3362        }
3363        break {
3364            if {!$IDEBUG(on) || $IDEBUG(debugging) || \
3365                    ([llength $args] && \
3366                    ![string match $IDEBUG(id) $args]) || [info level]<1} {
3367                return
3368            }
3369            set IDEBUG(debugging) 1
3370            puts stderr "idebug at level \#$level: [lindex [info level -1] 0]"
3371            set tkcon [llength [info command tkcon]]
3372            if {$tkcon} {
3373                tkcon master eval set ::tkcon::OPT(prompt2) \$::tkcon::OPT(prompt1)
3374                tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(debugPrompt)
3375                set slave [tkcon set ::tkcon::OPT(exec)]
3376                set event [tkcon set ::tkcon::PRIV(event)]
3377                tkcon set ::tkcon::OPT(exec) [tkcon master interp create debugger]
3378                tkcon set ::tkcon::PRIV(event) 1
3379            }
3380            set max $level
3381            while 1 {
3382                set err {}
3383                if {$tkcon} {
3384                    # tkcon's overload of gets is advanced enough to not need
3385                    # this, but we get a little better control this way.
3386                    tkcon evalSlave set level $level
3387                    tkcon prompt
3388                    set line [tkcon getcommand]
3389                    tkcon console mark set output end
3390                } else {
3391                    puts -nonewline stderr "(level \#$level) debug > "
3392                    gets stdin line
3393                    while {![info complete $line]} {
3394                        puts -nonewline "> "
3395                        append line "\n[gets stdin]"
3396                    }
3397                }
3398                if {[string match {} $line]} continue
3399                set key [lindex $line 0]
3400                if {![regexp {^([#-]?[0-9]+)} [lreplace $line 0 0] lvl]} {
3401                    set lvl \#$level
3402                }
3403                set res {}; set c 0
3404                switch -- $key {
3405                    + {
3406                        ## Allow for jumping multiple levels
3407                        if {$level < $max} {
3408                            idebug trace [incr level] $level 0 VERBOSE
3409                        }
3410                    }
3411                    - {
3412                        ## Allow for jumping multiple levels
3413                        if {$level > 1} {
3414                            idebug trace [incr level -1] $level 0 VERBOSE
3415                        }
3416                    }
3417                    . { set c [catch {idebug trace $level $level 0 VERBOSE} res] }
3418                    v { set c [catch {idebug show vars $lvl } res] }
3419                    V { set c [catch {idebug show vars $lvl VERBOSE} res] }
3420                    l { set c [catch {idebug show locals $lvl } res] }
3421                    L { set c [catch {idebug show locals $lvl VERBOSE} res] }
3422                    g { set c [catch {idebug show globals $lvl } res] }
3423                    G { set c [catch {idebug show globals $lvl VERBOSE} res] }
3424                    t { set c [catch {idebug trace 1 $max $level } res] }
3425                    T { set c [catch {idebug trace 1 $max $level VERBOSE} res]}
3426                    b { set c [catch {idebug body $lvl} res] }
3427                    o { set res [set IDEBUG(on) [expr {!$IDEBUG(on)}]] }
3428                    h - ?       {
3429                        puts stderr "    +              Move down in call stack
3430    -           Move up in call stack
3431    .           Show current proc name and params
3432
3433    v           Show names of variables currently in scope
3434    V           Show names of variables currently in scope with values
3435    l           Show names of local (transient) variables
3436    L           Show names of local (transient) variables with values
3437    g           Show names of declared global variables
3438    G           Show names of declared global variables with values
3439    t           Show a stack trace
3440    T           Show a verbose stack trace
3441
3442    b           Show body of current proc
3443    o           Toggle on/off any further debugging
3444    c,q         Continue regular execution (Quit debugger)
3445    h,?         Print this help
3446    default     Evaluate line at current level (\#$level)"
3447                    }
3448                    c - q break
3449                    default { set c [catch {uplevel \#$level $line} res] }
3450                }
3451                if {$tkcon} {
3452                    tkcon set ::tkcon::PRIV(event) \
3453                            [tkcon evalSlave eval history add [list $line]\
3454                            \; history nextid]
3455                }
3456                if {$c} {
3457                    puts stderr $res
3458                } elseif {[string compare {} $res]} {
3459                    puts $res
3460                }
3461            }
3462            set IDEBUG(debugging) 0
3463            if {$tkcon} {
3464                tkcon master interp delete debugger
3465                tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(prompt2)
3466                tkcon set ::tkcon::OPT(exec) $slave
3467                tkcon set ::tkcon::PRIV(event) $event
3468                tkcon prompt
3469            }
3470        }
3471        bo* {
3472            if {[regexp {^([#-]?[0-9]+)} $args level]} {
3473                return [uplevel $level {dump c -no [lindex [info level 0] 0]}]
3474            }
3475        }
3476        t* {
3477            if {[llength $args]<2} return
3478            set min [set max [set lvl $level]]
3479            set exp {^#?([0-9]+)? ?#?([0-9]+) ?#?([0-9]+)? ?(VERBOSE)?}
3480            if {![regexp $exp $args junk min max lvl verbose]} return
3481            for {set i $max} {
3482                $i>=$min && ![catch {uplevel \#$i info level 0} info]
3483            } {incr i -1} {
3484                if {$i==$lvl} {
3485                    puts -nonewline stderr "* \#$i:\t"
3486                } else {
3487                    puts -nonewline stderr "  \#$i:\t"
3488                }
3489                set name [lindex $info 0]
3490                if {[string compare VERBOSE $verbose] || \
3491                        ![llength [info procs $name]]} {
3492                    puts $info
3493                } else {
3494                    puts "proc $name {[info args $name]} { ... }"
3495                    set idx 0
3496                    foreach arg [info args $name] {
3497                        if {[string match args $arg]} {
3498                            puts "\t$arg = [lrange $info [incr idx] end]"
3499                            break
3500                        } else {
3501                            puts "\t$arg = [lindex $info [incr idx]]"
3502                        }
3503                    }
3504                }
3505            }
3506        }
3507        s* {
3508            #var, local, global
3509            set level \#$level
3510            if {![regexp {^([vgl][^ ]*) ?([#-]?[0-9]+)? ?(VERBOSE)?} \
3511                    $args junk type level verbose]} return
3512            switch -glob -- $type {
3513                v* { set vars [uplevel $level {lsort [info vars]}] }
3514                l* { set vars [uplevel $level {lsort [info locals]}] }
3515                g* { set vars [lremove [uplevel $level {info vars}] \
3516                        [uplevel $level {info locals}]] }
3517            }
3518            if {[string match VERBOSE $verbose]} {
3519                return [uplevel $level dump var -nocomplain $vars]
3520            } else {
3521                return $vars
3522            }
3523        }
3524        e* - pu* {
3525            if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} {
3526                set id [lindex [info level 0] 0]
3527            } else {
3528                set id [lindex $opt 1]
3529            }
3530            if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} {
3531                if {[string match e* $opt]} {
3532                    puts [concat $args]
3533                } else { eval puts $args }
3534            }
3535        }
3536        default {
3537            return -code error "bad [lindex [info level 0] 0] option \"$opt\",\
3538                    must be: [join [lsort [list on off id break print body\
3539                    trace show puts echo]] {, }]"
3540        }
3541    }
3542}
3543
3544## observe - like trace, but not
3545# ARGS: opt     - option
3546#       name    - name of variable or command
3547##
3548proc observe {opt name args} {
3549    global tcl_observe
3550    switch -glob -- $opt {
3551        co* {
3552            if {[regexp {^(catch|lreplace|set|puts|for|incr|info|uplevel)$} \
3553                    $name]} {
3554                return -code error "cannot observe \"$name\":\
3555                        infinite eval loop will occur"
3556            }
3557            set old ${name}@
3558            while {[llength [info command $old]]} { append old @ }
3559            rename $name $old
3560            set max 4
3561            regexp {^[0-9]+} $args max
3562            ## idebug trace could be used here
3563            proc $name args "
3564            for {set i \[info level\]; set max \[expr \[info level\]-$max\]} {