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
Line 
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\]} {
3565                \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\]
3566            } {incr i -1} {
3567                puts -nonewline stderr \"  \#\$i:\t\"
3568                puts \$info
3569            }
3570            uplevel \[lreplace \[info level 0\] 0 0 $old\]
3571            "
3572            set tcl_observe($name) $old
3573        }
3574        cd* {
3575            if {[info exists tcl_observe($name)] && [catch {
3576                rename $name {}
3577                rename $tcl_observe($name) $name
3578                unset tcl_observe($name)
3579            } err]} { return -code error $err }
3580        }
3581        ci* {
3582            ## What a useless method...
3583            if {[info exists tcl_observe($name)]} {
3584                set i $tcl_observe($name)
3585                set res "\"$name\" observes true command \"$i\""
3586                while {[info exists tcl_observe($i)]} {
3587                    append res "\n\"$name\" observes true command \"$i\""
3588                    set i $tcl_observe($name)
3589                }
3590                return $res
3591            }
3592        }
3593        va* - vd* {
3594            set type [lindex $args 0]
3595            set args [lrange $args 1 end]
3596            if {![regexp {^[rwu]} $type type]} {
3597                return -code error "bad [lindex [info level 0] 0] $opt type\
3598                        \"$type\", must be: read, write or unset"
3599            }
3600            if {![llength $args]} { set args observe_var }
3601            uplevel 1 [list trace $opt $name $type $args]
3602        }
3603        vi* {
3604            uplevel 1 [list trace vinfo $name]
3605        }
3606        default {
3607            return -code error "bad [lindex [info level 0] 0] option\
3608                    \"[lindex $args 0]\", must be: [join [lsort \
3609                    [list command cdelete cinfo variable vdelete vinfo]] {, }]"
3610        }
3611    }
3612}
3613
3614## observe_var - auxilary function for observing vars, called by trace
3615## via observe
3616# ARGS: name    - variable name
3617#       el      - array element name, if any
3618#       op      - operation type (rwu)
3619##
3620proc observe_var {name el op} {
3621    if {[string match u $op]} {
3622        if {[string compare {} $el]} {
3623            puts "unset \"${name}($el)\""
3624        } else {
3625            puts "unset \"$name\""
3626        }
3627    } else {
3628        upvar 1 $name $name
3629        if {[info exists ${name}($el)]} {
3630            puts [dump v ${name}($el)]
3631        } else {
3632            puts [dump v $name]
3633        }
3634    }
3635}
3636
3637## which - tells you where a command is found
3638# ARGS: cmd     - command name
3639# Returns:      where command is found (internal / external / unknown)
3640##
3641proc which cmd {
3642    ## This tries to auto-load a command if not recognized
3643    set types [uplevel 1 [list what $cmd 1]]
3644    if {[llength $types]} {
3645        set out {}
3646       
3647        foreach type $types {
3648            switch -- $type {
3649                alias           { set res "$cmd: aliased to [alias $cmd]" }
3650                procedure       { set res "$cmd: procedure" }
3651                command         { set res "$cmd: internal command" }
3652                executable      { lappend out [auto_execok $cmd] }
3653                variable        { lappend out "$cmd: $type" }
3654            }
3655            if {[info exists res]} {
3656                global auto_index
3657                if {[info exists auto_index($cmd)]} {
3658                    ## This tells you where the command MIGHT have come from -
3659                    ## not true if the command was redefined interactively or
3660                    ## existed before it had to be auto_loaded.  This is just
3661                    ## provided as a hint at where it MAY have come from
3662                    append res " ($auto_index($cmd))"
3663                }
3664                lappend out $res
3665                unset res
3666            }
3667        }
3668        return [join $out \n]
3669    } else {
3670        return -code error "$cmd: command not found"
3671    }
3672}
3673
3674## what - tells you what a string is recognized as
3675# ARGS: str     - string to id
3676# Returns:      id types of command as list
3677##
3678proc what {str {autoload 0}} {
3679    set types {}
3680    if {[llength [info commands $str]] || ($autoload && \
3681            [auto_load $str] && [llength [info commands $str]])} {
3682        if {[lsearch -exact [interp aliases] $str] > -1} {
3683            lappend types "alias"
3684        } elseif {
3685            [llength [info procs $str]] ||
3686            ([string match *::* $str] &&
3687            [llength [namespace eval [namespace qualifier $str] \
3688                    info procs [namespace tail $str]]])
3689        } {
3690            lappend types "procedure"
3691        } else {
3692            lappend types "command"
3693        }
3694    }
3695    if {[llength [uplevel 1 info vars $str]]} {
3696        upvar 1 $str var
3697        if {[array exists var]} {
3698            lappend types array variable
3699        } else {
3700            lappend types scalar variable
3701        }
3702    }
3703    if {[file isdirectory $str]} {
3704        lappend types "directory"
3705    }
3706    if {[file isfile $str]} {
3707        lappend types "file"
3708    }
3709    if {[llength [info commands winfo]] && [winfo exists $str]} {
3710        lappend types "widget"
3711    }
3712    if {[string compare {} [auto_execok $str]]} {
3713        lappend types "executable"
3714    }
3715    return $types
3716}
3717
3718## dir - directory list
3719# ARGS: args    - names/glob patterns of directories to list
3720# OPTS: -all    - list hidden files as well (Unix dot files)
3721#       -long   - list in full format "permissions size date filename"
3722#       -full   - displays / after directories and link paths for links
3723# Returns:      a directory listing
3724##
3725proc dir {args} {
3726    array set s {
3727        all 0 full 0 long 0
3728        0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
3729    }
3730    while {[string match \-* [lindex $args 0]]} {
3731        set str [lindex $args 0]
3732        set args [lreplace $args 0 0]
3733        switch -glob -- $str {
3734            -a* {set s(all) 1} -f* {set s(full) 1}
3735            -l* {set s(long) 1} -- break
3736            default {
3737                return -code error "unknown option \"$str\",\
3738                        should be one of: -all, -full, -long"
3739            }
3740        }
3741    }
3742    set sep [string trim [file join . .] .]
3743    if {![llength $args]} { set args . }
3744    if {$::tcl_version >= 8.3} {
3745        # Newer glob args allow safer dir processing.  The user may still
3746        # want glob chars, but really only for file matching.
3747        foreach arg $args {
3748            if {[file isdirectory $arg]} {
3749                if {$s(all)} {
3750                    lappend out [list $arg [lsort \
3751                            [glob -nocomplain -directory $arg .* *]]]
3752                } else {
3753                    lappend out [list $arg [lsort \
3754                            [glob -nocomplain -directory $arg *]]]
3755                }
3756            } else {
3757                set dir [file dirname $arg]
3758                lappend out [list $dir$sep [lsort \
3759                        [glob -nocomplain -directory $dir [file tail $arg]]]]
3760            }
3761        }
3762    } else {
3763        foreach arg $args {
3764            if {[file isdirectory $arg]} {
3765                set arg [string trimright $arg $sep]$sep
3766                if {$s(all)} {
3767                    lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]]
3768                } else {
3769                    lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]]
3770                }
3771            } else {
3772                lappend out [list [file dirname $arg]$sep \
3773                        [lsort [glob -nocomplain -- $arg]]]
3774            }
3775        }
3776    }
3777    if {$s(long)} {
3778        set old [clock scan {1 year ago}]
3779        set fmt "%s%9d %s %s\n"
3780        foreach o $out {
3781            set d [lindex $o 0]
3782            append res $d:\n
3783            foreach f [lindex $o 1] {
3784                file lstat $f st
3785                set f [file tail $f]
3786                if {$s(full)} {
3787                    switch -glob $st(type) {
3788                        d* { append f $sep }
3789                        l* { append f "@ -> [file readlink $d$sep$f]" }
3790                        default { if {[file exec $d$sep$f]} { append f * } }
3791                    }
3792                }
3793                if {[string match file $st(type)]} {
3794                    set mode -
3795                } else {
3796                    set mode [string index $st(type) 0]
3797                }
3798                foreach j [split [format %03o [expr {$st(mode)&0777}]] {}] {
3799                    append mode $s($j)
3800                }
3801                if {$st(mtime)>$old} {
3802                    set cfmt {%b %d %H:%M}
3803                } else {
3804                    set cfmt {%b %%Y}
3805                }
3806                append res [format $fmt $mode $st(size) \
3807                        [clock format $st(mtime) -format $cfmt] $f]
3808            }
3809            append res \n
3810        }
3811    } else {
3812        foreach o $out {
3813            set d [lindex $o 0]
3814            append res "$d:\n"
3815            set i 0
3816            foreach f [lindex $o 1] {
3817                if {[string len [file tail $f]] > $i} {
3818                    set i [string len [file tail $f]]
3819                }
3820            }
3821            set i [expr {$i+2+$s(full)}]
3822            set j 80
3823            ## This gets the number of cols in the tkcon console widget
3824            if {[llength [info commands tkcon]]} {
3825                set j [expr {[tkcon master set ::tkcon::OPT(cols)]/$i}]
3826            }
3827            set k 0
3828            foreach f [lindex $o 1] {
3829                set f [file tail $f]
3830                if {$s(full)} {
3831                    switch -glob [file type $d$sep$f] {
3832                        d* { append f $sep }
3833                        l* { append f @ }
3834                        default { if {[file exec $d$sep$f]} { append f * } }
3835                    }
3836                }
3837                append res [format "%-${i}s" $f]
3838                if {$j == 0 || [incr k]%$j == 0} {
3839                    set res [string trimright $res]\n
3840                }
3841            }
3842            append res \n\n
3843        }
3844    }
3845    return [string trimright $res]
3846}
3847interp alias {} ::ls {} ::dir -full
3848
3849## lremove - remove items from a list
3850# OPTS:
3851#   -all        remove all instances of each item
3852#   -glob       remove all instances matching glob pattern
3853#   -regexp     remove all instances matching regexp pattern
3854# ARGS: l       a list to remove items from
3855#       args    items to remove (these are 'join'ed together)
3856##
3857proc lremove {args} {
3858    array set opts {-all 0 pattern -exact}
3859    while {[string match -* [lindex $args 0]]} {
3860        switch -glob -- [lindex $args 0] {
3861            -a* { set opts(-all) 1 }
3862            -g* { set opts(pattern) -glob }
3863            -r* { set opts(pattern) -regexp }
3864            --  { set args [lreplace $args 0 0]; break }
3865            default {return -code error "unknown option \"[lindex $args 0]\""}
3866        }
3867        set args [lreplace $args 0 0]
3868    }
3869    set l [lindex $args 0]
3870    foreach i [join [lreplace $args 0 0]] {
3871        if {[set ix [lsearch $opts(pattern) $l $i]] == -1} continue
3872        set l [lreplace $l $ix $ix]
3873        if {$opts(-all)} {
3874            while {[set ix [lsearch $opts(pattern) $l $i]] != -1} {
3875                set l [lreplace $l $ix $ix]
3876            }
3877        }
3878    }
3879    return $l
3880}
3881
3882if {!$::tkcon::PRIV(WWW)} {;
3883
3884## Unknown changed to get output into tkcon window
3885# unknown:
3886# Invoked automatically whenever an unknown command is encountered.
3887# Works through a list of "unknown handlers" that have been registered
3888# to deal with unknown commands.  Extensions can integrate their own
3889# handlers into the 'unknown' facility via 'unknown_handler'.
3890#
3891# If a handler exists that recognizes the command, then it will
3892# take care of the command action and return a valid result or a
3893# Tcl error.  Otherwise, it should return "-code continue" (=2)
3894# and responsibility for the command is passed to the next handler.
3895#
3896# Arguments:
3897# args -        A list whose elements are the words of the original
3898#               command, including the command name.
3899
3900proc unknown args {
3901    global unknown_handler_order unknown_handlers errorInfo errorCode
3902
3903    #
3904    # Be careful to save error info now, and restore it later
3905    # for each handler.  Some handlers generate their own errors
3906    # and disrupt handling.
3907    #
3908    set savedErrorCode $errorCode
3909    set savedErrorInfo $errorInfo
3910
3911    if {![info exists unknown_handler_order] || \
3912            ![info exists unknown_handlers]} {
3913        set unknown_handlers(tcl) tcl_unknown
3914        set unknown_handler_order tcl
3915    }
3916
3917    foreach handler $unknown_handler_order {
3918        set status [catch {uplevel 1 $unknown_handlers($handler) $args} result]
3919
3920        if {$status == 1} {
3921            #
3922            # Strip the last five lines off the error stack (they're
3923            # from the "uplevel" command).
3924            #
3925            set new [split $errorInfo \n]
3926            set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n]
3927            return -code $status -errorcode $errorCode \
3928                -errorinfo $new $result
3929
3930        } elseif {$status != 4} {
3931            return -code $status $result
3932        }
3933
3934        set errorCode $savedErrorCode
3935        set errorInfo $savedErrorInfo
3936    }
3937
3938    set name [lindex $args 0]
3939    return -code error "invalid command name \"$name\""
3940}
3941
3942# tcl_unknown:
3943# Invoked when a Tcl command is invoked that doesn't exist in the
3944# interpreter:
3945#
3946#       1. See if the autoload facility can locate the command in a
3947#          Tcl script file.  If so, load it and execute it.
3948#       2. If the command was invoked interactively at top-level:
3949#           (a) see if the command exists as an executable UNIX program.
3950#               If so, "exec" the command.
3951#           (b) see if the command requests csh-like history substitution
3952#               in one of the common forms !!, !<number>, or ^old^new.  If
3953#               so, emulate csh's history substitution.
3954#           (c) see if the command is a unique abbreviation for another
3955#               command.  If so, invoke the command.
3956#
3957# Arguments:
3958# args -        A list whose elements are the words of the original
3959#               command, including the command name.
3960
3961proc tcl_unknown args {
3962    global auto_noexec auto_noload env unknown_pending tcl_interactive
3963    global errorCode errorInfo
3964
3965    # If the command word has the form "namespace inscope ns cmd"
3966    # then concatenate its arguments onto the end and evaluate it.
3967
3968    set cmd [lindex $args 0]
3969    if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
3970        set arglist [lrange $args 1 end]
3971        set ret [catch {uplevel 1 $cmd $arglist} result]
3972        if {$ret == 0} {
3973            return $result
3974        } else {
3975            return -code $ret -errorcode $errorCode $result
3976        }
3977    }
3978
3979    # Save the values of errorCode and errorInfo variables, since they
3980    # may get modified if caught errors occur below.  The variables will
3981    # be restored just before re-executing the missing command.
3982
3983    set savedErrorCode $errorCode
3984    set savedErrorInfo $errorInfo
3985    set name [lindex $args 0]
3986    if {![info exists auto_noload]} {
3987        #
3988        # Make sure we're not trying to load the same proc twice.
3989        #
3990        if {[info exists unknown_pending($name)]} {
3991            return -code error "self-referential recursion in \"unknown\" for command \"$name\""
3992        }
3993        set unknown_pending($name) pending
3994        if {[llength [info args auto_load]]==1} {
3995            set ret [catch {auto_load $name} msg]
3996        } else {
3997            set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
3998        }
3999        unset unknown_pending($name)
4000        if {$ret} {
4001            return -code $ret -errorcode $errorCode \
4002                    "error while autoloading \"$name\": $msg"
4003        }
4004        if {![array size unknown_pending]} { unset unknown_pending }
4005        if {$msg} {
4006            set errorCode $savedErrorCode
4007            set errorInfo $savedErrorInfo
4008            set code [catch {uplevel 1 $args} msg]
4009            if {$code ==  1} {
4010                #
4011                # Strip the last five lines off the error stack (they're
4012                # from the "uplevel" command).
4013                #
4014
4015                set new [split $errorInfo \n]
4016                set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n]
4017                return -code error -errorcode $errorCode \
4018                        -errorinfo $new $msg
4019            } else {
4020                return -code $code $msg
4021            }
4022        }
4023    }
4024    if {[info level] == 1 && [string match {} [info script]] \
4025            && [info exists tcl_interactive] && $tcl_interactive} {
4026        if {![info exists auto_noexec]} {
4027            set new [auto_execok $name]
4028            if {[string compare {} $new]} {
4029                set errorCode $savedErrorCode
4030                set errorInfo $savedErrorInfo
4031                return [uplevel 1 exec $new [lrange $args 1 end]]
4032                #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]]
4033            }
4034        }
4035        set errorCode $savedErrorCode
4036        set errorInfo $savedErrorInfo
4037        ##
4038        ## History substitution moved into ::tkcon::EvalCmd
4039        ##
4040        if {[string compare $name "::"] == 0} {
4041            set name ""
4042        }
4043        if {$ret != 0} {
4044            return -code $ret -errorcode $errorCode \
4045                "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
4046        }
4047        set cmds [info commands $name*]
4048        if {[llength $cmds] == 1} {
4049            return [uplevel 1 [lreplace $args 0 0 $cmds]]
4050        }
4051        if {[llength $cmds]} {
4052            if {$name == ""} {
4053                return -code error "empty command name \"\""
4054            } else {
4055                return -code error \
4056                        "ambiguous command name \"$name\": [lsort $cmds]"
4057            }
4058        }
4059        ## We've got nothing so far
4060        ## Check and see if Tk wasn't loaded, but it appears to be a Tk cmd
4061        if {![uplevel \#0 info exists tk_version]} {
4062            lappend tkcmds bell bind bindtags button \
4063                    canvas checkbutton clipboard destroy \
4064                    entry event focus font frame grab grid image \
4065                    label listbox lower menu menubutton message \
4066                    option pack place radiobutton raise \
4067                    scale scrollbar selection send spinbox \
4068                    text tk tkwait toplevel winfo wm
4069            if {[lsearch -exact $tkcmds $name] >= 0 && \
4070                    [tkcon master tk_messageBox -icon question -parent . \
4071                    -title "Load Tk?" -type retrycancel -default retry \
4072                    -message "This appears to be a Tk command, but Tk\
4073                    has not yet been loaded.  Shall I retry the command\
4074                    with loading Tk first?"] == "retry"} {
4075                return [uplevel 1 "load {} Tk; $args"]
4076            }
4077        }
4078    }
4079    return -code continue
4080}
4081
4082} ; # end exclusionary code for WWW
4083
4084proc ::tkcon::Bindings {} {
4085    variable PRIV
4086    global tcl_platform tk_version
4087
4088    #-----------------------------------------------------------------------
4089    # Elements of tkPriv that are used in this file:
4090    #
4091    # char -            Character position on the line;  kept in order
4092    #                   to allow moving up or down past short lines while
4093    #                   still remembering the desired position.
4094    # mouseMoved -      Non-zero means the mouse has moved a significant
4095    #                   amount since the button went down (so, for example,
4096    #                   start dragging out a selection).
4097    # prevPos -         Used when moving up or down lines via the keyboard.
4098    #                   Keeps track of the previous insert position, so
4099    #                   we can distinguish a series of ups and downs, all
4100    #                   in a row, from a new up or down.
4101    # selectMode -      The style of selection currently underway:
4102    #                   char, word, or line.
4103    # x, y -            Last known mouse coordinates for scanning
4104    #                   and auto-scanning.
4105    #-----------------------------------------------------------------------
4106
4107    switch -glob $tcl_platform(platform) {
4108        win*    { set PRIV(meta) Alt }
4109        mac*    { set PRIV(meta) Command }
4110        default { set PRIV(meta) Meta }
4111    }
4112
4113    ## Get all Text bindings into TkConsole
4114    foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] }       
4115    ## We really didn't want the newline insertion
4116    bind TkConsole <Control-Key-o> {}
4117
4118    ## Now make all our virtual event bindings
4119    foreach {ev key} [subst -nocommand -noback {
4120        <<TkCon_Exit>>          <Control-q>
4121        <<TkCon_New>>           <Control-N>
4122        <<TkCon_Close>>         <Control-w>
4123        <<TkCon_About>>         <Control-A>
4124        <<TkCon_Help>>          <Control-H>
4125        <<TkCon_Find>>          <Control-F>
4126        <<TkCon_Slave>>         <Control-Key-1>
4127        <<TkCon_Master>>        <Control-Key-2>
4128        <<TkCon_Main>>          <Control-Key-3>
4129        <<TkCon_Expand>>        <Key-Tab>
4130        <<TkCon_ExpandFile>>    <Key-Escape>
4131        <<TkCon_ExpandProc>>    <Control-P>
4132        <<TkCon_ExpandVar>>     <Control-V>
4133        <<TkCon_Tab>>           <Control-i>
4134        <<TkCon_Tab>>           <$PRIV(meta)-i>
4135        <<TkCon_Newline>>       <Control-o>
4136        <<TkCon_Newline>>       <$PRIV(meta)-o>
4137        <<TkCon_Newline>>       <Control-Key-Return>
4138        <<TkCon_Newline>>       <Control-Key-KP_Enter>
4139        <<TkCon_Eval>>          <Return>
4140        <<TkCon_Eval>>          <KP_Enter>
4141        <<TkCon_Clear>>         <Control-l>
4142        <<TkCon_Previous>>      <Up>
4143        <<TkCon_PreviousImmediate>>     <Control-p>
4144        <<TkCon_PreviousSearch>>        <Control-r>
4145        <<TkCon_Next>>          <Down>
4146        <<TkCon_NextImmediate>> <Control-n>
4147        <<TkCon_NextSearch>>    <Control-s>
4148        <<TkCon_Transpose>>     <Control-t>
4149        <<TkCon_ClearLine>>     <Control-u>
4150        <<TkCon_SaveCommand>>   <Control-z>
4151        <<TkCon_Popup>>         <Button-3>
4152    }] {
4153        event add $ev $key
4154        ## Make sure the specific key won't be defined
4155        bind TkConsole $key {}
4156    }
4157
4158    ## Make the ROOT bindings
4159    bind $PRIV(root) <<TkCon_Exit>>     exit
4160    bind $PRIV(root) <<TkCon_New>>      { ::tkcon::New }
4161    bind $PRIV(root) <<TkCon_Close>>    { ::tkcon::Destroy }
4162    bind $PRIV(root) <<TkCon_About>>    { ::tkcon::About }
4163    bind $PRIV(root) <<TkCon_Help>>     { ::tkcon::Help }
4164    bind $PRIV(root) <<TkCon_Find>>     { ::tkcon::FindBox $::tkcon::PRIV(console) }
4165    bind $PRIV(root) <<TkCon_Slave>>    {
4166        ::tkcon::Attach {}
4167        ::tkcon::Prompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
4168    }
4169    bind $PRIV(root) <<TkCon_Master>>   {
4170        if {[string compare {} $::tkcon::PRIV(name)]} {
4171            ::tkcon::Attach $::tkcon::PRIV(name)
4172        } else {
4173            ::tkcon::Attach Main
4174        }
4175        ::tkcon::Prompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
4176    }
4177    bind $PRIV(root) <<TkCon_Main>>     {
4178        ::tkcon::Attach Main
4179        ::tkcon::Prompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
4180    }
4181    bind $PRIV(root) <<TkCon_Popup>> {
4182        ::tkcon::PopupMenu %X %Y
4183    }
4184
4185    ## Menu items need null TkConsolePost bindings to avoid the TagProc
4186    ##
4187    foreach ev [bind $PRIV(root)] {
4188        bind TkConsolePost $ev {
4189            # empty
4190        }
4191    }
4192
4193
4194    # ::tkcon::ClipboardKeysyms --
4195    # This procedure is invoked to identify the keys that correspond to
4196    # the copy, cut, and paste functions for the clipboard.
4197    #
4198    # Arguments:
4199    # copy -    Name of the key (keysym name plus modifiers, if any,
4200    #           such as "Meta-y") used for the copy operation.
4201    # cut -             Name of the key used for the cut operation.
4202    # paste -   Name of the key used for the paste operation.
4203
4204    proc ::tkcon::ClipboardKeysyms {copy cut paste} {
4205        bind TkConsole <$copy>  {::tkcon::Copy %W}
4206        bind TkConsole <$cut>   {::tkcon::Cut %W}
4207        bind TkConsole <$paste> {::tkcon::Paste %W}
4208    }
4209
4210    proc ::tkcon::GetSelection {w} {
4211        if {
4212            ![catch {selection get -displayof $w -type UTF8_STRING} txt] ||
4213            ![catch {selection get -displayof $w} txt] ||
4214            ![catch {selection get -displayof $w -selection CLIPBOARD} txt]
4215        } {
4216            return $txt
4217        }
4218        return -code error "could not find default selection"
4219    }
4220
4221    proc ::tkcon::Cut w {
4222        if {[string match $w [selection own -displayof $w]]} {
4223            clipboard clear -displayof $w
4224            catch {
4225                set txt [selection get -displayof $w]
4226                clipboard append -displayof $w $txt
4227                if {[$w compare sel.first >= limit]} {
4228                    $w delete sel.first sel.last
4229                }
4230            }
4231        }
4232    }
4233    proc ::tkcon::Copy w {
4234        if {[string match $w [selection own -displayof $w]]} {
4235            clipboard clear -displayof $w
4236            catch {
4237                set txt [selection get -displayof $w]
4238                clipboard append -displayof $w $txt
4239            }
4240        }
4241    }
4242    proc ::tkcon::Paste w {
4243        if {![catch {GetSelection $w} txt]} {
4244            if {[$w compare insert < limit]} { $w mark set insert end }
4245            $w insert insert $txt
4246            $w see insert
4247            if {[string match *\n* $txt]} { ::tkcon::Eval $w }
4248        }
4249    }
4250
4251    ## Redefine for TkConsole what we need
4252    ##
4253    event delete <<Paste>> <Control-V>
4254    ::tkcon::ClipboardKeysyms <Copy> <Cut> <Paste>
4255
4256    bind TkConsole <Insert> {
4257        catch { ::tkcon::Insert %W [::tkcon::GetSelection %W] }
4258    }
4259
4260    bind TkConsole <Triple-1> {+
4261        catch {
4262            eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
4263            eval %W tag remove sel sel.last-1c
4264            %W mark set insert sel.first
4265        }
4266    }
4267
4268    ## binding editor needed
4269    ## binding <events> for .tkconrc
4270
4271    bind TkConsole <<TkCon_ExpandFile>> {
4272        if {[%W compare insert > limit]} {::tkcon::Expand %W path}
4273        break
4274    }
4275    bind TkConsole <<TkCon_ExpandProc>> {
4276        if {[%W compare insert > limit]} {::tkcon::Expand %W proc}
4277    }
4278    bind TkConsole <<TkCon_ExpandVar>> {
4279        if {[%W compare insert > limit]} {::tkcon::Expand %W var}
4280    }
4281    bind TkConsole <<TkCon_Expand>> {
4282        if {[%W compare insert > limit]} {::tkcon::Expand %W}
4283    }
4284    bind TkConsole <<TkCon_Tab>> {
4285        if {[%W compare insert >= limit]} {
4286            ::tkcon::Insert %W \t
4287        }
4288    }
4289    bind TkConsole <<TkCon_Newline>> {
4290        if {[%W compare insert >= limit]} {
4291            ::tkcon::Insert %W \n
4292        }
4293    }
4294    bind TkConsole <<TkCon_Eval>> {
4295        ::tkcon::Eval %W
4296    }
4297    bind TkConsole <Delete> {
4298        if {[llength [%W tag nextrange sel 1.0 end]] \
4299                && [%W compare sel.first >= limit]} {
4300            %W delete sel.first sel.last
4301        } elseif {[%W compare insert >= limit]} {
4302            %W delete insert
4303            %W see insert
4304        }
4305    }
4306    bind TkConsole <BackSpace> {
4307        if {[llength [%W tag nextrange sel 1.0 end]] \
4308                && [%W compare sel.first >= limit]} {
4309            %W delete sel.first sel.last
4310        } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
4311            %W delete insert-1c
4312            %W see insert
4313        }
4314    }
4315    bind TkConsole <Control-h> [bind TkConsole <BackSpace>]
4316
4317    bind TkConsole <KeyPress> {
4318        ::tkcon::Insert %W %A
4319    }
4320
4321    bind TkConsole <Control-a> {
4322        if {[%W compare {limit linestart} == {insert linestart}]} {
4323            tkTextSetCursor %W limit
4324        } else {
4325            tkTextSetCursor %W {insert linestart}
4326        }
4327    }
4328    bind TkConsole <Key-Home> [bind TkConsole <Control-a>]
4329    bind TkConsole <Control-d> {
4330        if {[%W compare insert < limit]} break
4331        %W delete insert
4332    }
4333    bind TkConsole <Control-k> {
4334        if {[%W compare insert < limit]} break
4335        if {[%W compare insert == {insert lineend}]} {
4336            %W delete insert
4337        } else {
4338            %W delete insert {insert lineend}
4339        }
4340    }
4341    bind TkConsole <<TkCon_Clear>> {
4342        ## Clear console buffer, without losing current command line input
4343        set ::tkcon::PRIV(tmp) [::tkcon::CmdGet %W]
4344        clear
4345        ::tkcon::Prompt {} $::tkcon::PRIV(tmp)
4346    }
4347    bind TkConsole <<TkCon_Previous>> {
4348        if {[%W compare {insert linestart} != {limit linestart}]} {
4349            tkTextSetCursor %W [tkTextUpDownLine %W -1]
4350        } else {
4351            ::tkcon::Event -1
4352        }
4353    }
4354    bind TkConsole <<TkCon_Next>> {
4355        if {[%W compare {insert linestart} != {end-1c linestart}]} {
4356            tkTextSetCursor %W [tkTextUpDownLine %W 1]
4357        } else {
4358            ::tkcon::Event 1
4359        }
4360    }
4361    bind TkConsole <<TkCon_NextImmediate>>  { ::tkcon::Event 1 }
4362    bind TkConsole <<TkCon_PreviousImmediate>> { ::tkcon::Event -1 }
4363    bind TkConsole <<TkCon_PreviousSearch>> {
4364        ::tkcon::Event -1 [::tkcon::CmdGet %W]
4365    }
4366    bind TkConsole <<TkCon_NextSearch>>     {
4367        ::tkcon::Event 1 [::tkcon::CmdGet %W]
4368    }
4369    bind TkConsole <<TkCon_Transpose>>  {
4370        ## Transpose current and previous chars
4371        if {[%W compare insert > "limit+1c"]} { tkTextTranspose %W }
4372    }
4373    bind TkConsole <<TkCon_ClearLine>> {
4374        ## Clear command line (Unix shell staple)
4375        %W delete limit end
4376    }
4377    bind TkConsole <<TkCon_SaveCommand>> {
4378        ## Save command buffer (swaps with current command)
4379        set ::tkcon::PRIV(tmp) $::tkcon::PRIV(cmdsave)
4380        set ::tkcon::PRIV(cmdsave) [::tkcon::CmdGet %W]
4381        if {[string match {} $::tkcon::PRIV(cmdsave)]} {
4382            set ::tkcon::PRIV(cmdsave) $::tkcon::PRIV(tmp)
4383        } else {
4384            %W delete limit end-1c
4385        }
4386        ::tkcon::Insert %W $::tkcon::PRIV(tmp)
4387        %W see end
4388    }
4389    catch {bind TkConsole <Key-Page_Up>   { tkTextScrollPages %W -1 }}
4390    catch {bind TkConsole <Key-Prior>     { tkTextScrollPages %W -1 }}
4391    catch {bind TkConsole <Key-Page_Down> { tkTextScrollPages %W 1 }}
4392    catch {bind TkConsole <Key-Next>      { tkTextScrollPages %W 1 }}
4393    bind TkConsole <$PRIV(meta)-d> {
4394        if {[%W compare insert >= limit]} {
4395            %W delete insert {insert wordend}
4396        }
4397    }
4398    bind TkConsole <$PRIV(meta)-BackSpace> {
4399        if {[%W compare {insert -1c wordstart} >= limit]} {
4400            %W delete {insert -1c wordstart} insert
4401        }
4402    }
4403    bind TkConsole <$PRIV(meta)-Delete> {
4404        if {[%W compare insert >= limit]} {
4405            %W delete insert {insert wordend}
4406        }
4407    }
4408    bind TkConsole <ButtonRelease-2> {
4409        if {
4410            (!$tkPriv(mouseMoved) || $tk_strictMotif) &&
4411            ![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)]
4412        } {
4413            if {[%W compare @%x,%y < limit]} {
4414                %W insert end $::tkcon::PRIV(tmp)
4415            } else {
4416                %W insert @%x,%y $::tkcon::PRIV(tmp)
4417            }
4418            if {[string match *\n* $::tkcon::PRIV(tmp)]} {::tkcon::Eval %W}
4419        }
4420    }
4421
4422    ##
4423    ## End TkConsole bindings
4424    ##
4425
4426    ##
4427    ## Bindings for doing special things based on certain keys
4428    ##
4429    bind TkConsolePost <Key-parenright> {
4430        if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \
4431                [string compare \\ [%W get insert-2c]]} {
4432            ::tkcon::MatchPair %W \( \) limit
4433        }
4434        set ::tkcon::PRIV(StatusCursor) [%W index insert]
4435    }
4436    bind TkConsolePost <Key-bracketright> {
4437        if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \
4438                [string compare \\ [%W get insert-2c]]} {
4439            ::tkcon::MatchPair %W \[ \] limit
4440        }
4441        set ::tkcon::PRIV(StatusCursor) [%W index insert]
4442    }
4443    bind TkConsolePost <Key-braceright> {
4444        if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \
4445                [string compare \\ [%W get insert-2c]]} {
4446            ::tkcon::MatchPair %W \{ \} limit
4447        }
4448        set ::tkcon::PRIV(StatusCursor) [%W index insert]
4449    }
4450    bind TkConsolePost <Key-quotedbl> {
4451        if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \
4452                [string compare \\ [%W get insert-2c]]} {
4453            ::tkcon::MatchQuote %W limit
4454        }
4455        set ::tkcon::PRIV(StatusCursor) [%W index insert]
4456    }
4457
4458    bind TkConsolePost <KeyPress> {
4459        if {$::tkcon::OPT(lightcmd) && [string compare {} %A]} {
4460            ::tkcon::TagProc %W
4461        }
4462        set ::tkcon::PRIV(StatusCursor) [%W index insert]
4463    }
4464
4465    bind TkConsolePost <Button-1> {
4466        set ::tkcon::PRIV(StatusCursor) [%W index insert]
4467    }
4468    bind TkConsolePost <B1-Motion> {
4469        set ::tkcon::PRIV(StatusCursor) [%W index insert]
4470    }
4471
4472}
4473
4474##
4475# ::tkcon::PopupMenu - what to do when the popup menu is requested
4476##
4477proc ::tkcon::PopupMenu {X Y} {
4478    variable PRIV
4479
4480    set w $PRIV(console)
4481    if {[string compare $w [winfo containing $X $Y]]} {
4482        tk_popup $PRIV(popup) $X $Y
4483        return
4484    }
4485    set x [expr {$X-[winfo rootx $w]}]
4486    set y [expr {$Y-[winfo rooty $w]}]
4487    if {[llength [set tags [$w tag names @$x,$y]]]} {
4488        if {[lsearch -exact $tags "proc"] >= 0} {
4489            lappend type "proc"
4490            foreach {first last} [$w tag prevrange proc @$x,$y] {
4491                set word [$w get $first $last]; break
4492            }
4493        }
4494        if {[lsearch -exact $tags "var"] >= 0} {
4495            lappend type "var"
4496            foreach {first last} [$w tag prevrange var @$x,$y] {
4497                set word [$w get $first $last]; break
4498            }
4499        }
4500    }
4501    if {![info exists type]} {
4502        set exp "(^|\[^\\\\\]\[ \t\n\r\])"
4503        set exp2 "\[\[\\\\\\?\\*\]"
4504        set i [$w search -backwards -regexp $exp @$x,$y "@$x,$y linestart"]
4505        if {[string compare {} $i]} {
4506            if {![string match *.0 $i]} {append i +2c}
4507            if {[string compare {} \
4508                    [set j [$w search -regexp $exp $i "$i lineend"]]]} {
4509                append j +1c
4510            } else {
4511                set j "$i lineend"
4512            }
4513            regsub -all $exp2 [$w get $i $j] {\\\0} word
4514            set word [string trim $word {\"$[]{}',?#*}]
4515            if {[llength [EvalAttached [list info commands $word]]]} {
4516                lappend type "proc"
4517            }
4518            if {[llength [EvalAttached [list info vars $word]]]} {
4519                lappend type "var"
4520            }
4521            if {[EvalAttached [list file isfile $word]]} {
4522                lappend type "file"
4523            }
4524        }
4525    }
4526    if {![info exists type] || ![info exists word]} {
4527        tk_popup $PRIV(popup) $X $Y
4528        return
4529    }
4530    $PRIV(context) delete 0 end
4531    $PRIV(context) add command -label "$word" -state disabled
4532    $PRIV(context) add separator
4533    set app [Attach]
4534    if {[lsearch $type proc] != -1} {
4535        $PRIV(context) add command -label "View Procedure" \
4536                -command [list edit -attach $app -type proc -- $word]
4537    }
4538    if {[lsearch $type var] != -1} {
4539        $PRIV(context) add command -label "View Variable" \
4540                -command [list edit -attach $app -type var -- $word]
4541    }
4542    if {[lsearch $type file] != -1} {
4543        $PRIV(context) add command -label "View File" \
4544                -command [list edit -attach $app -type file -- $word]
4545    }
4546    tk_popup $PRIV(context) $X $Y
4547}
4548
4549## ::tkcon::TagProc - tags a procedure in the console if it's recognized
4550## This procedure is not perfect.  However, making it perfect wastes
4551## too much CPU time...
4552##
4553proc ::tkcon::TagProc w {
4554    set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
4555    set i [$w search -backwards -regexp $exp insert-1c limit-1c]
4556    if {[string compare {} $i]} {append i +2c} else {set i limit}
4557    regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
4558    if {[llength [EvalAttached [list info commands $c]]]} {
4559        $w tag add proc $i "insert-1c wordend"
4560    } else {
4561        $w tag remove proc $i "insert-1c wordend"
4562    }
4563    if {[llength [EvalAttached [list info vars $c]]]} {
4564        $w tag add var $i "insert-1c wordend"
4565    } else {
4566        $w tag remove var $i "insert-1c wordend"
4567    }
4568}
4569
4570## ::tkcon::MatchPair - blinks a matching pair of characters
4571## c2 is assumed to be at the text index 'insert'.
4572## This proc is really loopy and took me an hour to figure out given
4573## all possible combinations with escaping except for escaped \'s.
4574## It doesn't take into account possible commenting... Oh well.  If
4575## anyone has something better, I'd like to see/use it.  This is really
4576## only efficient for small contexts.
4577# ARGS: w       - console text widget
4578#       c1      - first char of pair
4579#       c2      - second char of pair
4580# Calls:        ::tkcon::Blink
4581##
4582proc ::tkcon::MatchPair {w c1 c2 {lim 1.0}} {
4583    if {[string compare {} [set ix [$w search -back $c1 insert $lim]]]} {
4584        while {
4585            [string match {\\} [$w get $ix-1c]] &&
4586            [string compare {} [set ix [$w search -back $c1 $ix-1c $lim]]]
4587        } {}
4588        set i1 insert-1c
4589        while {[string compare {} $ix]} {
4590            set i0 $ix
4591            set j 0
4592            while {[string compare {} [set i0 [$w search $c2 $i0 $i1]]]} {
4593                append i0 +1c
4594                if {[string match {\\} [$w get $i0-2c]]} continue
4595                incr j
4596            }
4597            if {!$j} break
4598            set i1 $ix
4599            while {$j && [string compare {} \
4600                    [set ix [$w search -back $c1 $ix $lim]]]} {
4601                if {[string match {\\} [$w get $ix-1c]]} continue
4602                incr j -1
4603            }
4604        }
4605        if {[string match {} $ix]} { set ix [$w index $lim] }
4606    } else { set ix [$w index $lim] }
4607    if {$::tkcon::OPT(blinkrange)} {
4608        Blink $w $ix [$w index insert]
4609    } else {
4610        Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
4611    }
4612}
4613
4614## ::tkcon::MatchQuote - blinks between matching quotes.
4615## Blinks just the quote if it's unmatched, otherwise blinks quoted string
4616## The quote to match is assumed to be at the text index 'insert'.
4617# ARGS: w       - console text widget
4618# Calls:        ::tkcon::Blink
4619##
4620proc ::tkcon::MatchQuote {w {lim 1.0}} {
4621    set i insert-1c
4622    set j 0
4623    while {[string compare [set i [$w search -back \" $i $lim]] {}]} {
4624        if {[string match {\\} [$w get $i-1c]]} continue
4625        if {!$j} {set i0 $i}
4626        incr j
4627    }
4628    if {$j&1} {
4629        if {$::tkcon::OPT(blinkrange)} {
4630            Blink $w $i0 [$w index insert]
4631        } else {
4632            Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
4633        }
4634    } else {
4635        Blink $w [$w index insert-1c] [$w index insert]
4636    }
4637}
4638
4639## ::tkcon::Blink - blinks between n index pairs for a specified duration.
4640# ARGS: w       - console text widget
4641#       i1      - start index to blink region
4642#       i2      - end index of blink region
4643#       dur     - duration in usecs to blink for
4644# Outputs:      blinks selected characters in $w
4645##
4646proc ::tkcon::Blink {w args} {
4647    eval [list $w tag add blink] $args
4648    after $::tkcon::OPT(blinktime) [list $w] tag remove blink $args
4649    return
4650}
4651
4652
4653## ::tkcon::Insert
4654## Insert a string into a text console at the point of the insertion cursor.
4655## If there is a selection in the text, and it covers the point of the
4656## insertion cursor, then delete the selection before inserting.
4657# ARGS: w       - text window in which to insert the string
4658#       s       - string to insert (usually just a single char)
4659# Outputs:      $s to text widget
4660##
4661proc ::tkcon::Insert {w s} {
4662    if {[string match {} $s] || [string match disabled [$w cget -state]]} {
4663        return
4664    }
4665    if {[$w comp insert < limit]} {
4666        $w mark set insert end
4667    }
4668    if {[llength [$w tag ranges sel]] && \
4669            [$w comp sel.first <= insert] && [$w comp sel.last >= insert]} {
4670        $w delete sel.first sel.last
4671    }
4672    $w insert insert $s
4673    $w see insert
4674}
4675
4676## ::tkcon::Expand -
4677# ARGS: w       - text widget in which to expand str
4678#       type    - type of expansion (path / proc / variable)
4679# Calls:        ::tkcon::Expand(Pathname|Procname|Variable)
4680# Outputs:      The string to match is expanded to the longest possible match.
4681#               If ::tkcon::OPT(showmultiple) is non-zero and the user longest
4682#               match equaled the string to expand, then all possible matches
4683#               are output to stdout.  Triggers bell if no matches are found.
4684# Returns:      number of matches found
4685##
4686proc ::tkcon::Expand {w {type ""}} {
4687    set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"$\]"
4688    set tmp [$w search -backwards -regexp $exp insert-1c limit-1c]
4689    if {[string compare {} $tmp]} {append tmp +2c} else {set tmp limit}
4690    if {[$w compare $tmp >= insert]} return
4691    set str [$w get $tmp insert]
4692    switch -glob $type {
4693        pa* { set res [ExpandPathname $str] }
4694        pr* { set res [ExpandProcname $str] }
4695        v*  { set res [ExpandVariable $str] }
4696        default {
4697            set res {}
4698            foreach t $::tkcon::OPT(expandorder) {
4699                if {![catch {Expand$t $str} res] && \
4700                        [string compare {} $res]} break
4701            }
4702        }
4703    }
4704    set len [llength $res]
4705    if {$len} {
4706        $w delete $tmp insert
4707        $w insert $tmp [lindex $res 0]
4708        if {$len > 1} {
4709            if {$::tkcon::OPT(showmultiple) && \
4710                    ![string compare [lindex $res 0] $str]} {
4711                puts stdout [lsort [lreplace $res 0 0]]
4712            }
4713        }
4714    } else { bell }
4715    return [incr len -1]
4716}
4717
4718## ::tkcon::ExpandPathname - expand a file pathname based on $str
4719## This is based on UNIX file name conventions
4720# ARGS: str     - partial file pathname to expand
4721# Calls:        ::tkcon::ExpandBestMatch
4722# Returns:      list containing longest unique match followed by all the
4723#               possible further matches
4724##
4725proc ::tkcon::ExpandPathname str {
4726    set pwd [EvalAttached pwd]
4727    # Cause a string like {C:/Program\ Files/} to become "C:/Program Files/"
4728    regsub -all {\\([][ ])} $str {\1} str
4729    if {[catch {EvalAttached [list cd [file dirname $str]]} err]} {
4730        return -code error $err
4731    }
4732    set dir [file tail $str]
4733    ## Check to see if it was known to be a directory and keep the trailing
4734    ## slash if so (file tail cuts it off)
4735    if {[string match */ $str]} { append dir / }
4736    # Create a safely glob-able name
4737    regsub -all {([][])} $dir {\\\1} safedir
4738    if {[catch {lsort [EvalAttached [list glob $safedir*]]} m]} {
4739        set match {}
4740    } else {
4741        if {[llength $m] > 1} {
4742            global tcl_platform
4743            if {[string match windows $tcl_platform(platform)]} {
4744                ## Windows is screwy because it's case insensitive
4745                set tmp [ExpandBestMatch [string tolower $m] \
4746                        [string tolower $dir]]
4747                ## Don't change case if we haven't changed the word
4748                if {[string length $dir]==[string length $tmp]} {
4749                    set tmp $dir
4750                }
4751            } else {
4752                set tmp [ExpandBestMatch $m $dir]
4753            }
4754            if {[string match */* $str]} {
4755                set tmp [string trimright [file dirname $str] /]/$tmp
4756            }
4757            regsub -all {([^\\])([][ ])} $tmp {\1\\\2} tmp
4758            set match [linsert $m 0 $tmp]
4759        } else {
4760            ## This may look goofy, but it handles spaces in path names
4761            eval append match $m
4762            if {[file isdirectory $match]} {append match /}
4763            if {[string match */* $str]} {
4764                set match [string trimright [file dirname $str] /]/$match
4765            }
4766            regsub -all {([^\\])([][ ])} $match {\1\\\2} match
4767            ## Why is this one needed and the ones below aren't!!
4768            set match [list $match]
4769        }
4770    }
4771    EvalAttached [list cd $pwd]
4772    return $match
4773}
4774
4775## ::tkcon::ExpandProcname - expand a tcl proc name based on $str
4776# ARGS: str     - partial proc name to expand
4777# Calls:        ::tkcon::ExpandBestMatch
4778# Returns:      list containing longest unique match followed by all the
4779#               possible further matches
4780##
4781proc ::tkcon::ExpandProcname str {
4782    set match [EvalAttached [list info commands $str*]]
4783    if {[llength $match] == 0} {
4784        set ns [EvalAttached \
4785                "namespace children \[namespace current\] [list $str*]"]
4786        if {[llength $ns]==1} {
4787            set match [EvalAttached [list info commands ${ns}::*]]
4788        } else {
4789            set match $ns
4790        }
4791    }
4792    if {[llength $match] > 1} {
4793        regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str
4794        set match [linsert $match 0 $str]
4795    } else {
4796        regsub -all {([^\\]) } $match {\1\\ } match
4797    }
4798    return $match
4799}
4800
4801## ::tkcon::ExpandVariable - expand a tcl variable name based on $str
4802# ARGS: str     - partial tcl var name to expand
4803# Calls:        ::tkcon::ExpandBestMatch
4804# Returns:      list containing longest unique match followed by all the
4805#               possible further matches
4806##
4807proc ::tkcon::ExpandVariable str {
4808    if {[regexp {([^\(]*)\((.*)} $str junk ary str]} {
4809        ## Looks like they're trying to expand an array.
4810        set match [EvalAttached [list array names $ary $str*]]
4811        if {[llength $match] > 1} {
4812            set vars $ary\([ExpandBestMatch $match $str]
4813            foreach var $match {lappend vars $ary\($var\)}
4814            return $vars
4815        } else {set match $ary\($match\)}
4816        ## Space transformation avoided for array names.
4817    } else {
4818        set match [EvalAttached [list info vars $str*]]
4819        if {[llength $match] > 1} {
4820            regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str
4821            set match [linsert $match 0 $str]
4822        } else {
4823            regsub -all {([^\\]) } $match {\1\\ } match
4824        }
4825    }
4826    return $match
4827}
4828
4829## ::tkcon::ExpandBestMatch2 - finds the best unique match in a list of names
4830## Improves upon the speed of the below proc only when $l is small
4831## or $e is {}.  $e is extra for compatibility with proc below.
4832# ARGS: l       - list to find best unique match in
4833# Returns:      longest unique match in the list
4834##
4835proc ::tkcon::ExpandBestMatch2 {l {e {}}} {
4836    set s [lindex $l 0]
4837    if {[llength $l]>1} {
4838        set i [expr {[string length $s]-1}]
4839        foreach l $l {
4840            while {$i>=0 && [string first $s $l]} {
4841                set s [string range $s 0 [incr i -1]]
4842            }
4843        }
4844    }
4845    return $s
4846}
4847
4848## ::tkcon::ExpandBestMatch - finds the best unique match in a list of names
4849## The extra $e in this argument allows us to limit the innermost loop a
4850## little further.  This improves speed as $l becomes large or $e becomes long.
4851# ARGS: l       - list to find best unique match in
4852#       e       - currently best known unique match
4853# Returns:      longest unique match in the list
4854##
4855proc ::tkcon::ExpandBestMatch {l {e {}}} {
4856    set ec [lindex $l 0]
4857    if {[llength $l]>1} {
4858        set e  [string length $e]; incr e -1
4859        set ei [string length $ec]; incr ei -1
4860        foreach l $l {
4861            while {$ei>=$e && [string first $ec $l]} {
4862                set ec [string range $ec 0 [incr ei -1]]
4863            }
4864        }
4865    }
4866    return $ec
4867}
4868
4869# Here is a group of functions that is only used when Tkcon is
4870# executed in a safe interpreter. It provides safe versions of
4871# missing functions. For example:
4872#
4873# - "tk appname" returns "tkcon.tcl" but cannot be set
4874# - "toplevel" is equivalent to 'frame', only it is automatically
4875#   packed.
4876# - The 'source', 'load', 'open', 'file' and 'exit' functions are
4877#   mapped to corresponding functions in the parent interpreter.
4878#
4879# Further on, Tk cannot be really loaded. Still the safe 'load'
4880# provedes a speciall case. The Tk can be divided into 4 groups,
4881# that each has a safe handling procedure.
4882#
4883# - "::tkcon::SafeItem" handles commands like 'button', 'canvas' ......
4884#   Each of these functions has the window name as first argument.
4885# - "::tkcon::SafeManage" handles commands like 'pack', 'place', 'grid',
4886#   'winfo', which can have multiple window names as arguments.
4887# - "::tkcon::SafeWindow" handles all windows, such as '.'. For every
4888#   window created, a new alias is formed which also is handled by
4889#   this function.
4890# - Other (e.g. bind, bindtag, image), which need their own function.
4891#
4892## These functions courtesy Jan Nijtmans (nijtmans@nici.kun.nl)
4893##
4894if {[string compare [info command tk] tk]} {
4895    proc tk {option args} {
4896        if {![string match app* $option]} {
4897            error "wrong option \"$option\": should be appname"
4898        }
4899        return "tkcon.tcl"
4900    }
4901}
4902
4903if {[string compare [info command toplevel] toplevel]} {
4904    proc toplevel {name args} {
4905        eval frame $name $args
4906        pack $name
4907    }
4908}
4909
4910proc ::tkcon::SafeSource {i f} {
4911    set fd [open $f r]
4912    set r [read $fd]
4913    close $fd
4914    if {[catch {interp eval $i $r} msg]} {
4915        error $msg
4916    }
4917}
4918
4919proc ::tkcon::SafeOpen {i f {m r}} {
4920    set fd [open $f $m]
4921    interp transfer {} $fd $i
4922    return $fd
4923}
4924
4925proc ::tkcon::SafeLoad {i f p} {
4926    global tk_version tk_patchLevel tk_library auto_path
4927    if {[string compare $p Tk]} {
4928        load $f $p $i
4929    } else {
4930        foreach command {button canvas checkbutton entry frame label
4931        listbox message radiobutton scale scrollbar spinbox text toplevel} {
4932            $i alias $command ::tkcon::SafeItem $i $command
4933        }
4934        $i alias image ::tkcon::SafeImage $i
4935        foreach command {pack place grid destroy winfo} {
4936            $i alias $command ::tkcon::SafeManage $i $command
4937        }
4938        if {[llength [info command event]]} {
4939            $i alias event ::tkcon::SafeManage $i $command
4940        }
4941        frame .${i}_dot -width 300 -height 300 -relief raised
4942        pack .${i}_dot -side left
4943        $i alias tk tk
4944        $i alias bind ::tkcon::SafeBind $i
4945        $i alias bindtags ::tkcon::SafeBindtags $i
4946        $i alias . ::tkcon::SafeWindow $i {}
4947        foreach var {tk_version tk_patchLevel tk_library auto_path} {
4948            $i eval set $var [list [set $var]]
4949        }
4950        $i eval {
4951            package provide Tk $tk_version
4952            if {[lsearch -exact $auto_path $tk_library] < 0} {
4953                lappend auto_path $tk_library
4954            }
4955        }
4956        return ""
4957    }
4958}
4959
4960proc ::tkcon::SafeSubst {i a} {
4961    set arg1 ""
4962    foreach {arg value} $a {
4963        if {![string compare $arg -textvariable] ||
4964        ![string compare $arg -variable]} {
4965            set newvalue "[list $i] $value"
4966            global $newvalue
4967            if {[interp eval $i info exists $value]} {
4968                set $newvalue [interp eval $i set $value]
4969            } else {
4970                catch {unset $newvalue}
4971            }
4972            $i eval trace variable $value rwu \{[list tkcon set $newvalue $i]\}
4973            set value $newvalue
4974        } elseif {![string compare $arg -command]} {
4975            set value [list $i eval $value]
4976        }
4977        lappend arg1 $arg $value
4978    }
4979    return $arg1
4980}
4981
4982proc ::tkcon::SafeItem {i command w args} {
4983    set args [::tkcon::SafeSubst $i $args]
4984    set code [catch "$command [list .${i}_dot$w] $args" msg]
4985    $i alias $w ::tkcon::SafeWindow $i $w
4986    regsub -all .${i}_dot $msg {} msg
4987    return -code $code $msg
4988}
4989
4990proc ::tkcon::SafeManage {i command args} {
4991    set args1 ""
4992    foreach arg $args {
4993        if {[string match . $arg]} {
4994            set arg .${i}_dot
4995        } elseif {[string match .* $arg]} {
4996            set arg ".${i}_dot$arg"
4997        }
4998        lappend args1 $arg
4999    }
5000    set code [catch "$command $args1" msg]
5001    regsub -all .${i}_dot $msg {} msg
5002    return -code $code $msg
5003}
5004
5005#
5006# FIX: this function doesn't work yet if the binding starts with '+'.
5007#
5008proc ::tkcon::SafeBind {i w args} {
5009    if {[string match . $w]} {
5010        set w .${i}_dot
5011    } elseif {[string match .* $w]} {
5012        set w ".${i}_dot$w"
5013    }
5014    if {[llength $args] > 1} {
5015        set args [list [lindex $args 0] \
5016                "[list $i] eval [list [lindex $args 1]]"]
5017    }
5018    set code [catch "bind $w $args" msg]
5019    if {[llength $args] <2 && $code == 0} {
5020        set msg [lindex $msg 3]
5021    }
5022    return -code $code $msg
5023}
5024
5025proc ::tkcon::SafeImage {i option args} {
5026    set code [catch "image $option $args" msg]
5027    if {[string match cr* $option]} {
5028        $i alias $msg $msg
5029    }
5030    return -code $code $msg
5031}
5032
5033proc ::tkcon::SafeBindtags {i w {tags {}}} {
5034    if {[string match . $w]} {
5035        set w .${i}_dot
5036    } elseif {[string match .* $w]} {
5037        set w ".${i}_dot$w"
5038    }
5039    set newtags {}
5040    foreach tag $tags {
5041        if {[string match . $tag]} {
5042            lappend newtags .${i}_dot
5043        } elseif {[string match .* $tag]} {
5044            lappend newtags ".${i}_dot$tag"
5045        } else {
5046            lappend newtags $tag
5047        }
5048    }
5049    if {[string match $tags {}]} {
5050        set code [catch {bindtags $w} msg]
5051        regsub -all \\.${i}_dot $msg {} msg
5052    } else {
5053        set code [catch {bindtags $w $newtags} msg]
5054    }
5055    return -code $code $msg
5056}
5057
5058proc ::tkcon::SafeWindow {i w option args} {
5059    if {[string match conf* $option] && [llength $args] > 1} {
5060        set args [::tkcon::SafeSubst $i $args]
5061    } elseif {[string match itemco* $option] && [llength $args] > 2} {
5062        set args "[list [lindex $args 0]] [::tkcon::SafeSubst $i [lrange $args 1 end]]"
5063    } elseif {[string match cr* $option]} {
5064        if {[llength $args]%2} {
5065            set args "[list [lindex $args 0]] [::tkcon::SafeSubst $i [lrange $args 1 end]]"
5066        } else {
5067            set args [::tkcon::SafeSubst $i $args]
5068        }
5069    } elseif {[string match bi* $option] && [llength $args] > 2} {
5070        set args [list [lindex $args 0] [lindex $args 1] "[list $i] eval [list [lindex $args 2]]"]
5071    }
5072    set code [catch ".${i}_dot$w $option $args" msg]
5073    if {$code} {
5074        regsub -all .${i}_dot $msg {} msg
5075    } elseif {[string match conf* $option] || [string match itemco* $option]} {
5076        if {[llength $args] == 1} {
5077            switch -- $args {
5078                -textvariable - -variable {
5079                    set msg "[lrange $msg 0 3] [list [lrange [lindex $msg 4] 1 end]]"
5080                }
5081                -command - updatecommand {
5082                    set msg "[lrange $msg 0 3] [list [lindex [lindex $msg 4] 2]]"
5083                }
5084            }
5085        } elseif {[llength $args] == 0} {
5086            set args1 ""
5087            foreach el $msg {
5088                switch -- [lindex $el 0] {
5089                    -textvariable - -variable {
5090                        set el "[lrange $el 0 3] [list [lrange [lindex $el 4] 1 end]]"
5091                    }
5092                    -command - updatecommand {
5093                        set el "[lrange $el 0 3] [list [lindex [lindex $el 4] 2]]"
5094                    }
5095                }
5096                lappend args1 $el
5097            }
5098            set msg $args1
5099        }
5100    } elseif {[string match cg* $option] || [string match itemcg* $option]} {
5101        switch -- $args {
5102            -textvariable - -variable {
5103                set msg [lrange $msg 1 end]
5104            }
5105            -command - updatecommand {
5106                set msg [lindex $msg 2]
5107            }
5108        }
5109    } elseif {[string match bi* $option]} {
5110        if {[llength $args] == 2 && $code == 0} {
5111            set msg [lindex $msg 2]
5112        }
5113    }
5114    return -code $code $msg
5115}
5116
5117proc ::tkcon::RetrieveFilter {host} {
5118    variable PRIV
5119    set result {}
5120    if {[info exists PRIV(proxy)]} {
5121        if {![regexp "^(localhost|127\.0\.0\.1)" $host]} {
5122            set result [lrange [split [lindex $PRIV(proxy) 0] :] 0 1]
5123        }
5124    }
5125    return $result
5126}
5127
5128proc ::tkcon::RetrieveAuthentication {} {
5129    package require Tk
5130    if {[catch {package require base64}]} {
5131        if {[catch {package require Trf}]} {
5132            error "base64 support not available"
5133        } else {
5134            set local64 "base64 -mode enc"
5135        }
5136    } else {
5137        set local64 "base64::encode"
5138    }
5139
5140    set dlg [toplevel .auth]
5141    wm title $dlg "Authenticating Proxy Configuration"
5142    set f1 [frame ${dlg}.f1]
5143    set f2 [frame ${dlg}.f2]
5144    button $f2.b -text "OK" -command "destroy $dlg"
5145    pack $f2.b -side right
5146    label $f1.l2 -text "Username"
5147    label $f1.l3 -text "Password"
5148    entry $f1.e2 -textvariable "[namespace current]::conf_userid"
5149    entry $f1.e3 -textvariable "[namespace current]::conf_passwd" -show *
5150    grid $f1.l2 -column 0 -row 0 -sticky e
5151    grid $f1.l3 -column 0 -row 1 -sticky e
5152    grid $f1.e2 -column 1 -row 0 -sticky news
5153    grid $f1.e3 -column 1 -row 1 -sticky news
5154    grid columnconfigure $f1 1 -weight 1
5155    pack $f2 -side bottom -fill x
5156    pack $f1 -side top -anchor n -fill both -expand 1
5157    tkwait window $dlg
5158    set result {}
5159    if {[info exists [namespace current]::conf_userid]} {
5160        set data [subst $[namespace current]::conf_userid]
5161        append data : [subst $[namespace current]::conf_passwd]
5162        set data [$local64 $data]
5163        set result [list "Proxy-Authorization" "Basic $data"]
5164    }
5165    unset [namespace current]::conf_passwd
5166    return $result
5167}
5168
5169proc ::tkcon::Retrieve {} {
5170    # A little bit'o'magic to grab the latest tkcon from CVS and
5171    # save it locally.  It doesn't support proxies though...
5172    variable PRIV
5173
5174    set defExt ""
5175    if {[string match "windows" $::tcl_platform(platform)]} {
5176        set defExt ".tcl"
5177    }
5178    set file [tk_getSaveFile -title "Save Latest tkcon to ..." \
5179            -defaultextension $defExt \
5180            -initialdir  [file dirname $PRIV(SCRIPT)] \
5181            -initialfile [file tail $PRIV(SCRIPT)] \
5182            -parent $PRIV(root) \
5183            -filetypes {{"Tcl Files" {.tcl .tk}} {"All Files" {*.*}}}]
5184    if {[string compare $file ""]} {
5185        package require http 2
5186        set token [::http::geturl $PRIV(HEADURL) -timeout 30000]
5187        ::http::wait $token
5188        set code [catch {
5189            if {[::http::status $token] == "ok"} {
5190                set fid [open $file w]
5191                # We don't want newline mode to change
5192                fconfigure $fid -translation binary
5193                set data [::http::data $token]
5194                puts -nonewline $fid $data
5195                close $fid
5196                regexp {Id: tkcon.tcl,v (\d+\.\d+)} $data -> rcsVersion
5197                regexp {version\s+(\d+\.\d[^\n]*)} $data -> tkconVersion
5198            }
5199        } err]
5200        ::http::cleanup $token
5201        if {$code} {
5202            return -code error $err
5203        } elseif {[tk_messageBox -type yesno -icon info -parent $PRIV(root) \
5204                -title "Retrieved tkcon v$tkconVersion, RCS $rcsVersion" \
5205                -message "Successfully retrieved tkcon v$tkconVersion,\
5206                RCS $rcsVersion.  Shall I resource (not restart) this\
5207                version now?"] == "yes"} {
5208            set PRIV(SCRIPT) $file
5209            set PRIV(version) $tkconVersion.$rcsVersion
5210            ::tkcon::Resource
5211        }
5212    }
5213}
5214
5215## ::tkcon::Resource - re'source's this script into current console
5216## Meant primarily for my development of this program.  It follows
5217## links until the ultimate source is found.
5218##
5219set ::tkcon::PRIV(SCRIPT) [info script]
5220if {!$::tkcon::PRIV(WWW) && [string compare $::tkcon::PRIV(SCRIPT) {}]} {
5221    # we use a catch here because some wrap apps choke on 'file type'
5222    # because TclpLstat wasn't wrappable until 8.4.
5223    catch {
5224        while {[string match link [file type $::tkcon::PRIV(SCRIPT)]]} {
5225            set link [file readlink $::tkcon::PRIV(SCRIPT)]
5226            if {[string match relative [file pathtype $link]]} {
5227                set ::tkcon::PRIV(SCRIPT) \
5228                        [file join [file dirname $::tkcon::PRIV(SCRIPT)] $link]
5229            } else {
5230                set ::tkcon::PRIV(SCRIPT) $link
5231            }
5232        }
5233        catch {unset link}
5234        if {[string match relative [file pathtype $::tkcon::PRIV(SCRIPT)]]} {
5235            set ::tkcon::PRIV(SCRIPT) [file join [pwd] $::tkcon::PRIV(SCRIPT)]
5236        }
5237    }
5238}
5239
5240proc ::tkcon::Resource {} {
5241    uplevel \#0 {
5242        if {[catch {source -rsrc tkcon}]} { source $::tkcon::PRIV(SCRIPT) }
5243    }
5244    Bindings
5245    InitSlave $::tkcon::OPT(exec)
5246}
5247
5248## Initialize only if we haven't yet
5249##
5250if {![info exists ::tkcon::PRIV(root)] || \
5251        ![winfo exists $::tkcon::PRIV(root)]} {
5252    ::tkcon::Init
5253}
Note: See TracBrowser for help on using the repository browser.