source: trunk/tkcon/tkcon.tcl

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

tkcon fixes; implement gnome-terminal if xterm is not found

  • Property svn:executable set to *
File size: 186.5 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, Jan Nijtmans, Mark Crimmins, Wart
14##
15## Copyright (c) 1995-2004 Jeffrey Hobbs, jeff(a)hobbs(.)org
16## Initiated: Thu Aug 17 15:36:47 PDT 1995
17##
18## source standard_disclaimer.tcl
19## source bourbon_ware.tcl
20##
21
22# Proxy support for retrieving the current version of Tkcon.
23#
24# Mon Jun 25 12:19:56 2001 - Pat Thoyts
25#
26# In your tkcon.cfg or .tkconrc file put your proxy details into the
27# `proxy' member of the `PRIV' array. e.g.:
28#
29#    set ::tkcon::PRIV(proxy) wwwproxy:8080
30#
31# If you want to be prompted for proxy authentication details (eg for
32# an NT proxy server) make the second element of this variable non-nil - eg:
33#
34#    set ::tkcon::PRIV(proxy) {wwwproxy:8080 1}
35#
36# Or you can set the above variable from within tkcon by calling
37#
38#    tkcon master set ::tkcon:PRIV(proxy) wwwproxy:8080
39#
40
41if {$tcl_version < 8.0} {
42    return -code error "tkcon requires at least Tcl/Tk8"
43} else {
44#    package require -exact Tk $tcl_version; # exact causes a problem with Tk 8.5+
45    package require Tk $tcl_version
46}
47
48# We need to load some package to get what's available, and we
49# choose ctext because we'll use it if its available in the editor
50catch {package require ctext}
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    # when modifying this line, make sure that the auto-upgrade check
78    # for version still works.
79    variable VERSION "2.4"
80    # The OPT variable is an array containing most of the optional
81    # info to configure.  COLOR has the color data.
82    variable OPT
83    variable COLOR
84
85    # PRIV is used for internal data that only tkcon should fiddle with.
86    variable PRIV
87    set PRIV(WWW) [info exists embed_args]
88
89    variable EXPECT 0
90}
91
92## ::tkcon::Init - inits tkcon
93#
94# Calls:        ::tkcon::InitUI
95# Outputs:      errors found in tkcon's resource file
96##
97proc ::tkcon::Init {args} {
98    variable VERSION
99    variable OPT
100    variable COLOR
101    variable PRIV
102    global tcl_platform env tcl_interactive errorInfo
103
104    set tcl_interactive 1
105    set argc [llength $args]
106
107    ##
108    ## When setting up all the default values, we always check for
109    ## prior existence.  This allows users who embed tkcon to modify
110    ## the initial state before tkcon initializes itself.
111    ##
112
113    # bg == {} will get bg color from the main toplevel (in InitUI)
114    foreach {key default} {
115        bg              {}
116        blink           \#FFFF00
117        cursor          \#000000
118        disabled        \#4D4D4D
119        proc            \#008800
120        var             \#FFC0D0
121        prompt          \#8F4433
122        stdin           \#000000
123        stdout          \#0000FF
124        stderr          \#FF0000
125    } {
126        if {![info exists COLOR($key)]} { set COLOR($key) $default }
127    }
128
129    # expandorder could also include 'Xotcl' (before Procname)
130    foreach {key default} {
131        autoload        {}
132        blinktime       500
133        blinkrange      1
134        buffer          512
135        maxlinelen      0
136        calcmode        0
137        cols            80
138        debugPrompt     {(level \#$level) debug [history nextid] > }
139        dead            {}
140        edit            edit
141        expandorder     {Pathname Variable Procname}
142        font            {}
143        history         48
144        hoterrors       1
145        library         {}
146        lightbrace      1
147        lightcmd        1
148        maineval        {}
149        maxmenu         18
150        nontcl          0
151        prompt1         {ignore this, it's set below}
152        rows            20
153        scrollypos      right
154        showmenu        1
155        showmultiple    1
156        showstatusbar   1
157        slaveeval       {}
158        slaveexit       close
159        subhistory      1
160        gc-delay        60000
161        gets            {congets}
162        overrideexit    1
163        usehistory      1
164
165        exec            slave
166    } {
167        if {![info exists OPT($key)]} { set OPT($key) $default }
168    }
169
170    foreach {key default} {
171        app             {}
172        appname         {}
173        apptype         slave
174        namesp          ::
175        cmd             {}
176        cmdbuf          {}
177        cmdsave         {}
178        event           1
179        deadapp         0
180        deadsock        0
181        debugging       0
182        displayWin      .
183        histid          0
184        find            {}
185        find,case       0
186        find,reg        0
187        errorInfo       {}
188        protocol        exit
189        showOnStartup   1
190        slaveprocs      {
191            alias clear dir dump echo idebug lremove
192            tkcon_puts tkcon_gets observe observe_var unalias which what
193        }
194        RCS             {RCS: @(#) $Id: tkcon.tcl,v 1.89 2005/09/12 19:07:17 hobbs Exp $}
195        HEADURL         {http://cvs.sourceforge.net/viewcvs.py/*checkout*/tkcon/tkcon/tkcon.tcl?rev=HEAD}
196
197        docs            "http://tkcon.sourceforge.net/"
198        email           {jeff(a)hobbs(.)org}
199        root            .
200        uid             0
201        tabs            {}
202    } {
203        if {![info exists PRIV($key)]} { set PRIV($key) $default }
204    }
205    foreach {key default} {
206        slavealias      { $OPT(edit) more less tkcon }
207    } {
208        if {![info exists PRIV($key)]} { set PRIV($key) [subst $default] }
209    }
210    set PRIV(version) $VERSION
211
212    option add *Menu.tearOff 0
213    option add *takeFocus 0
214
215    if {[info exists PRIV(name)]} {
216        set title $PRIV(name)
217    } else {
218        MainInit
219        # some main initialization occurs later in this proc,
220        # to go after the UI init
221        set MainInit 1
222        set title Main
223    }
224
225    ## NOTES FOR STAYING IN PRIMARY INTERPRETER:
226    ##
227    ## If you set ::tkcon::OPT(exec) to {}, then instead of a multiple
228    ## interp model, you get tkcon operating in the main interp by default.
229    ## This can be useful when attaching to programs that like to operate
230    ## in the main interpter (for example, based on special wish'es).
231    ## You can set this from the command line with -exec ""
232    ## A side effect is that all tkcon command line args will be used
233    ## by the first console only.
234    #set OPT(exec) {}
235
236    if {$PRIV(WWW)} {
237        lappend PRIV(slavealias) history
238        set OPT(prompt1) {[history nextid] % }
239    } else {
240        lappend PRIV(slaveprocs) tcl_unknown unknown
241        set OPT(prompt1) {([file tail [pwd]]) [history nextid] % }
242    }
243
244    ## If we are using the default '.' toplevel, and there appear to be
245    ## children of '.', then make sure we use a disassociated toplevel.
246    if {$PRIV(root) == "." && [llength [winfo children .]]} {
247        set PRIV(root) .tkcon
248    }
249
250    ## Do platform specific configuration here, other than defaults
251    ### Use tkcon.cfg filename for resource filename on non-unix systems
252    ### Determine what directory the resource file should be in
253    switch $tcl_platform(platform) {
254        macintosh       {
255            if {![interp issafe]} {cd [file dirname [info script]]}
256            set envHome         PREF_FOLDER
257            set rcfile          tkcon.cfg
258            set histfile        tkcon.hst
259            catch {console hide}
260        }
261        windows         {
262            set envHome         HOME
263            set rcfile          tkcon.cfg
264            set histfile        tkcon.hst
265        }
266        unix            {
267            set envHome         HOME
268            set rcfile          .tkconrc
269            set histfile        .tkcon_history
270        }
271    }
272    if {[info exists env($envHome)]} {
273        set home $env($envHome)
274        if {[file pathtype $home] == "volumerelative"} {
275            # Convert 'C:' to 'C:/' if necessary, innocuous otherwise
276            append home /
277        }
278        if {![info exists PRIV(rcfile)]} {
279            set PRIV(rcfile)    [file join $home $rcfile]
280        }
281        if {![info exists PRIV(histfile)]} {
282            set PRIV(histfile)  [file join $home $histfile]
283        }
284    }
285
286    ## Handle command line arguments before sourcing resource file to
287    ## find if resource file is being specified (let other args pass).
288    if {[set i [lsearch -exact $args -rcfile]] != -1} {
289        set PRIV(rcfile) [lindex $args [incr i]]
290    }
291
292    if {!$PRIV(WWW) && [file exists $PRIV(rcfile)]} {
293        set code [catch {uplevel \#0 [list source $PRIV(rcfile)]} err]
294    }
295
296    if {[info exists env(TK_CON_LIBRARY)]} {
297        lappend ::auto_path $env(TK_CON_LIBRARY)
298    } elseif {$OPT(library) != ""} {
299        lappend ::auto_path $OPT(library)
300    }
301
302    if {![info exists ::tcl_pkgPath]} {
303        set dir [file join [file dirname [info nameofexec]] lib]
304        if {[llength [info commands @scope]]} {
305            set dir [file join $dir itcl]
306        }
307        catch {source [file join $dir pkgIndex.tcl]}
308    }
309    catch {tclPkgUnknown dummy-name dummy-version}
310
311    ## Handle rest of command line arguments after sourcing resource file
312    ## and slave is created, but before initializing UI or setting packages.
313    set slaveargs {}
314    set slavefiles {}
315    set truth {^(1|yes|true|on)$}
316    for {set i 0} {$i < $argc} {incr i} {
317        set arg [lindex $args $i]
318        if {[string match {-*} $arg]} {
319            set val [lindex $args [incr i]]
320            ## Handle arg based options
321            switch -glob -- $arg {
322                -- - -argv - -args {
323                    set argv [concat -- [lrange $argv $i end]]
324                    set argc [llength $argv]
325                    break
326                }
327                -color-*        { set COLOR([string range $arg 7 end]) $val }
328                -exec           { set OPT(exec) $val }
329                -main - -e - -eval      { append OPT(maineval) \n$val\n }
330                -package - -load        { lappend OPT(autoload) $val }
331                -slave          { append OPT(slaveeval) \n$val\n }
332                -nontcl         { set OPT(nontcl) [regexp -nocase $truth $val]}
333                -root           { set PRIV(root) $val }
334                -font           { set OPT(font) $val }
335                -rcfile {}
336                default { lappend slaveargs $arg; incr i -1 }
337            }
338        } elseif {[file isfile $arg]} {
339            lappend slavefiles $arg
340        } else {
341            lappend slaveargs $arg
342        }
343    }
344
345    ## Create slave executable
346    if {"" != $OPT(exec)} {
347        uplevel \#0 ::tkcon::InitSlave $OPT(exec) $slaveargs
348    } else {
349        set argc [llength $slaveargs]
350        set args $slaveargs
351        uplevel \#0 $slaveargs
352    }
353
354    ## Attach to the slave, EvalAttached will then be effective
355    Attach $PRIV(appname) $PRIV(apptype)
356    InitUI $title
357    if {"" != $OPT(exec)} {
358        # override exit to DeleteTab now that tab has been created
359        $OPT(exec) alias exit ::tkcon::DeleteTab $PRIV(curtab) $OPT(exec)
360    }
361
362    ## swap puts and gets with the tkcon versions to make sure all
363    ## input and output is handled by tkcon
364    if {![catch {rename ::puts ::tkcon_tcl_puts}]} {
365        interp alias {} ::puts {} ::tkcon_puts
366    }
367    if {($OPT(gets) != "") && ![catch {rename ::gets ::tkcon_tcl_gets}]} {
368        interp alias {} ::gets {} ::tkcon_gets
369    }
370
371    EvalSlave history keep $OPT(history)
372    if {[info exists MainInit]} {
373        # Source history file only for the main console, as all slave
374        # consoles will adopt from the main's history, but still
375        # keep separate histories
376        if {!$PRIV(WWW) && $OPT(usehistory) && [file exists $PRIV(histfile)]} {
377            puts -nonewline "loading history file ... "
378            # The history file is built to be loaded in and
379            # understood by tkcon
380            if {[catch {uplevel \#0 [list source $PRIV(histfile)]} herr]} {
381                puts stderr "error:\n$herr"
382                append PRIV(errorInfo) $errorInfo\n
383            }
384            set PRIV(event) [EvalSlave history nextid]
385            puts "[expr {$PRIV(event)-1}] events added"
386        }
387    }
388
389    ## Autoload specified packages in slave
390    set pkgs [EvalSlave package names]
391    foreach pkg $OPT(autoload) {
392        puts -nonewline "autoloading package \"$pkg\" ... "
393        if {[lsearch -exact $pkgs $pkg]>-1} {
394            if {[catch {EvalSlave package require [list $pkg]} pkgerr]} {
395                puts stderr "error:\n$pkgerr"
396                append PRIV(errorInfo) $errorInfo\n
397            } else { puts "OK" }
398        } else {
399            puts stderr "error: package does not exist"
400        }
401    }
402
403    ## Evaluate maineval in slave
404    if {[string compare {} $OPT(maineval)] && \
405            [catch {uplevel \#0 $OPT(maineval)} merr]} {
406        puts stderr "error in eval:\n$merr"
407        append PRIV(errorInfo) $errorInfo\n
408    }
409
410    ## Source extra command line argument files into slave executable
411    foreach fn $slavefiles {
412        puts -nonewline "slave sourcing \"$fn\" ... "
413        if {[catch {EvalSlave source [list $fn]} fnerr]} {
414            puts stderr "error:\n$fnerr"
415            append PRIV(errorInfo) $errorInfo\n
416        } else { puts "OK" }
417    }
418
419    ## Evaluate slaveeval in slave
420    if {[string compare {} $OPT(slaveeval)] && \
421            [catch {interp eval $OPT(exec) $OPT(slaveeval)} serr]} {
422        puts stderr "error in slave eval:\n$serr"
423        append PRIV(errorInfo) $errorInfo\n
424    }
425    ## Output any error/output that may have been returned from rcfile
426    if {[info exists code] && $code && [string compare {} $err]} {
427        puts stderr "error in $PRIV(rcfile):\n$err"
428        append PRIV(errorInfo) $errorInfo
429    }
430    if {[string compare {} $OPT(exec)]} {
431        StateCheckpoint [concat $PRIV(name) $OPT(exec)] slave
432    }
433    StateCheckpoint $PRIV(name) slave
434
435    puts "buffer line limit:\
436        [expr {$OPT(buffer)?$OPT(buffer):{unlimited}}]  \
437        max line length:\
438        [expr {$OPT(maxlinelen)?$OPT(maxlinelen):{unlimited}}]"
439
440    Prompt "$title console display active (Tcl$::tcl_patchLevel / Tk$::tk_patchLevel)\n"
441}
442
443## ::tkcon::InitSlave - inits the slave by placing key procs and aliases in it
444## It's arg[cv] are based on passed in options, while argv0 is the same as
445## the master.  tcl_interactive is the same as the master as well.
446# ARGS: slave   - name of slave to init.  If it does not exist, it is created.
447#       args    - args to pass to a slave as argv/argc
448##
449proc ::tkcon::InitSlave {slave args} {
450    variable OPT
451    variable COLOR
452    variable PRIV
453    global argv0 tcl_interactive tcl_library env auto_path tk_library
454
455    if {[string match {} $slave]} {
456        return -code error "Don't init the master interpreter, goofball"
457    }
458    if {![interp exists $slave]} { interp create $slave }
459    if {[interp eval $slave info command source] == ""} {
460        $slave alias source SafeSource $slave
461        $slave alias load SafeLoad $slave
462        $slave alias open SafeOpen $slave
463        $slave alias file file
464        interp eval $slave \
465            [list set auto_path [lremove $auto_path $tk_library]]
466        interp eval $slave [dump var -nocomplain tcl_library env]
467        interp eval $slave { catch {source [file join $tcl_library init.tcl]} }
468        interp eval $slave { catch unknown }
469    }
470    # This will likely be overridden to call DeleteTab where possible
471    $slave alias exit exit
472    interp eval $slave {
473        # Do package require before changing around puts/gets
474        catch {package require bogus-package-name}
475        catch {rename ::puts ::tkcon_tcl_puts}
476    }
477    foreach cmd $PRIV(slaveprocs) { $slave eval [dump proc $cmd] }
478    foreach cmd $PRIV(slavealias) { $slave alias $cmd $cmd }
479    interp alias $slave ::ls $slave ::dir -full
480    interp alias $slave ::puts $slave ::tkcon_puts
481    if {$OPT(gets) != ""} {
482        interp eval $slave { catch {rename ::gets ::tkcon_tcl_gets} }
483        interp alias $slave ::gets $slave ::tkcon_gets
484    }
485    if {[info exists argv0]} {interp eval $slave [list set argv0 $argv0]}
486    interp eval $slave set tcl_interactive $tcl_interactive \; \
487            set auto_path [list [lremove $auto_path $tk_library]] \; \
488            set argc [llength $args] \; \
489            set argv  [list $args] \; {
490        if {![llength [info command bgerror]]} {
491            proc bgerror err {
492                global errorInfo
493                set body [info body bgerror]
494                rename ::bgerror {}
495                if {[auto_load bgerror]} { return [bgerror $err] }
496                proc bgerror err $body
497                tkcon bgerror $err $errorInfo
498            }
499        }
500    }
501
502    foreach pkg [lremove [package names] Tcl] {
503        foreach v [package versions $pkg] {
504            interp eval $slave [list package ifneeded $pkg $v \
505                    [package ifneeded $pkg $v]]
506        }
507    }
508}
509
510## ::tkcon::InitInterp - inits an interpreter by placing key
511## procs and aliases in it.
512# ARGS: name    - interp name
513#       type    - interp type (slave|interp)
514##
515proc ::tkcon::InitInterp {name type} {
516    variable OPT
517    variable PRIV
518
519    ## Don't allow messing up a local master interpreter
520    if {[string match namespace $type] || ([string match slave $type] && \
521            [regexp {^([Mm]ain|Slave[0-9]+)$} $name])} return
522    set old [Attach]
523    set oldname $PRIV(namesp)
524    catch {
525        Attach $name $type
526        EvalAttached { catch {rename ::puts ::tkcon_tcl_puts} }
527        foreach cmd $PRIV(slaveprocs) { EvalAttached [dump proc $cmd] }
528        switch -exact $type {
529            slave {
530                foreach cmd $PRIV(slavealias) {
531                    Main interp alias $name ::$cmd $PRIV(name) ::$cmd
532                }
533            }
534            interp {
535                set thistkcon [::send::appname]
536                foreach cmd $PRIV(slavealias) {
537                    EvalAttached "proc $cmd args { ::send::send [list $thistkcon] $cmd \$args }"
538                }
539            }
540        }
541        ## Catch in case it's a 7.4 (no 'interp alias') interp
542        EvalAttached {
543            catch {interp alias {} ::ls {} ::dir -full}
544            if {[catch {interp alias {} ::puts {} ::tkcon_puts}]} {
545                catch {rename ::tkcon_puts ::puts}
546            }
547        }
548        if {$OPT(gets) != ""} {
549            EvalAttached {
550                catch {rename ::gets ::tkcon_tcl_gets}
551                if {[catch {interp alias {} ::gets {} ::tkcon_gets}]} {
552                    catch {rename ::tkcon_gets ::gets}
553                }
554            }
555        }
556        return
557    } {err}
558    eval Attach $old
559    AttachNamespace $oldname
560    if {[string compare {} $err]} { return -code error $err }
561}
562
563## ::tkcon::InitUI - inits UI portion (console) of tkcon
564## Creates all elements of the console window and sets up the text tags
565# ARGS: root    - widget pathname of the tkcon console root
566#       title   - title for the console root and main (.) windows
567# Calls:        ::tkcon::InitMenus, ::tkcon::Prompt
568##
569proc ::tkcon::InitUI {title} {
570    variable OPT
571    variable PRIV
572    variable COLOR
573
574    set root $PRIV(root)
575    if {[string match . $root]} { set w {} } else { set w [toplevel $root] }
576    if {!$PRIV(WWW)} {
577        wm withdraw $root
578        wm protocol $root WM_DELETE_WINDOW $PRIV(protocol)
579    }
580    set PRIV(base) $w
581
582    catch {font create tkconfixed -family Courier -size -12}
583    catch {font create tkconfixedbold -family Courier -size -12 -weight bold}
584
585    set PRIV(statusbar) [set sbar [frame $w.fstatus]]
586    set PRIV(tabframe)  [frame $sbar.tabs]
587    set PRIV(X) [button $sbar.deltab -text "X" -command ::tkcon::DeleteTab \
588                     -activeforeground red -fg red -font tkconfixedbold \
589                     -highlightthickness 0 -padx 2 -pady 0 -bd 1 \
590                     -state disabled -relief flat]
591    catch {$PRIV(X) configure -overrelief raised}
592    label $sbar.cursor -relief sunken -bd 1 -anchor e -width 6 \
593            -textvariable ::tkcon::PRIV(StatusCursor)
594    set padx [expr {![info exists ::tcl_platform(os)]
595                    || ![string match "Windows CE" $::tcl_platform(os)]}]
596    grid $PRIV(X) $PRIV(tabframe) $sbar.cursor -sticky news -padx $padx
597    grid configure $PRIV(tabframe) -sticky nsw
598    grid configure $PRIV(X) -pady 0 -padx 0
599    grid columnconfigure $sbar 1 -weight 1
600    grid rowconfigure $sbar 0 -weight 1
601    grid rowconfigure $PRIV(tabframe) 0 -weight 1
602    if {$::tcl_version >= 8.4 && [tk windowingsystem] == "aqua"} {
603        # resize control space
604        grid columnconfigure $sbar [lindex [grid size $sbar] 0] -minsize 16
605    }
606
607    ## Create console tab
608    set con [InitTab $w]
609    set PRIV(curtab) $con
610
611    # Only apply this for the first console
612    $con configure -setgrid 1 -width $OPT(cols) -height $OPT(rows)
613    bind $PRIV(root) <Configure> {
614        if {"%W" == $::tkcon::PRIV(root)} {
615            scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \
616                ::tkcon::OPT(cols) ::tkcon::OPT(rows)
617            if {[info exists ::tkcon::EXP(spawn_id)]} {
618                catch {stty rows $::tkcon::OPT(rows) columns \
619                           $::tkcon::OPT(cols) < $::tkcon::EXP(slave,name)}
620            }
621        }
622    }
623
624    # scrollbar
625    set sy [scrollbar $w.sy -takefocus 0 -bd 1 -command [list $con yview]]
626    if {!$PRIV(WWW) && [string match "Windows CE" $::tcl_platform(os)]} {
627        $w.sy configure -width 10
628    }
629
630    $con configure -yscrollcommand [list $sy set]
631    set PRIV(console) $con
632    set PRIV(scrolly) $sy
633
634    ## Menus
635    ## catch against use in plugin
636    if {[catch {menu $w.mbar} PRIV(menubar)]} {
637        set PRIV(menubar) [frame $w.mbar -relief raised -bd 1]
638    }
639
640    InitMenus $PRIV(menubar) $title
641    Bindings
642
643    if {$OPT(showmenu)} {
644        $root configure -menu $PRIV(menubar)
645    }
646
647    grid $con  -row 1 -column 1 -sticky news
648    grid $sy   -row 1 -column [expr {$OPT(scrollypos)=="left"?0:2}] -sticky ns
649    grid $sbar -row 2 -column 0 -columnspan 3 -sticky ew
650
651    grid columnconfigure $root 1 -weight 1
652    grid rowconfigure    $root 1 -weight 1
653
654    if {!$OPT(showstatusbar)} {
655        grid remove $sbar
656    }
657
658    if {!$PRIV(WWW)} {
659        wm title $root "tkcon $PRIV(version) $title"
660        if {$PRIV(showOnStartup)} { wm deiconify $root }
661    }
662    if {$PRIV(showOnStartup)} { focus -force $PRIV(console) }
663    if {$OPT(gc-delay)} {
664        after $OPT(gc-delay) ::tkcon::GarbageCollect
665    }
666}
667
668proc ::tkcon::InitTab {w} {
669    variable OPT
670    variable PRIV
671    variable COLOR
672    variable ATTACH
673
674    # text console
675    set con $w.tab[incr PRIV(uid)]
676    text $con -wrap char -foreground $COLOR(stdin) \
677        -insertbackground $COLOR(cursor)
678    $con mark set output 1.0
679    $con mark set limit 1.0
680    if {[string compare {} $COLOR(bg)]} {
681        $con configure -background $COLOR(bg)
682    }
683    set COLOR(bg) [$con cget -background]
684    if {[string compare {} $OPT(font)]} {
685        ## Set user-requested font, if any
686        $con configure -font $OPT(font)
687    } elseif {[string compare unix $::tcl_platform(platform)]} {
688        ## otherwise make sure the font is monospace
689        set font [$con cget -font]
690        if {![font metrics $font -fixed]} {
691            $con configure -font tkconfixed
692        }
693    } else {
694        $con configure -font tkconfixed
695    }
696    set OPT(font) [$con cget -font]
697    bindtags $con [list $con TkConsole TkConsolePost $PRIV(root) all]
698
699    # scrollbar
700    if {!$PRIV(WWW)} {
701        if {[string match "Windows CE" $::tcl_platform(os)]} {
702            font configure tkconfixed -family Tahoma -size 8
703            $con configure -font tkconfixed -bd 0 -padx 0 -pady 0
704            set cw [font measure tkconfixed "0"]
705            set ch [font metrics tkconfixed -linespace]
706            set sw [winfo screenwidth $con]
707            set sh [winfo screenheight $con]
708            # We need the magic hard offsets until I find a way to
709            # correctly assume size
710            if {$cw*($OPT(cols)+2) > $sw} {
711                set OPT(cols) [expr {($sw / $cw) - 2}]
712            }
713            if {$ch*($OPT(rows)+3) > $sh} {
714                set OPT(rows) [expr {($sh / $ch) - 3}]
715            }
716            # Place it so that the titlebar underlaps the CE titlebar
717            wm geometry $PRIV(root) +0+0
718        }
719    }
720    $con configure -height $OPT(rows) -width $OPT(cols)
721
722    foreach col {prompt stdout stderr stdin proc} {
723        $con tag configure $col -foreground $COLOR($col)
724    }
725    $con tag configure var -background $COLOR(var)
726    $con tag raise sel
727    $con tag configure blink -background $COLOR(blink)
728    $con tag configure find -background $COLOR(blink)
729
730    set ATTACH($con) [Attach]
731    set rb [radiobutton $PRIV(tabframe).cb[winfo name $con] \
732                -textvariable ::tkcon::ATTACH($con) \
733                -selectcolor white -relief sunken \
734                -indicatoron 0 -padx 0 -pady 0 -bd 1 \
735                -variable ::tkcon::PRIV(curtab) -value $con \
736                -command [list ::tkcon::GotoTab $con]]
737    if {$::tcl_version >= 8.4} {
738        $rb configure -offrelief flat -overrelief raised
739    }
740    grid $rb -row 0 -column [lindex [grid size $PRIV(tabframe)] 0] -sticky ns
741    grid $con -row 1 -column 1 -sticky news
742
743    lappend PRIV(tabs) $con
744    return $con
745}
746
747proc ::tkcon::GotoTab {con} {
748    variable PRIV
749    variable ATTACH
750
751    set numtabs [llength $PRIV(tabs)]
752    #if {$numtabs == 1} { return }
753
754    if {[regexp {^[0-9]+$} $con]} {
755        set curtab [lsearch -exact $PRIV(tabs) $PRIV(console)]
756        set nexttab [expr {$curtab + $con}]
757        if {$nexttab >= $numtabs} {
758            set nexttab 0
759        } elseif {$nexttab < 0} {
760            set nexttab "end"
761        }
762        set con [lindex $PRIV(tabs) $nexttab]
763    } elseif {$con == $PRIV(console)} {
764        return
765    }
766
767    # adjust console
768    if {[winfo exists $PRIV(console)]} {
769        lower $PRIV(console)
770        $PRIV(console) configure -yscrollcommand {}
771        set ATTACH($PRIV(console)) [Attach]
772    }
773    set PRIV(console) $con
774    $con configure -yscrollcommand [list $PRIV(scrolly) set]
775    $PRIV(scrolly) configure -command [list $con yview]
776
777    # adjust attach
778    eval [linsert $ATTACH($con) 0 Attach]
779
780    set PRIV(curtab) $con
781
782    raise $con
783
784    if {[$con compare 1.0 == end-1c]} {
785        Prompt
786    }
787
788    # set StatusCursor
789    set PRIV(StatusCursor) [$con index insert]
790
791    focus -force $con
792}
793
794proc ::tkcon::NewTab {{con {}}} {
795    variable PRIV
796    variable ATTACH
797
798    set con   [InitTab $PRIV(base)]
799    set slave [interp create Slave[GetSlaveNum]]
800    InitSlave $slave
801    $slave alias exit ::tkcon::DeleteTab $con $slave
802    set ATTACH($con) [list $slave slave]
803    $PRIV(X) configure -state normal
804    MenuConfigure Console "Delete Tab" -state normal
805    GotoTab $con
806}
807
808# The extra code arg is for the alias of exit to this function
809proc ::tkcon::DeleteTab {{con {}} {slave {}} {code 0}} {
810    variable PRIV
811
812    set numtabs [llength $PRIV(tabs)]
813    if {$numtabs <= 2} {
814        $PRIV(X) configure -state disabled
815        MenuConfigure Console "Delete Tab" -state disabled
816    }
817    if {$numtabs == 1} {
818        # in the master, it should do the right thing
819        # currently the first master still exists - need rearch to fix
820        exit
821        # we might end up here, depending on how exit is rerouted
822        return
823    }
824
825    if {$con == ""} {
826        set con $PRIV(console)
827    }
828    catch {unset ATTACH($con)}
829    set curtab  [lsearch -exact $PRIV(tabs) $con]
830    set PRIV(tabs) [lreplace $PRIV(tabs) $curtab $curtab]
831
832    set numtabs [llength $PRIV(tabs)]
833    set nexttab $curtab
834    if {$nexttab >= $numtabs} {
835        set nexttab end
836    }
837    set nexttab [lindex $PRIV(tabs) $nexttab]
838
839    GotoTab $nexttab
840
841    if {$slave != "" && $slave != $::tkcon::OPT(exec)} {
842        interp delete $slave
843    }
844    destroy $PRIV(tabframe).cb[winfo name $con]
845    destroy $con
846}
847
848## ::tkcon::GarbageCollect - do various cleanup ops periodically to our setup
849##
850proc ::tkcon::GarbageCollect {} {
851    variable OPT
852    variable PRIV
853
854    foreach w $PRIV(tabs) {
855        if {[winfo exists $w]} {
856            ## Remove error tags that no longer span anything
857            ## Make sure the tag pattern matches the unique tag prefix
858            foreach tag [$w tag names] {
859                if {[string match _tag* $tag]
860                    && ![llength [$w tag ranges $tag]]} {
861                    $w tag delete $tag
862                }
863            }
864        }
865    }
866    if {$OPT(gc-delay)} {
867        after $OPT(gc-delay) ::tkcon::GarbageCollect
868    }
869}
870
871## ::tkcon::Eval - evaluates commands input into console window
872## This is the first stage of the evaluating commands in the console.
873## They need to be broken up into consituent commands (by ::tkcon::CmdSep) in
874## case a multiple commands were pasted in, then each is eval'ed (by
875## ::tkcon::EvalCmd) in turn.  Any uncompleted command will not be eval'ed.
876# ARGS: w       - console text widget
877# Calls:        ::tkcon::CmdGet, ::tkcon::CmdSep, ::tkcon::EvalCmd
878##
879proc ::tkcon::Eval {w} {
880    set incomplete [CmdSep [CmdGet $w] cmds last]
881    $w mark set insert end-1c
882    $w insert end \n
883    if {[llength $cmds]} {
884        foreach c $cmds {EvalCmd $w $c}
885        $w insert insert $last {}
886    } elseif {!$incomplete} {
887        EvalCmd $w $last
888    }
889    if {[winfo exists $w]} {
890        $w see insert
891    }
892}
893
894## ::tkcon::EvalCmd - evaluates a single command, adding it to history
895# ARGS: w       - console text widget
896#       cmd     - the command to evaluate
897# Calls:        ::tkcon::Prompt
898# Outputs:      result of command to stdout (or stderr if error occured)
899# Returns:      next event number
900##
901proc ::tkcon::EvalCmd {w cmd} {
902    variable OPT
903    variable PRIV
904
905    $w mark set output end
906    if {[string compare {} $cmd]} {
907        set code 0
908        if {$OPT(subhistory)} {
909            set ev [EvalSlave history nextid]
910            incr ev -1
911            ## FIX: calcmode doesn't work with requesting history events
912            if {[string match !! $cmd]} {
913                set code [catch {EvalSlave history event $ev} cmd]
914                if {!$code} {$w insert output $cmd\n stdin}
915            } elseif {[regexp {^!(.+)$} $cmd dummy event]} {
916                ## Check last event because history event is broken
917                set code [catch {EvalSlave history event $ev} cmd]
918                if {!$code && ![string match ${event}* $cmd]} {
919                    set code [catch {EvalSlave history event $event} cmd]
920                }
921                if {!$code} {$w insert output $cmd\n stdin}
922            } elseif {[regexp {^\^([^^]*)\^([^^]*)\^?$} $cmd dummy old new]} {
923                set code [catch {EvalSlave history event $ev} cmd]
924                if {!$code} {
925                    regsub -all -- $old $cmd $new cmd
926                    $w insert output $cmd\n stdin
927                }
928            } elseif {$OPT(calcmode) && ![catch {expr $cmd} err]} {
929                AddSlaveHistory $cmd
930                set cmd $err
931                set code -1
932            }
933        }
934        if {$code} {
935            $w insert output $cmd\n stderr
936        } else {
937            ## We are about to evaluate the command, so move the limit
938            ## mark to ensure that further <Return>s don't cause double
939            ## evaluation of this command - for cases like the command
940            ## has a vwait or something in it
941            $w mark set limit end
942            if {$OPT(nontcl) && [string match interp $PRIV(apptype)]} {
943                set code [catch {EvalSend $cmd} res]
944                if {$code == 1} {
945                    set PRIV(errorInfo) "Non-Tcl errorInfo not available"
946                }
947            } elseif {[string match socket $PRIV(apptype)]} {
948                set code [catch {EvalSocket $cmd} res]
949                if {$code == 1} {
950                    set PRIV(errorInfo) "Socket-based errorInfo not available"
951                }
952            } else {
953                set code [catch {EvalAttached $cmd} res]
954                if {$code == 1} {
955                    if {[catch {EvalAttached [list set errorInfo]} err]} {
956                        set PRIV(errorInfo) "Error getting errorInfo:\n$err"
957                    } else {
958                        set PRIV(errorInfo) $err
959                    }
960                }
961            }
962            if {![winfo exists $w]} {
963                # early abort - must be a deleted tab
964                return
965            }
966            AddSlaveHistory $cmd
967            catch {EvalAttached [list set _ $res]}
968            set maxlen $OPT(maxlinelen)
969            set trailer ""
970            if {($maxlen > 0) && ([string length $res] > $maxlen)} {
971                # If we exceed maximum desired output line length, truncate
972                # the result and add "...+${num}b" in error coloring
973                set trailer ...+[expr {[string length $res]-$maxlen}]b
974                set res [string range $res 0 $maxlen]
975            }
976            if {$code} {
977                if {$OPT(hoterrors)} {
978                    set tag [UniqueTag $w]
979                    $w insert output $res [list stderr $tag] \n$trailer stderr
980                    $w tag bind $tag <Enter> \
981                            [list $w tag configure $tag -under 1]
982                    $w tag bind $tag <Leave> \
983                            [list $w tag configure $tag -under 0]
984                    $w tag bind $tag <ButtonRelease-1> \
985                            "if {!\[info exists tkPriv(mouseMoved)\] || !\$tkPriv(mouseMoved)} \
986                            {[list $OPT(edit) -attach [Attach] -type error -- $PRIV(errorInfo)]}"
987                } else {
988                    $w insert output $res\n$trailer stderr
989                }
990            } elseif {[string compare {} $res]} {
991                $w insert output $res stdout $trailer stderr \n stdout
992            }
993        }
994    }
995    Prompt
996    set PRIV(event) [EvalSlave history nextid]
997}
998
999## ::tkcon::EvalSlave - evaluates the args in the associated slave
1000## args should be passed to this procedure like they would be at
1001## the command line (not like to 'eval').
1002# ARGS: args    - the command and args to evaluate
1003##
1004proc ::tkcon::EvalSlave args {
1005    interp eval $::tkcon::OPT(exec) $args
1006}
1007
1008## ::tkcon::EvalOther - evaluate a command in a foreign interp or slave
1009## without attaching to it.  No check for existence is made.
1010# ARGS: app     - interp/slave name
1011#       type    - (slave|interp)
1012##
1013proc ::tkcon::EvalOther { app type args } {
1014    if {[string compare slave $type]==0} {
1015        return [Slave $app $args]
1016    } else {
1017        return [uplevel 1 ::send::send [list $app] $args]
1018    }
1019}
1020
1021## ::tkcon::AddSlaveHistory -
1022## Command is added to history only if different from previous command.
1023## This also doesn't cause the history id to be incremented, although the
1024## command will be evaluated.
1025# ARGS: cmd     - command to add
1026##
1027proc ::tkcon::AddSlaveHistory cmd {
1028    set ev [EvalSlave history nextid]
1029    incr ev -1
1030    set code [catch {EvalSlave history event $ev} lastCmd]
1031    if {$code || [string compare $cmd $lastCmd]} {
1032        EvalSlave history add $cmd
1033    }
1034}
1035
1036## ::tkcon::EvalSend - sends the args to the attached interpreter
1037## Varies from 'send' by determining whether attachment is dead
1038## when an error is received
1039# ARGS: cmd     - the command string to send across
1040# Returns:      the result of the command
1041##
1042proc ::tkcon::EvalSend cmd {
1043    variable OPT
1044    variable PRIV
1045
1046    if {$PRIV(deadapp)} {
1047        if {[lsearch -exact [::send::interps] $PRIV(app)]<0} {
1048            return
1049        } else {
1050            set PRIV(appname) [string range $PRIV(appname) 5 end]
1051            set PRIV(deadapp) 0
1052            Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)]
1053        }
1054    }
1055    set code [catch {::send::send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result]
1056    if {$code && [lsearch -exact [::send::interps] $PRIV(app)]<0} {
1057        ## Interpreter disappeared
1058        if {[string compare leave $OPT(dead)] && \
1059                ([string match ignore $OPT(dead)] || \
1060                     [tk_messageBox -title "Dead Attachment" -type yesno \
1061                          -icon info -message \
1062                          "\"$PRIV(app)\" appears to have died.\
1063                \nReturn to primary slave interpreter?"]=="no")} {
1064            set PRIV(appname) "DEAD:$PRIV(appname)"
1065            set PRIV(deadapp) 1
1066        } else {
1067            set err "Attached Tk interpreter \"$PRIV(app)\" died."
1068            Attach {}
1069            set PRIV(deadapp) 0
1070            EvalSlave set errorInfo $err
1071        }
1072        Prompt \n [CmdGet $PRIV(console)]
1073    }
1074    return -code $code $result
1075}
1076
1077## ::tkcon::EvalSocket - sends the string to an interpreter attached via
1078## a tcp/ip socket
1079##
1080## In the EvalSocket case, ::tkcon::PRIV(app) is the socket id
1081##
1082## Must determine whether socket is dead when an error is received
1083# ARGS: cmd     - the data string to send across
1084# Returns:      the result of the command
1085##
1086proc ::tkcon::EvalSocket cmd {
1087    variable OPT
1088    variable PRIV
1089    global tcl_version
1090
1091    if {$PRIV(deadapp)} {
1092        if {![info exists PRIV(app)] || \
1093                [catch {eof $PRIV(app)} eof] || $eof} {
1094            return
1095        } else {
1096            set PRIV(appname) [string range $PRIV(appname) 5 end]
1097            set PRIV(deadapp) 0
1098            Prompt "\n\"$PRIV(app)\" alive\n" [CmdGet $PRIV(console)]
1099        }
1100    }
1101    # Sockets get \'s interpreted, so that users can
1102    # send things like \n\r or explicit hex values
1103    set cmd [subst -novariables -nocommands $cmd]
1104    #puts [list $PRIV(app) $cmd]
1105    set code [catch {puts $PRIV(app) $cmd ; flush $PRIV(app)} result]
1106    if {$code && [eof $PRIV(app)]} {
1107        ## Interpreter died or disappeared
1108        puts "$code eof [eof $PRIV(app)]"
1109        EvalSocketClosed $PRIV(app)
1110    }
1111    return -code $code $result
1112}
1113
1114## ::tkcon::EvalSocketEvent - fileevent command for an interpreter attached
1115## via a tcp/ip socket
1116## Must determine whether socket is dead when an error is received
1117# ARGS: args    - the args to send across
1118# Returns:      the result of the command
1119##
1120proc ::tkcon::EvalSocketEvent {sock} {
1121    variable PRIV
1122
1123    if {[gets $sock line] == -1} {
1124        if {[eof $sock]} {
1125            EvalSocketClosed $sock
1126        }
1127        return
1128    }
1129    puts $line
1130}
1131
1132## ::tkcon::EvalSocketClosed - takes care of handling a closed eval socket
1133##
1134# ARGS: args    - the args to send across
1135# Returns:      the result of the command
1136##
1137proc ::tkcon::EvalSocketClosed {sock} {
1138    variable OPT
1139    variable PRIV
1140
1141    catch {close $sock}
1142    if {![string match $sock $PRIV(app)]} {
1143        # If we are not still attached to that socket, just return.
1144        # Might be nice to tell the user the socket closed ...
1145        return
1146    }
1147    if {[string compare leave $OPT(dead)] && \
1148            ([string match ignore $OPT(dead)] || \
1149                 [tk_messageBox -title "Dead Attachment" -type yesno \
1150                      -icon question \
1151                      -message "\"$PRIV(app)\" appears to have died.\
1152            \nReturn to primary slave interpreter?"] == "no")} {
1153        set PRIV(appname) "DEAD:$PRIV(appname)"
1154        set PRIV(deadapp) 1
1155    } else {
1156        set err "Attached Tk interpreter \"$PRIV(app)\" died."
1157        Attach {}
1158        set PRIV(deadapp) 0
1159        EvalSlave set errorInfo $err
1160    }
1161    Prompt \n [CmdGet $PRIV(console)]
1162}
1163
1164## ::tkcon::EvalNamespace - evaluates the args in a particular namespace
1165## This is an override for ::tkcon::EvalAttached for when the user wants
1166## to attach to a particular namespace of the attached interp
1167# ARGS: attached       
1168#       namespace       the namespace to evaluate in
1169#       args            the args to evaluate
1170# RETURNS:      the result of the command
1171##
1172proc ::tkcon::EvalNamespace { attached namespace args } {
1173    if {[llength $args]} {
1174        uplevel \#0 $attached \
1175                [list [concat [list namespace eval $namespace] $args]]
1176    }
1177}
1178
1179
1180## ::tkcon::Namespaces - return all the namespaces descendent from $ns
1181##
1182#
1183##
1184proc ::tkcon::Namespaces {{ns ::} {l {}}} {
1185    if {[string compare {} $ns]} { lappend l $ns }
1186    foreach i [EvalAttached [list namespace children $ns]] {
1187        set l [Namespaces $i $l]
1188    }
1189    return $l
1190}
1191
1192## ::tkcon::CmdGet - gets the current command from the console widget
1193# ARGS: w       - console text widget
1194# Returns:      text which compromises current command line
1195##
1196proc ::tkcon::CmdGet w {
1197    if {![llength [$w tag nextrange prompt limit end]]} {
1198        $w tag add stdin limit end-1c
1199        return [$w get limit end-1c]
1200    }
1201}
1202
1203## ::tkcon::CmdSep - separates multiple commands into a list and remainder
1204# ARGS: cmd     - (possible) multiple command to separate
1205#       list    - varname for the list of commands that were separated.
1206#       last    - varname of any remainder (like an incomplete final command).
1207#               If there is only one command, it's placed in this var.
1208# Returns:      constituent command info in varnames specified by list & rmd.
1209##
1210proc ::tkcon::CmdSep {cmd list last} {
1211    upvar 1 $list cmds $last inc
1212    set inc {}
1213    set cmds {}
1214    foreach c [split [string trimleft $cmd] \n] {
1215        if {[string compare $inc {}]} {
1216            append inc \n$c
1217        } else {
1218            append inc [string trimleft $c]
1219        }
1220        if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
1221            if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
1222            set inc {}
1223        }
1224    }
1225    set i [string compare $inc {}]
1226    if {!$i && [string compare $cmds {}] && ![string match *\n $cmd]} {
1227        set inc [lindex $cmds end]
1228        set cmds [lreplace $cmds end end]
1229    }
1230    return $i
1231}
1232
1233## ::tkcon::CmdSplit - splits multiple commands into a list
1234# ARGS: cmd     - (possible) multiple command to separate
1235# Returns:      constituent commands in a list
1236##
1237proc ::tkcon::CmdSplit {cmd} {
1238    set inc {}
1239    set cmds {}
1240    foreach cmd [split [string trimleft $cmd] \n] {
1241        if {[string compare {} $inc]} {
1242            append inc \n$cmd
1243        } else {
1244            append inc [string trimleft $cmd]
1245        }
1246        if {[info complete $inc] && ![regexp {[^\\]\\$} $inc]} {
1247            #set inc [string trimright $inc]
1248            if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
1249            set inc {}
1250        }
1251    }
1252    if {[regexp "^\[^#\]" $inc]} {lappend cmds $inc}
1253    return $cmds
1254}
1255
1256## ::tkcon::UniqueTag - creates a uniquely named tag, reusing names
1257## Called by ::tkcon::EvalCmd
1258# ARGS: w       - text widget
1259# Outputs:      tag name guaranteed unique in the widget
1260##
1261proc ::tkcon::UniqueTag {w} {
1262    set tags [$w tag names]
1263    set idx 0
1264    while {[lsearch -exact $tags _tag[incr idx]] != -1} {}
1265    return _tag$idx
1266}
1267
1268## ::tkcon::ConstrainBuffer - This limits the amount of data in the text widget
1269## Called by ::tkcon::Prompt and in tkcon proc buffer/console switch cases
1270# ARGS: w       - console text widget
1271#       size    - # of lines to constrain to
1272# Outputs:      may delete data in console widget
1273##
1274proc ::tkcon::ConstrainBuffer {w size} {
1275    if {$size && ([$w index end] > $size)} {
1276        $w delete 1.0 [expr {int([$w index end])-$size}].0
1277    }
1278}
1279
1280## ::tkcon::Prompt - displays the prompt in the console widget
1281# ARGS: w       - console text widget
1282# Outputs:      prompt (specified in ::tkcon::OPT(prompt1)) to console
1283##
1284proc ::tkcon::Prompt {{pre {}} {post {}} {prompt {}}} {
1285    variable OPT
1286    variable PRIV
1287
1288    set w $PRIV(console)
1289    if {![winfo exists $w]} { return }
1290    if {[string compare {} $pre]} { $w insert end $pre stdout }
1291    set i [$w index end-1c]
1292    if {!$OPT(showstatusbar)} {
1293        if {[string compare {} $PRIV(appname)]} {
1294            $w insert end ">$PRIV(appname)< " prompt
1295        }
1296        if {[string compare :: $PRIV(namesp)]} {
1297            $w insert end "<$PRIV(namesp)> " prompt
1298        }
1299    }
1300    if {[string compare {} $prompt]} {
1301        $w insert end $prompt prompt
1302    } else {
1303        $w insert end [EvalSlave subst $OPT(prompt1)] prompt
1304    }
1305    $w mark set output $i
1306    $w mark set insert end
1307    $w mark set limit insert
1308    $w mark gravity limit left
1309    if {[string compare {} $post]} { $w insert end $post stdin }
1310    ConstrainBuffer $w $OPT(buffer)
1311    set ::tkcon::PRIV(StatusCursor) [$w index insert]
1312    $w see end
1313}
1314proc ::tkcon::RePrompt {{pre {}} {post {}} {prompt {}}} {
1315    # same as prompt, but does nothing for those actions where we
1316    # only wanted to refresh the prompt on attach change when the
1317    # statusbar is showing (which carries that info instead)
1318    variable OPT
1319    if {!$OPT(showstatusbar)} {
1320        Prompt $pre $post $prompt
1321    }
1322}
1323
1324## ::tkcon::About - gives about info for tkcon
1325##
1326proc ::tkcon::About {} {
1327    variable OPT
1328    variable PRIV
1329    variable COLOR
1330
1331    set w $PRIV(base).about
1332    if {![winfo exists $w]} {
1333        global tk_patchLevel tcl_patchLevel tcl_version
1334        toplevel $w
1335        wm withdraw $w
1336        wm transient $w $PRIV(root)
1337        wm group $w $PRIV(root)
1338        wm title $w "About tkcon v$PRIV(version)"
1339        button $w.b -text Dismiss -command [list wm withdraw $w]
1340        text $w.text -height 9 -bd 1 -width 60 \
1341                -foreground $COLOR(stdin) \
1342                -background $COLOR(bg) \
1343                -font $OPT(font)
1344        pack $w.b -fill x -side bottom
1345        pack $w.text -fill both -side left -expand 1
1346        $w.text tag config center -justify center
1347        $w.text tag config title -justify center -font {Courier -18 bold}
1348        # strip down the RCS info displayed in the about box
1349        regexp {,v ([0-9\./: ]*)} $PRIV(RCS) -> RCS
1350        $w.text insert 1.0 "About tkcon v$PRIV(version)" title \
1351                "\n\nCopyright 1995-2002 Jeffrey Hobbs, $PRIV(email)\
1352                \nRelease Info: v$PRIV(version), CVS v$RCS\
1353                \nDocumentation available at:\n$PRIV(docs)\
1354                \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
1355        $w.text config -state disabled
1356        bind $w <Escape> [list destroy $w]
1357    }
1358    wm deiconify $w
1359}
1360
1361## ::tkcon::InitMenus - inits the menubar and popup for the console
1362# ARGS: w       - console text widget
1363##
1364proc ::tkcon::InitMenus {w title} {
1365    variable OPT
1366    variable PRIV
1367    variable COLOR
1368    global tcl_platform
1369
1370    if {[catch {menu $w.pop}]} {
1371        label $w.label -text "Menus not available in plugin mode"
1372        grid $w.label -sticky ew
1373        return
1374    }
1375    menu $w.context -disabledforeground $COLOR(disabled)
1376    set PRIV(context) $w.context
1377    set PRIV(popup) $w.pop
1378
1379    proc MenuButton {w m l} {
1380        $w add cascade -label $m -underline 0 -menu $w.$l
1381        return $w.$l
1382    }
1383    proc MenuConfigure {m l args} {
1384        variable PRIV
1385        eval [list $PRIV(menubar).[string tolower $m] entryconfigure $l] $args
1386        eval [list $PRIV(popup).[string tolower $m] entryconfigure $l] $args
1387    }
1388
1389    foreach m [list File Console Edit Interp Prefs History Help] {
1390        set l [string tolower $m]
1391        MenuButton $w $m $l
1392        $w.pop add cascade -label $m -underline 0 -menu $w.pop.$l
1393    }
1394
1395    ## File Menu
1396    ##
1397    foreach m [list [menu $w.file -disabledforeground $COLOR(disabled)] \
1398            [menu $w.pop.file -disabledforeground $COLOR(disabled)]] {
1399        $m add command -label "Load File" -underline 0 -command ::tkcon::Load
1400        $m add cascade -label "Save ..."  -underline 0 -menu $m.save
1401        $m add separator
1402        $m add command -label "Quit" -underline 0 -accel Ctrl-q -command exit
1403
1404        ## Save Menu
1405        ##
1406        set s $m.save
1407        menu $s -disabledforeground $COLOR(disabled)
1408        $s add command -label "All"     -underline 0 \
1409                -command {::tkcon::Save {} all}
1410        $s add command -label "History" -underline 0 \
1411                -command {::tkcon::Save {} history}
1412        $s add command -label "Stdin"   -underline 3 \
1413                -command {::tkcon::Save {} stdin}
1414        $s add command -label "Stdout"  -underline 3 \
1415                -command {::tkcon::Save {} stdout}
1416        $s add command -label "Stderr"  -underline 3 \
1417                -command {::tkcon::Save {} stderr}
1418    }
1419
1420    ## Console Menu
1421    ##
1422    foreach m [list [menu $w.console -disabledfore $COLOR(disabled)] \
1423            [menu $w.pop.console -disabledfore $COLOR(disabled)]] {
1424        $m add command -label "$title Console"  -state disabled
1425        $m add command -label "New Console"     -underline 0 -accel Ctrl-N \
1426                -command ::tkcon::New
1427        $m add command -label "New Tab"         -underline 4 -accel Ctrl-T \
1428                -command ::tkcon::NewTab
1429        $m add command -label "Delete Tab"      -underline 0 \
1430                -command ::tkcon::DeleteTab -state disabled
1431        $m add command -label "Close Console"   -underline 0 -accel Ctrl-w \
1432                -command ::tkcon::Destroy
1433        $m add command -label "Clear Console"   -underline 1 -accel Ctrl-l \
1434                -command { clear; ::tkcon::Prompt }
1435        if {[string match unix $tcl_platform(platform)]} {
1436            $m add separator
1437            $m add command -label "Make Xauth Secure" -und 5 \
1438                    -command ::tkcon::XauthSecure
1439        }
1440        $m add separator
1441        $m add cascade -label "Attach To ..." -underline 0 -menu $m.attach
1442
1443        ## Attach Console Menu
1444        ##
1445        set sub [menu $m.attach -disabledforeground $COLOR(disabled)]
1446        $sub add cascade -label "Interpreter" -underline 0 -menu $sub.apps
1447        $sub add cascade -label "Namespace"   -underline 0 -menu $sub.name
1448
1449        ## Attach Console Menu
1450        ##
1451        menu $sub.apps -disabledforeground $COLOR(disabled) \
1452                -postcommand [list ::tkcon::AttachMenu $sub.apps]
1453
1454        ## Attach Namespace Menu
1455        ##
1456        menu $sub.name -disabledforeground $COLOR(disabled) \
1457                -postcommand [list ::tkcon::NamespaceMenu $sub.name]
1458
1459        if {$::tcl_version >= 8.3} {
1460            ## Attach Socket Menu
1461            ##
1462            # This uses [file channels] to create the menu, so we only
1463            # want it for newer versions of Tcl.
1464            $sub add cascade -label "Socket" -underline 0 -menu $sub.sock
1465            menu $sub.sock -disabledforeground $COLOR(disabled) \
1466                    -postcommand [list ::tkcon::SocketMenu $sub.sock]
1467        }
1468
1469        if {![string compare "unix" $tcl_platform(platform)]} {
1470            ## Attach Display Menu
1471            ##
1472            $sub add cascade -label "Display" -underline 0 -menu $sub.disp
1473            menu $sub.disp -disabledforeground $COLOR(disabled) \
1474                    -postcommand [list ::tkcon::DisplayMenu $sub.disp]
1475        }
1476    }
1477
1478    ## Edit Menu
1479    ##
1480    set text $PRIV(console)
1481    foreach m [list [menu $w.edit] [menu $w.pop.edit]] {
1482        $m add command -label "Cut"   -underline 2 -accel Ctrl-x \
1483                -command [list ::tkcon::Cut $text]
1484        $m add command -label "Copy"  -underline 0 -accel Ctrl-c \
1485                -command [list ::tkcon::Copy $text]
1486        $m add command -label "Paste" -underline 0 -accel Ctrl-v \
1487                 -command [list ::tkcon::Paste $text]
1488        $m add separator
1489        $m add command -label "Find"  -underline 0 -accel Ctrl-F \
1490                -command [list ::tkcon::FindBox $text]
1491    }
1492
1493    ## Interp Menu
1494    ##
1495    foreach m [list $w.interp $w.pop.interp] {
1496        menu $m -disabledforeground $COLOR(disabled) \
1497                -postcommand [list ::tkcon::InterpMenu $m]
1498    }
1499
1500    ## Prefs Menu
1501    ##
1502    foreach m [list [menu $w.prefs] [menu $w.pop.prefs]] {
1503        $m add check -label "Brace Highlighting" \
1504                -underline 0 -variable ::tkcon::OPT(lightbrace)
1505        $m add check -label "Command Highlighting" \
1506                -underline 0 -variable ::tkcon::OPT(lightcmd)
1507        $m add check -label "History Substitution" \
1508                -underline 0 -variable ::tkcon::OPT(subhistory)
1509        $m add check -label "Hot Errors" \
1510                -underline 4 -variable ::tkcon::OPT(hoterrors)
1511        $m add check -label "Non-Tcl Attachments" \
1512                -underline 0 -variable ::tkcon::OPT(nontcl)
1513        $m add check -label "Calculator Mode" \
1514                -underline 1 -variable ::tkcon::OPT(calcmode)
1515        $m add check -label "Show Multiple Matches" \
1516                -underline 0 -variable ::tkcon::OPT(showmultiple)
1517        $m add check -label "Show Menubar" \
1518                -underline 5 -variable ::tkcon::OPT(showmenu) \
1519                -command {$::tkcon::PRIV(root) configure -menu [expr \
1520                {$::tkcon::OPT(showmenu) ? $::tkcon::PRIV(menubar) : {}}]}
1521        $m add check -label "Show Statusbar" \
1522            -underline 5 -variable ::tkcon::OPT(showstatusbar) \
1523            -command {
1524                if {$::tkcon::OPT(showstatusbar)} {
1525                    grid $::tkcon::PRIV(statusbar)
1526                } else { grid remove $::tkcon::PRIV(statusbar) }
1527            }
1528        $m add cascade -label "Scrollbar" -underline 2 -menu $m.scroll
1529
1530        ## Scrollbar Menu
1531        ##
1532        set m [menu $m.scroll]
1533        $m add radio -label "Left" -value left \
1534                -variable ::tkcon::OPT(scrollypos) \
1535                -command { grid configure $::tkcon::PRIV(scrolly) -column 0 }
1536        $m add radio -label "Right" -value right \
1537                -variable ::tkcon::OPT(scrollypos) \
1538                -command { grid configure $::tkcon::PRIV(scrolly) -column 2 }
1539    }
1540
1541    ## History Menu
1542    ##
1543    foreach m [list $w.history $w.pop.history] {
1544        menu $m -disabledforeground $COLOR(disabled) \
1545                -postcommand [list ::tkcon::HistoryMenu $m]
1546    }
1547
1548    ## Help Menu
1549    ##
1550    foreach m [list [menu $w.help] [menu $w.pop.help]] {
1551        $m add command -label "About " -underline 0 -accel Ctrl-A \
1552                -command ::tkcon::About
1553        $m add command -label "Retrieve Latest Version" -underline 0 \
1554                -command ::tkcon::Retrieve
1555        if {![catch {package require ActiveTcl} ver]} {
1556            set cmd ""
1557            if {$tcl_platform(platform) == "windows"} {
1558                package require registry
1559                set ver [join [lrange [split $ver .] 0 3] .]
1560                set key {HKEY_LOCAL_MACHINE\SOFTWARE\ActiveState\ActiveTcl}
1561                if {![catch {registry get "$key\\$ver\\Help" ""} help]
1562                    && [file exists $help]} {
1563                    set cmd [list exec $::env(COMSPEC) /c start $help]
1564                }
1565            } elseif {$tcl_platform(os) == "Darwin"} {
1566                set ver ActiveTcl-[join [lrange [split $ver .] 0 1] .]
1567                set rsc "/Library/Frameworks/Tcl.framework/Resources"
1568                set help "$rsc/English.lproj/$ver/index.html"
1569                if {[file exists $help]} {
1570                    set cmd [list exec open $help]
1571                }
1572            } elseif {$tcl_platform(platform) == "unix"} {
1573                set help [file dirname [info nameofexe]]
1574                append help /../html/index.html
1575                if {[file exists $help]} {
1576                    set cmd [list puts "Start $help"]
1577                }
1578            }
1579            if {$cmd != ""} {
1580                $m add separator
1581                $m add command -label "ActiveTcl Help" -underline 10 \
1582                    -command $cmd
1583            }
1584        }
1585    }
1586}
1587
1588## ::tkcon::HistoryMenu - dynamically build the menu for attached interpreters
1589##
1590# ARGS: m       - menu widget
1591##
1592proc ::tkcon::HistoryMenu m {
1593    variable PRIV
1594
1595    if {![winfo exists $m]} return
1596    set id [EvalSlave history nextid]
1597    if {$PRIV(histid)==$id} return
1598    set PRIV(histid) $id
1599    $m delete 0 end
1600    while {($id>1) && ($id>$PRIV(histid)-10) && \
1601            ![catch {EvalSlave history event [incr id -1]} tmp]} {
1602        set lbl $tmp
1603        if {[string len $lbl]>32} { set lbl [string range $tmp 0 28]... }
1604        $m add command -label "$id: $lbl" -command "
1605        $::tkcon::PRIV(console) delete limit end
1606        $::tkcon::PRIV(console) insert limit [list $tmp]
1607        $::tkcon::PRIV(console) see end
1608        ::tkcon::Eval $::tkcon::PRIV(console)"
1609    }
1610}
1611
1612## ::tkcon::InterpMenu - dynamically build the menu for attached interpreters
1613##
1614# ARGS: w       - menu widget
1615##
1616proc ::tkcon::InterpMenu w {
1617    variable OPT
1618    variable PRIV
1619    variable COLOR
1620
1621    if {![winfo exists $w]} return
1622    $w delete 0 end
1623    foreach {app type} [Attach] break
1624    $w add command -label "[string toupper $type]: $app" -state disabled
1625    if {($OPT(nontcl) && [string match interp $type]) || $PRIV(deadapp)} {
1626        $w add separator
1627        $w add command -state disabled -label "Communication disabled to"
1628        $w add command -state disabled -label "dead or non-Tcl interps"
1629        return
1630    }
1631
1632    ## Show Last Error
1633    ##
1634    $w add separator
1635    $w add command -label "Show Last Error" \
1636            -command [list tkcon error $app $type]
1637
1638    ## Packages Cascaded Menu
1639    ##
1640    $w add separator
1641    $w add command -label "Manage Packages" -underline 0 \
1642        -command [list ::tkcon::InterpPkgs $app $type]
1643
1644    ## State Checkpoint/Revert
1645    ##
1646    $w add separator
1647    $w add command -label "Checkpoint State" \
1648            -command [list ::tkcon::StateCheckpoint $app $type]
1649    $w add command -label "Revert State" \
1650            -command [list ::tkcon::StateRevert $app $type]
1651    $w add command -label "View State Change" \
1652            -command [list ::tkcon::StateCompare $app $type]
1653
1654    ## Init Interp
1655    ##
1656    $w add separator
1657    $w add command -label "Send tkcon Commands" \
1658            -command [list ::tkcon::InitInterp $app $type]
1659}
1660
1661## ::tkcon::PkgMenu - fill in  in the applications sub-menu
1662## with a list of all the applications that currently exist.
1663##
1664proc ::tkcon::InterpPkgs {app type} {
1665    variable PRIV
1666
1667    set t $PRIV(base).interppkgs
1668    if {![winfo exists $t]} {
1669        toplevel $t
1670        wm withdraw $t
1671        wm title $t "$app Packages"
1672        wm transient $t $PRIV(root)
1673        wm group $t $PRIV(root)
1674        bind $t <Escape> [list destroy $t]
1675
1676        label $t.ll -text "Loadable:" -anchor w
1677        label $t.lr -text "Loaded:" -anchor w
1678        listbox $t.loadable -bg white -bd 1 -font tkconfixed \
1679            -yscrollcommand [list $t.llsy set] -selectmode extended
1680        listbox $t.loaded -bg white -bd 1 -font tkconfixed \
1681            -yscrollcommand [list $t.lrsy set]
1682        scrollbar $t.llsy -bd 1 -command [list $t.loadable yview]
1683        scrollbar $t.lrsy -bd 1 -command [list $t.loaded yview]
1684        button $t.load -bd 1 -text ">>" \
1685            -command [list ::tkcon::InterpPkgLoad $app $type $t.loadable]
1686        if {$::tcl_version >= 8.4} {
1687            $t.load configure -relief flat -overrelief raised
1688        }
1689
1690        set f [frame $t.btns]
1691        button $f.refresh -width 8 -text "Refresh" -command [info level 0]
1692        button $f.dismiss -width 8 -text "Dismiss" -command [list destroy $t]
1693        grid $f.refresh $f.dismiss -padx 4 -pady 3 -sticky ew
1694
1695        grid $t.ll x x $t.lr x -sticky ew
1696        grid $t.loadable $t.llsy $t.load $t.loaded $t.lrsy -sticky news
1697        grid $t.btns -sticky e -columnspan 5
1698        grid columnconfigure $t {0 3} -weight 1
1699        grid rowconfigure $t 1 -weight 1
1700        grid configure $t.load -sticky ""
1701
1702        bind $t.loadable <Double-1> "[list $t.load invoke]; break"
1703    }
1704    $t.loaded delete 0 end
1705    $t.loadable delete 0 end
1706
1707    # just in case stuff has been added to the auto_path
1708    # we have to make sure that the errorInfo doesn't get screwed up
1709    EvalAttached {
1710        set __tkcon_error $errorInfo
1711        catch {package require bogus-package-name}
1712        set errorInfo ${__tkcon_error}
1713        unset __tkcon_error
1714    }
1715    # get all packages loaded into current interp
1716    foreach pkg [EvalAttached [list info loaded {}]] {
1717        set pkg [lindex $pkg 1]
1718        set loaded($pkg) [package provide $pkg]
1719    }
1720    # get all package names currently visible
1721    foreach pkg [lremove [EvalAttached {package names}] Tcl] {
1722        set version [EvalAttached [list package provide $pkg]]
1723        if {[string compare {} $version]} {
1724            set loaded($pkg) $version
1725        } elseif {![info exists loaded($pkg)]} {
1726            set loadable($pkg) package
1727        }
1728    }
1729    # get packages that are loaded in any interp
1730    foreach pkg [EvalAttached {info loaded}] {
1731        set pkg [lindex $pkg 1]
1732        if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} {
1733            set loadable($pkg) load
1734        }
1735    }
1736    foreach pkg [lsort -dictionary [array names loadable]] {
1737        foreach v [EvalAttached [list package version $pkg]] {
1738            $t.loadable insert end [list $pkg $v "($loadable($pkg))"]
1739        }
1740    }
1741    foreach pkg [lsort -dictionary [array names loaded]] {
1742        $t.loaded insert end [list $pkg $loaded($pkg)]
1743    }
1744
1745    wm deiconify $t
1746    raise $t
1747}
1748
1749proc ::tkcon::InterpPkgLoad {app type lb} {
1750    # load the lb entry items into the interp
1751    foreach sel [$lb curselection] {
1752        foreach {pkg ver method} [$lb get $sel] { break }
1753        if {$method == "(package)"} {
1754            set code [catch {::tkcon::EvalOther $app $type \
1755                                 package require $pkg $ver} msg]
1756        } elseif {$method == "(load)"} {
1757            set code [catch {::tkcon::EvalOther $app $type load {} $pkg} msg]
1758        } else {
1759            set code 1
1760            set msg "Incorrect entry in Loadable selection"
1761        }
1762        if {$code} {
1763            tk_messageBox -icon error -title "Error requiring $pkg" -type ok \
1764                -message "Error requiring $pkg $ver:\n$msg\n$::errorInfo"
1765        }
1766    }
1767    # refresh package list
1768    InterpPkgs $app $type
1769}
1770
1771## ::tkcon::AttachMenu - fill in  in the applications sub-menu
1772## with a list of all the applications that currently exist.
1773##
1774proc ::tkcon::AttachMenu m {
1775    variable OPT
1776    variable PRIV
1777
1778    array set interps [set tmp [Interps]]
1779    foreach {i j} $tmp { set tknames($j) {} }
1780
1781    $m delete 0 end
1782    set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1783    $m add radio -label {None (use local slave) } -accel Ctrl-1 \
1784            -variable ::tkcon::PRIV(app) \
1785            -value [concat $::tkcon::PRIV(name) $::tkcon::OPT(exec)] \
1786            -command "::tkcon::Attach {}; $cmd"
1787    $m add separator
1788    $m add command -label "Foreign Tk Interpreters" -state disabled
1789    foreach i [lsort [lremove [::send::interps] [array names tknames]]] {
1790        $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \
1791                -command "::tkcon::Attach [list $i] interp; $cmd"
1792    }
1793    $m add separator
1794
1795    $m add command -label "tkcon Interpreters" -state disabled
1796    foreach i [lsort [array names interps]] {
1797        if {[string match {} $interps($i)]} { set interps($i) "no Tk" }
1798        if {[regexp {^Slave[0-9]+} $i]} {
1799            set opts [list -label "$i ($interps($i))" \
1800                    -variable ::tkcon::PRIV(app) -value $i \
1801                    -command "::tkcon::Attach [list $i] slave; $cmd"]
1802            if {[string match $PRIV(name) $i]} {
1803                append opts " -accel Ctrl-2"
1804            }
1805            eval $m add radio $opts
1806        } else {
1807            set name [concat Main $i]
1808            if {[string match Main $name]} {
1809                $m add radio -label "$name ($interps($i))" -accel Ctrl-3 \
1810                        -variable ::tkcon::PRIV(app) -value Main \
1811                        -command "::tkcon::Attach [list $name] slave; $cmd"
1812            } else {
1813                $m add radio -label "$name ($interps($i))" \
1814                        -variable ::tkcon::PRIV(app) -value $i \
1815                        -command "::tkcon::Attach [list $name] slave; $cmd"
1816            }
1817        }
1818    }
1819}
1820
1821## Displays Cascaded Menu
1822##
1823proc ::tkcon::DisplayMenu m {
1824    $m delete 0 end
1825    set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1826
1827    $m add command -label "New Display" -command ::tkcon::NewDisplay
1828    foreach disp [Display] {
1829        $m add separator
1830        $m add command -label $disp -state disabled
1831        set res [Display $disp]
1832        set win [lindex $res 0]
1833        foreach i [lsort [lindex $res 1]] {
1834            $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \
1835                    -command "::tkcon::Attach [list $i] [list dpy:$win]; $cmd"
1836        }
1837    }
1838}
1839
1840## Sockets Cascaded Menu
1841##
1842proc ::tkcon::SocketMenu m {
1843    $m delete 0 end
1844    set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1845
1846    $m add command -label "Create Connection" \
1847            -command "::tkcon::NewSocket; $cmd"
1848    foreach sock [file channels sock*] {
1849        $m add radio -label $sock -variable ::tkcon::PRIV(app) -value $sock \
1850                -command "::tkcon::Attach $sock socket; $cmd"
1851    }
1852}
1853
1854## Namepaces Cascaded Menu
1855##
1856proc ::tkcon::NamespaceMenu m {
1857    variable PRIV
1858    variable OPT
1859
1860    $m delete 0 end
1861    if {($PRIV(deadapp) || [string match socket $PRIV(apptype)] || \
1862            ($OPT(nontcl) && [string match interp $PRIV(apptype)]))} {
1863        $m add command -label "No Namespaces" -state disabled
1864        return
1865    }
1866
1867    ## Same command as for ::tkcon::AttachMenu items
1868    set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
1869
1870    set names [lsort [Namespaces ::]]
1871    if {[llength $names] > $OPT(maxmenu)} {
1872        $m add command -label "Attached to $PRIV(namesp)" -state disabled
1873        $m add command -label "List Namespaces" \
1874                -command [list ::tkcon::NamespacesList $names]
1875    } else {
1876        foreach i $names {
1877            if {[string match :: $i]} {
1878                $m add radio -label "Main" -value $i \
1879                        -variable ::tkcon::PRIV(namesp) \
1880                        -command "::tkcon::AttachNamespace [list $i]; $cmd"
1881            } else {
1882                $m add radio -label $i -value $i \
1883                        -variable ::tkcon::PRIV(namesp) \
1884                        -command "::tkcon::AttachNamespace [list $i]; $cmd"
1885            }
1886        }
1887    }
1888}
1889
1890## Namepaces List
1891##
1892proc ::tkcon::NamespacesList {names} {
1893    variable PRIV
1894
1895    set f $PRIV(base).namespaces
1896    catch {destroy $f}
1897    toplevel $f
1898    listbox $f.names -width 30 -height 15 -selectmode single \
1899            -yscrollcommand [list $f.scrollv set] \
1900            -xscrollcommand [list $f.scrollh set]
1901    scrollbar $f.scrollv -command [list $f.names yview]
1902    scrollbar $f.scrollh -command [list $f.names xview] -orient horizontal
1903    frame $f.buttons
1904    button $f.cancel -text "Cancel" -command [list destroy $f]
1905
1906    grid $f.names $f.scrollv -sticky nesw
1907    grid $f.scrollh -sticky ew
1908    grid $f.buttons -sticky nesw
1909    grid $f.cancel -in $f.buttons -pady 6
1910
1911    grid columnconfigure $f 0 -weight 1
1912    grid rowconfigure $f  0 -weight 1
1913    #fill the listbox
1914    foreach i $names {
1915        if {[string match :: $i]} {
1916            $f.names insert 0 Main
1917        } else {
1918            $f.names insert end $i
1919        }
1920    }
1921    #Bindings
1922    bind $f.names <Double-1> {
1923        ## Catch in case the namespace disappeared on us
1924        catch { ::tkcon::AttachNamespace [%W get [%W nearest %y]] }
1925        ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
1926        destroy [winfo toplevel %W]
1927    }
1928}
1929
1930# ::tkcon::XauthSecure --
1931#
1932#   This removes all the names in the xhost list, and secures
1933#   the display for Tk send commands.  Of course, this prevents
1934#   what might have been otherwise allowable X connections
1935#
1936# Arguments:
1937#   none
1938# Results:
1939#   Returns nothing
1940#
1941proc ::tkcon::XauthSecure {} {
1942    global tcl_platform
1943
1944    if {[string compare unix $tcl_platform(platform)]} {
1945        # This makes no sense outside of Unix
1946        return
1947    }
1948    set hosts [exec xhost]
1949    # the first line is info only
1950    foreach host [lrange [split $hosts \n] 1 end] {
1951        exec xhost -$host
1952    }
1953    exec xhost -
1954    tk_messageBox -title "Xhost secured" -message "Xhost secured" -icon info
1955}
1956
1957## ::tkcon::FindBox - creates minimal dialog interface to ::tkcon::Find
1958# ARGS: w       - text widget
1959#       str     - optional seed string for ::tkcon::PRIV(find)
1960##
1961proc ::tkcon::FindBox {w {str {}}} {
1962    variable PRIV
1963
1964    set base $PRIV(base).find
1965    if {![winfo exists $base]} {
1966        toplevel $base
1967        wm withdraw $base
1968        wm title $base "tkcon Find"
1969
1970        pack [frame $base.f] -fill x -expand 1
1971        label $base.f.l -text "Find:"
1972        entry $base.f.e -textvariable ::tkcon::PRIV(find)
1973        pack [frame $base.opt] -fill x
1974        checkbutton $base.opt.c -text "Case Sensitive" \
1975                -variable ::tkcon::PRIV(find,case)
1976        checkbutton $base.opt.r -text "Use Regexp" -variable ::tkcon::PRIV(find,reg)
1977        pack $base.f.l -side left
1978        pack $base.f.e $base.opt.c $base.opt.r -side left -fill both -expand 1
1979        pack [frame $base.sep -bd 2 -relief sunken -height 4] -fill x
1980        pack [frame $base.btn] -fill both
1981        button $base.btn.fnd -text "Find" -width 6
1982        button $base.btn.clr -text "Clear" -width 6
1983        button $base.btn.dis -text "Dismiss" -width 6
1984        eval pack [winfo children $base.btn] -padx 4 -pady 2 \
1985                -side left -fill both
1986
1987        focus $base.f.e
1988
1989        bind $base.f.e <Return> [list $base.btn.fnd invoke]
1990        bind $base.f.e <Escape> [list $base.btn.dis invoke]
1991    }
1992    $base.btn.fnd config -command "::tkcon::Find [list $w] \$::tkcon::PRIV(find) \
1993            -case \$::tkcon::PRIV(find,case) -reg \$::tkcon::PRIV(find,reg)"
1994    $base.btn.clr config -command "
1995    [list $w] tag remove find 1.0 end
1996    set ::tkcon::PRIV(find) {}
1997    "
1998    $base.btn.dis config -command "
1999    [list $w] tag remove find 1.0 end
2000    wm withdraw [list $base]
2001    "
2002    if {[string compare {} $str]} {
2003        set PRIV(find) $str
2004        $base.btn.fnd invoke
2005    }
2006
2007    if {[string compare normal [wm state $base]]} {
2008        wm deiconify $base
2009    } else { raise $base }
2010    $base.f.e select range 0 end
2011}
2012
2013## ::tkcon::Find - searches in text widget $w for $str and highlights it
2014## If $str is empty, it just deletes any highlighting
2015# ARGS: w       - text widget
2016#       str     - string to search for
2017#       -case   TCL_BOOLEAN     whether to be case sensitive    DEFAULT: 0
2018#       -regexp TCL_BOOLEAN     whether to use $str as pattern  DEFAULT: 0
2019##
2020proc ::tkcon::Find {w str args} {
2021    $w tag remove find 1.0 end
2022    set truth {^(1|yes|true|on)$}
2023    set opts  {}
2024    foreach {key val} $args {
2025        switch -glob -- $key {
2026            -c* { if {[regexp -nocase $truth $val]} { set case 1 } }
2027            -r* { if {[regexp -nocase $truth $val]} { lappend opts -regexp } }
2028            default { return -code error "Unknown option $key" }
2029        }
2030    }
2031    if {![info exists case]} { lappend opts -nocase }
2032    if {[string match {} $str]} return
2033    $w mark set findmark 1.0
2034    while {[string compare {} [set ix [eval $w search $opts -count numc -- \
2035            [list $str] findmark end]]]} {
2036        $w tag add find $ix ${ix}+${numc}c
2037        $w mark set findmark ${ix}+1c
2038    }
2039    $w tag configure find -background $::tkcon::COLOR(blink)
2040    catch {$w see find.first}
2041    return [expr {[llength [$w tag ranges find]]/2}]
2042}
2043
2044## ::tkcon::Attach - called to attach tkcon to an interpreter
2045# ARGS: name    - application name to which tkcon sends commands
2046#                 This is either a slave interperter name or tk appname.
2047#       type    - (slave|interp) type of interpreter we're attaching to
2048#                 slave means it's a tkcon interpreter
2049#                 interp means we'll need to 'send' to it.
2050# Results:      ::tkcon::EvalAttached is recreated to evaluate in the
2051#               appropriate interpreter
2052##
2053proc ::tkcon::Attach {{name <NONE>} {type slave} {ns {}}} {
2054    variable PRIV
2055    variable OPT
2056    variable ATTACH
2057
2058    if {[llength [info level 0]] == 1} {
2059        # no args were specified, return the attach info instead
2060        return [AttachId]
2061    }
2062    set path [concat $PRIV(name) $OPT(exec)]
2063
2064    set PRIV(displayWin) .
2065    if {[string match namespace $type]} {
2066        return [uplevel 1 ::tkcon::AttachNamespace $name]
2067    } elseif {[string match dpy:* $type]} {
2068        set PRIV(displayWin) [string range $type 4 end]
2069    } elseif {[string match sock* $type]} {
2070        global tcl_version
2071        if {[catch {eof $name} res]} {
2072            return -code error "No known channel \"$name\""
2073        } elseif {$res} {
2074            catch {close $name}
2075            return -code error "Channel \"$name\" returned EOF"
2076        }
2077        set app $name
2078        set type socket
2079    } elseif {[string compare {} $name]} {
2080        array set interps [Interps]
2081        if {[string match {[Mm]ain} [lindex $name 0]]} {
2082            set name [lrange $name 1 end]
2083        }
2084        if {[string match $path $name]} {
2085            set name {}
2086            set app $path
2087            set type slave
2088        } elseif {[info exists interps($name)]} {
2089            if {[string match {} $name]} { set name Main; set app Main }
2090            set type slave
2091        } elseif {[interp exists $name]} {
2092            set name [concat $PRIV(name) $name]
2093            set type slave
2094        } elseif {[interp exists [concat $OPT(exec) $name]]} {
2095            set name [concat $path $name]
2096            set type slave
2097        } elseif {[lsearch -exact [::send::interps] $name] > -1} {
2098            if {[EvalSlave info exists tk_library] \
2099                    && [string match $name [EvalSlave tk appname]]} {
2100                set name {}
2101                set app $path
2102                set type slave
2103            } elseif {[set i [lsearch -exact \
2104                    [Main set ::tkcon::PRIV(interps)] $name]] != -1} {
2105                set name [lindex [Main set ::tkcon::PRIV(slaves)] $i]
2106                if {[string match {[Mm]ain} $name]} { set app Main }
2107                set type slave
2108            } else {
2109                set type interp
2110            }
2111        } else {
2112            return -code error "No known interpreter \"$name\""
2113        }
2114    } else {
2115        set app $path
2116    }
2117    if {![info exists app]} { set app $name }
2118    array set PRIV [list app $app appname $name apptype $type deadapp 0]
2119
2120    ## ::tkcon::EvalAttached - evaluates the args in the attached interp
2121    ## args should be passed to this procedure as if they were being
2122    ## passed to the 'eval' procedure.  This procedure is dynamic to
2123    ## ensure evaluation occurs in the right interp.
2124    # ARGS:     args    - the command and args to evaluate
2125    ##
2126    set PRIV(namesp) ::
2127    set namespOK 0
2128    switch -glob -- $type {
2129        slave {
2130            if {[string match {} $name]} {
2131                interp alias {} ::tkcon::EvalAttached {} \
2132                        ::tkcon::EvalSlave uplevel \#0
2133            } elseif {[string match Main $PRIV(app)]} {
2134                interp alias {} ::tkcon::EvalAttached {} ::tkcon::Main
2135            } elseif {[string match $PRIV(name) $PRIV(app)]} {
2136                interp alias {} ::tkcon::EvalAttached {} uplevel \#0
2137            } else {
2138                interp alias {} ::tkcon::EvalAttached {} \
2139                        ::tkcon::Slave $::tkcon::PRIV(app)
2140            }
2141            set namespOK 1
2142        }
2143        sock* {
2144            interp alias {} ::tkcon::EvalAttached {} \
2145                    ::tkcon::EvalSlave uplevel \#0
2146            # The file event will just puts whatever data is found
2147            # into the interpreter
2148            fconfigure $name -buffering line -blocking 0
2149            fileevent $name readable [list ::tkcon::EvalSocketEvent $name]
2150        }
2151        dpy:* -
2152        interp {
2153            if {$OPT(nontcl)} {
2154                interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSlave
2155            } else {
2156                interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSend
2157                set namespOK 1
2158            }
2159        }
2160        default {
2161            return -code error "[lindex [info level 0] 0] did not specify\
2162                    a valid type: must be slave or interp"
2163        }
2164    }
2165    if {![string match {} $ns] && $namespOK} {
2166        AttachNamespace $ns
2167    }
2168    return [AttachId]
2169}
2170
2171proc ::tkcon::AttachId {} {
2172    # return Attach info in a form that Attach accepts again
2173    variable PRIV
2174
2175    if {[string match {} $PRIV(appname)]} {
2176        variable OPT
2177        set appname [concat $PRIV(name) $OPT(exec)]
2178    } else {
2179        set appname $PRIV(appname)
2180    }
2181    set id [list $appname $PRIV(apptype)]
2182    # only display ns info if it isn't "::" as that is what is also
2183    # used to indicate no eval in namespace
2184    if {![string match :: $PRIV(namesp)]} { lappend id $PRIV(namesp) }
2185    if {[info exists PRIV(console)]} {
2186        variable ATTACH
2187        set ATTACH($PRIV(console)) $id
2188    }
2189    return $id
2190}
2191
2192## ::tkcon::AttachNamespace - called to attach tkcon to a namespace
2193# ARGS: name    - namespace name in which tkcon should eval commands
2194# Results:      ::tkcon::EvalAttached will be modified
2195##
2196proc ::tkcon::AttachNamespace { name } {
2197    variable PRIV
2198    variable OPT
2199
2200    if {($OPT(nontcl) && [string match interp $PRIV(apptype)]) \
2201            || [string match socket $PRIV(apptype)] \
2202            || $PRIV(deadapp)} {
2203        return -code error "can't attach to namespace in attached environment"
2204    }
2205    if {[string match Main $name]} {set name ::}
2206    if {[string compare {} $name] && \
2207            [lsearch [Namespaces ::] $name] == -1} {
2208        return -code error "No known namespace \"$name\""
2209    }
2210    if {[regexp {^(|::)$} $name]} {
2211        ## If name=={} || ::, we want the primary namespace
2212        set alias [interp alias {} ::tkcon::EvalAttached]
2213        if {[string match ::tkcon::EvalNamespace* $alias]} {
2214            eval [list interp alias {} ::tkcon::EvalAttached {}] \
2215                    [lindex $alias 1]
2216        }
2217        set name ::
2218    } else {
2219        interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalNamespace \
2220                [interp alias {} ::tkcon::EvalAttached] [list $name]
2221    }
2222    set PRIV(namesp) $name
2223    return [AttachId]
2224}
2225
2226## ::tkcon::NewSocket - called to create a socket to connect to
2227# ARGS: none
2228# Results:      It will create a socket, and attach if requested
2229##
2230proc ::tkcon::NewSocket {} {
2231    variable PRIV
2232
2233    set t $PRIV(base).newsock
2234    if {![winfo exists $t]} {
2235        toplevel $t
2236        wm withdraw $t
2237        wm title $t "tkcon Create Socket"
2238        label $t.lhost -text "Host: "
2239        entry $t.host -width 16 -takefocus 1
2240        label $t.lport -text "Port: "
2241        entry $t.port -width 4 -takefocus 1
2242        button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} -width 4 \
2243            -takefocus 1
2244        bind $t.host <Return> [list focus $t.port]
2245        bind $t.port <Return> [list focus $t.ok]
2246        bind $t.ok   <Return> [list $t.ok invoke]
2247        grid $t.lhost $t.host $t.lport $t.port $t.ok -sticky ew
2248        grid configure $t.ok -padx 4 -pady 2
2249        grid columnconfig $t 1 -weight 1
2250        grid rowconfigure $t 1 -weight 1
2251        wm transient $t $PRIV(root)
2252        wm group $t $PRIV(root)
2253        wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
2254                reqwidth $t]) / 2}]+[expr {([winfo \
2255                screenheight $t]-[winfo reqheight $t]) / 2}]
2256        bind $t <Escape> [list destroy $t]
2257    }
2258    #$t.host delete 0 end
2259    #$t.port delete 0 end
2260    wm deiconify $t
2261    raise $t
2262    grab $t
2263    focus $t.host
2264    vwait ::tkcon::PRIV(grab)
2265    grab release $t
2266    wm withdraw $t
2267    set host [$t.host get]
2268    set port [$t.port get]
2269    if {$host == ""} { return }
2270    if {[catch {
2271        set sock [socket $host $port]
2272    } err]} {
2273        tk_messageBox -title "Socket Connection Error" \
2274                -message "Unable to connect to \"$host:$port\":\n$err" \
2275                -icon error -type ok
2276    } else {
2277        Attach $sock socket
2278    }
2279}
2280
2281## ::tkcon::Load - sources a file into the console
2282## The file is actually sourced in the currently attached's interp
2283# ARGS: fn      - (optional) filename to source in
2284# Returns:      selected filename ({} if nothing was selected)
2285##
2286proc ::tkcon::Load { {fn ""} } {
2287    set types {
2288        {{Tcl Files}    {.tcl .tk}}
2289        {{Text Files}   {.txt}}
2290        {{All Files}    *}
2291    }
2292    if {
2293        [string match {} $fn] &&
2294        ([catch {tk_getOpenFile -filetypes $types \
2295            -title "Source File"} fn] || [string match {} $fn])
2296    } { return }
2297    EvalAttached [list source $fn]
2298}
2299
2300## ::tkcon::Save - saves the console or other widget buffer to a file
2301## This does not eval in a slave because it's not necessary
2302# ARGS: w       - console text widget
2303#       fn      - (optional) filename to save to
2304##
2305proc ::tkcon::Save { {fn ""} {type ""} {opt ""} {mode w} } {
2306    variable PRIV
2307
2308    if {![regexp -nocase {^(all|history|stdin|stdout|stderr|widget)$} $type]} {
2309        array set s { 0 All 1 History 2 Stdin 3 Stdout 4 Stderr 5 Cancel }
2310        ## Allow user to specify what kind of stuff to save
2311        set type [tk_dialog $PRIV(base).savetype "Save Type" \
2312                "What part of the text do you want to save?" \
2313                questhead 0 $s(0) $s(1) $s(2) $s(3) $s(4) $s(5)]
2314        if {$type == 5 || $type == -1} return
2315        set type $s($type)
2316    }
2317    if {[string match {} $fn]} {
2318        set types {
2319            {{Tcl Files}        {.tcl .tk}}
2320            {{Text Files}       {.txt}}
2321            {{All Files}        *}
2322        }
2323        if {[catch {tk_getSaveFile -defaultextension .tcl -filetypes $types \
2324                -title "Save $type"} fn] || [string match {} $fn]} return
2325    }
2326    set type [string tolower $type]
2327    switch $type {
2328        stdin - stdout - stderr {
2329            set data {}
2330            foreach {first last} [$PRIV(console) tag ranges $type] {
2331                lappend data [$PRIV(console) get $first $last]
2332            }
2333            set data [join $data \n]
2334        }
2335        history         { set data [tkcon history] }
2336        all - default   { set data [$PRIV(console) get 1.0 end-1c] }
2337        widget          {
2338            set data [$opt get 1.0 end-1c]
2339        }
2340    }
2341    if {[catch {open $fn $mode} fid]} {
2342        return -code error "Save Error: Unable to open '$fn' for writing\n$fid"
2343    }
2344    puts -nonewline $fid $data
2345    close $fid
2346}
2347
2348## ::tkcon::MainInit
2349## This is only called for the main interpreter to include certain procs
2350## that we don't want to include (or rather, just alias) in slave interps.
2351##
2352proc ::tkcon::MainInit {} {
2353    variable PRIV
2354    variable OPT
2355
2356    if {![info exists PRIV(slaves)]} {
2357        array set PRIV [list slave 0 slaves Main name {} \
2358                interps [list [tk appname]]]
2359    }
2360    interp alias {} ::tkcon::Main {} ::tkcon::InterpEval Main
2361    interp alias {} ::tkcon::Slave {} ::tkcon::InterpEval
2362
2363    proc ::tkcon::GetSlaveNum {} {
2364        set i -1
2365        while {[interp exists Slave[incr i]]} {
2366            # oh my god, an empty loop!
2367        }
2368        return $i
2369    }
2370
2371    ## ::tkcon::New - create new console window
2372    ## Creates a slave interpreter and sources in this script.
2373    ## All other interpreters also get a command to eval function in the
2374    ## new interpreter.
2375    ##
2376    proc ::tkcon::New {} {
2377        variable PRIV
2378        global argv0 argc argv
2379
2380        set tmp [interp create Slave[GetSlaveNum]]
2381        lappend PRIV(slaves) $tmp
2382        load {} Tk $tmp
2383        # If we have tbcload, then that should be autoloaded into slaves.
2384        set idx [lsearch [info loaded] "* Tbcload"]
2385        if {$idx != -1} { catch {load {} Tbcload $tmp} }
2386        lappend PRIV(interps) [$tmp eval [list tk appname \
2387                "[tk appname] $tmp"]]
2388        if {[info exists argv0]} {$tmp eval [list set argv0 $argv0]}
2389        if {[info exists argc]}  {$tmp eval [list set argc $argc]}
2390        if {[info exists argv]}  {$tmp eval [list set argv $argv]}
2391        $tmp eval [list namespace eval ::tkcon {}]
2392        $tmp eval [list set ::tkcon::PRIV(name) $tmp]
2393        $tmp eval [list set ::tkcon::PRIV(SCRIPT) $::tkcon::PRIV(SCRIPT)]
2394        $tmp alias exit                         ::tkcon::Exit $tmp
2395        $tmp alias ::tkcon::Destroy             ::tkcon::Destroy $tmp
2396        $tmp alias ::tkcon::New                 ::tkcon::New
2397        $tmp alias ::tkcon::GetSlaveNum         ::tkcon::GetSlaveNum
2398        $tmp alias ::tkcon::Main                ::tkcon::InterpEval Main
2399        $tmp alias ::tkcon::Slave               ::tkcon::InterpEval
2400        $tmp alias ::tkcon::Interps             ::tkcon::Interps
2401        $tmp alias ::tkcon::NewDisplay          ::tkcon::NewDisplay
2402        $tmp alias ::tkcon::Display             ::tkcon::Display
2403        $tmp alias ::tkcon::StateCheckpoint     ::tkcon::StateCheckpoint
2404        $tmp alias ::tkcon::StateCleanup        ::tkcon::StateCleanup
2405        $tmp alias ::tkcon::StateCompare        ::tkcon::StateCompare
2406        $tmp alias ::tkcon::StateRevert         ::tkcon::StateRevert
2407        $tmp eval {
2408            if [catch {source -rsrc tkcon}] { source $::tkcon::PRIV(SCRIPT) }
2409        }
2410        return $tmp
2411    }
2412
2413    ## ::tkcon::Exit - full exit OR destroy slave console
2414    ## This proc should only be called in the main interpreter from a slave.
2415    ## The master determines whether we do a full exit or just kill the slave.
2416    ##
2417    proc ::tkcon::Exit {slave args} {
2418        variable PRIV
2419        variable OPT
2420
2421        ## Slave interpreter exit request
2422        if {[string match exit $OPT(slaveexit)]
2423            || [llength $PRIV(interps)] == 1} {
2424            ## Only exit if it specifically is stated to do so, or this
2425            ## is the last interp
2426            uplevel 1 exit $args
2427        } else {
2428            ## Otherwise we will delete the slave interp and associated data
2429            Destroy $slave
2430        }
2431    }
2432
2433    ## ::tkcon::Destroy - destroy console window
2434    ## This proc should only be called by the main interpreter.  If it is
2435    ## called from there, it will ask before exiting tkcon.  All others
2436    ## (slaves) will just have their slave interpreter deleted, closing them.
2437    ##
2438    proc ::tkcon::Destroy {{slave {}}} {
2439        variable PRIV
2440
2441        # Just close on the last one
2442        if {[llength $PRIV(interps)] == 1} { exit }
2443        if {"" == $slave} {
2444            ## Main interpreter close request
2445            if {[tk_messageBox -parent $PRIV(root) -title "Quit tkcon?" \
2446                     -message "Close all windows and exit tkcon?" \
2447                     -icon question -type yesno] == "yes"} { exit }
2448            return
2449        } elseif {$slave == $::tkcon::OPT(exec)} {
2450            set name  [tk appname]
2451            set slave "Main"
2452        } else {
2453            ## Slave interpreter close request
2454            set name [InterpEval $slave]
2455            interp delete $slave
2456        }
2457        set PRIV(interps) [lremove $PRIV(interps) [list $name]]
2458        set PRIV(slaves)  [lremove $PRIV(slaves) [list $slave]]
2459        StateCleanup $slave
2460    }
2461
2462    if {$OPT(overrideexit)} {
2463        ## We want to do a couple things before exiting...
2464        if {[catch {rename ::exit ::tkcon::FinalExit} err]} {
2465            puts stderr "tkcon might panic:\n$err"
2466        }
2467        proc ::exit args {
2468            if {$::tkcon::OPT(usehistory)} {
2469                if {[catch {open $::tkcon::PRIV(histfile) w} fid]} {
2470                    puts stderr "unable to save history file:\n$fid"
2471                    # pause a moment, because we are about to die finally...
2472                    after 1000
2473                } else {
2474                    set max [::tkcon::EvalSlave history nextid]
2475                    set id [expr {$max - $::tkcon::OPT(history)}]
2476                    if {$id < 1} { set id 1 }
2477                    ## FIX: This puts history in backwards!!
2478                    while {($id < $max) && ![catch \
2479                            {::tkcon::EvalSlave history event $id} cmd]} {
2480                        if {[string compare {} $cmd]} {
2481                            puts $fid "::tkcon::EvalSlave\
2482                                    history add [list $cmd]"
2483                        }
2484                        incr id
2485                    }
2486                    close $fid
2487                }
2488            }
2489            uplevel 1 ::tkcon::FinalExit $args
2490        }
2491    }
2492
2493    ## ::tkcon::InterpEval - passes evaluation to another named interpreter
2494    ## If the interpreter is named, but no args are given, it returns the
2495    ## [tk appname] of that interps master (not the associated eval slave).
2496    ##
2497    proc ::tkcon::InterpEval {{slave {}} args} {
2498        variable PRIV
2499
2500        if {[llength [info level 0]] == 1} {
2501            # no args given
2502            return $PRIV(slaves)
2503        } elseif {[string match {[Mm]ain} $slave]} {
2504            set slave {}
2505        }
2506        if {[llength $args]} {
2507            return [interp eval $slave uplevel \#0 $args]
2508        } else {
2509            # beware safe interps with Tk
2510            if {[interp eval $slave {llength [info commands tk]}]} {
2511                if {[catch {interp eval $slave tk appname} name]} {
2512                    return "safetk"
2513                }
2514                return $name
2515            }
2516        }
2517    }
2518
2519    proc ::tkcon::Interps {{ls {}} {interp {}}} {
2520        if {[string match {} $interp]} {
2521            lappend ls {} [tk appname]
2522        }
2523        foreach i [interp slaves $interp] {
2524            if {[string compare {} $interp]} { set i "$interp $i" }
2525            if {[string compare {} [interp eval $i package provide Tk]]} {
2526                # beware safe interps with Tk
2527                if {[catch {interp eval $i tk appname} name]} {
2528                    set name {}
2529                }
2530                lappend ls $i $name
2531            } else {
2532                lappend ls $i {}
2533            }
2534            set ls [Interps $ls $i]
2535        }
2536        return $ls
2537    }
2538
2539    proc ::tkcon::Display {{disp {}}} {
2540        variable DISP
2541
2542        set res {}
2543        if {$disp != ""} {
2544            if {![info exists DISP($disp)]} { return }
2545            return [list $DISP($disp) [winfo interps -displayof $DISP($disp)]]
2546        }
2547        return [lsort -dictionary [array names DISP]]
2548    }
2549
2550    proc ::tkcon::NewDisplay {} {
2551        variable PRIV
2552        variable DISP
2553
2554        set t $PRIV(base).newdisp
2555        if {![winfo exists $t]} {
2556            toplevel $t
2557            wm withdraw $t
2558            wm title $t "tkcon Attach to Display"
2559            label $t.gets -text "New Display: "
2560            entry $t.data -width 32
2561            button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1}
2562            bind $t.data <Return> [list $t.ok invoke]
2563            bind $t.ok   <Return> [list $t.ok invoke]
2564            grid $t.gets $t.data -sticky ew
2565            grid $t.ok   -       -sticky ew
2566            grid columnconfig $t 1 -weight 1
2567            grid rowconfigure $t 1 -weight 1
2568            wm transient $t $PRIV(root)
2569            wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
2570                    reqwidth $t]) / 2}]+[expr {([winfo \
2571                    screenheight $t]-[winfo reqheight $t]) / 2}]
2572        }
2573        $t.data delete 0 end
2574        wm deiconify $t
2575        raise $t
2576        grab $t
2577        focus $t.data
2578        vwait ::tkcon::PRIV(grab)
2579        grab release $t
2580        wm withdraw $t
2581        set disp [$t.data get]
2582        if {$disp == ""} { return }
2583        regsub -all {\.} [string tolower $disp] ! dt
2584        set dt $PRIV(base).$dt
2585        destroy $dt
2586        if {[catch {
2587            toplevel $dt -screen $disp
2588            set interps [winfo interps -displayof $dt]
2589            if {![llength $interps]} {
2590                error "No other Tk interpreters on $disp"
2591            }
2592            ::send::send -displayof $dt [lindex $interps 0] [list info tclversion]
2593        } err]} {
2594            global env
2595            if {[info exists env(DISPLAY)]} {
2596                set myd $env(DISPLAY)
2597            } else {
2598                set myd "myDisplay:0"
2599            }
2600            tk_messageBox -title "Display Connection Error" \
2601                    -message "Unable to connect to \"$disp\":\n$err\
2602                    \nMake sure you have xauth-based permissions\
2603                    (xauth add $myd . `mcookie`), and xhost is disabled\
2604                    (xhost -) on \"$disp\"" \
2605                    -icon error -type ok
2606            destroy $dt
2607            return
2608        }
2609        set DISP($disp) $dt
2610        wm withdraw $dt
2611        bind $dt <Destroy> [subst {catch {unset ::tkcon::DISP($disp)}}]
2612        tk_messageBox -title "$disp Connection" \
2613                -message "Connected to \"$disp\", found:\n[join $interps \n]" \
2614                -type ok
2615    }
2616
2617    ##
2618    ## The following state checkpoint/revert procedures are very sketchy
2619    ## and prone to problems.  They do not track modifications to currently
2620    ## existing procedures/variables, and they can really screw things up
2621    ## if you load in libraries (especially Tk) between checkpoint and
2622    ## revert.  Only with this knowledge in mind should you use these.
2623    ##
2624
2625    ## ::tkcon::StateCheckpoint - checkpoints the current state of the system
2626    ## This allows you to return to this state with ::tkcon::StateRevert
2627    # ARGS:
2628    ##
2629    proc ::tkcon::StateCheckpoint {app type} {
2630        variable CPS
2631        variable PRIV
2632
2633        if {[info exists CPS($type,$app,cmd)] && \
2634                [tk_dialog $PRIV(base).warning "Overwrite Previous State?" \
2635                "Are you sure you want to lose previously checkpointed\
2636                state of $type \"$app\"?" questhead 1 "Do It" "Cancel"]} return
2637        set CPS($type,$app,cmd) [EvalOther $app $type info commands *]
2638        set CPS($type,$app,var) [EvalOther $app $type info vars *]
2639        return
2640    }
2641
2642    ## ::tkcon::StateCompare - compare two states and output difference
2643    # ARGS:
2644    ##
2645    proc ::tkcon::StateCompare {app type {verbose 0}} {
2646        variable CPS
2647        variable PRIV
2648        variable OPT
2649        variable COLOR
2650
2651        if {![info exists CPS($type,$app,cmd)]} {
2652            return -code error \
2653                    "No previously checkpointed state for $type \"$app\""
2654        }
2655        set w $PRIV(base).compare
2656        if {[winfo exists $w]} {
2657            $w.text config -state normal
2658            $w.text delete 1.0 end
2659        } else {
2660            toplevel $w
2661            frame $w.btn
2662            scrollbar $w.sy -takefocus 0 -bd 1 -command [list $w.text yview]
2663            text $w.text -yscrollcommand [list $w.sy set] -height 12 \
2664                    -foreground $COLOR(stdin) \
2665                    -background $COLOR(bg) \
2666                    -insertbackground $COLOR(cursor) \
2667                    -font $OPT(font)
2668            pack $w.btn -side bottom -fill x
2669            pack $w.sy -side right -fill y
2670            pack $w.text -fill both -expand 1
2671            button $w.btn.close -text "Dismiss" -width 11 \
2672                    -command [list destroy $w]
2673            button $w.btn.check  -text "Recheckpoint" -width 11
2674            button $w.btn.revert -text "Revert" -width 11
2675            button $w.btn.expand -text "Verbose" -width 11
2676            button $w.btn.update -text "Update" -width 11
2677            pack $w.btn.check $w.btn.revert $w.btn.expand $w.btn.update \
2678                    $w.btn.close -side left -fill x -padx 4 -pady 2 -expand 1
2679            $w.text tag config red -foreground red
2680        }
2681        wm title $w "Compare State: $type [list $app]"
2682
2683        $w.btn.check config \
2684                -command "::tkcon::StateCheckpoint [list $app] $type; \
2685                ::tkcon::StateCompare [list $app] $type $verbose"
2686        $w.btn.revert config \
2687                -command "::tkcon::StateRevert [list $app] $type; \
2688                ::tkcon::StateCompare [list $app] $type $verbose"
2689        $w.btn.update config -command [info level 0]
2690        if {$verbose} {
2691            $w.btn.expand config -text Brief \
2692                    -command [list ::tkcon::StateCompare $app $type 0]
2693        } else {
2694            $w.btn.expand config -text Verbose \
2695                    -command [list ::tkcon::StateCompare $app $type 1]
2696        }
2697        ## Don't allow verbose mode unless 'dump' exists in $app
2698        ## We're assuming this is tkcon's dump command
2699        set hasdump [llength [EvalOther $app $type info commands dump]]
2700        if {$hasdump} {
2701            $w.btn.expand config -state normal
2702        } else {
2703            $w.btn.expand config -state disabled
2704        }
2705
2706        set cmds [lremove [EvalOther $app $type info commands *] \
2707                $CPS($type,$app,cmd)]
2708        set vars [lremove [EvalOther $app $type info vars *] \
2709                $CPS($type,$app,var)]
2710
2711        if {$hasdump && $verbose} {
2712            set cmds [EvalOther $app $type eval dump c -nocomplain $cmds]
2713            set vars [EvalOther $app $type eval dump v -nocomplain $vars]
2714        }
2715        $w.text insert 1.0 "NEW COMMANDS IN \"$app\":\n" red \
2716                $cmds {} "\n\nNEW VARIABLES IN \"$app\":\n" red $vars {}
2717
2718        raise $w
2719        $w.text config -state disabled
2720    }
2721
2722    ## ::tkcon::StateRevert - reverts interpreter to previous state
2723    # ARGS:
2724    ##
2725    proc ::tkcon::StateRevert {app type} {
2726        variable CPS
2727        variable PRIV
2728
2729        if {![info exists CPS($type,$app,cmd)]} {
2730            return -code error \
2731                    "No previously checkpointed state for $type \"$app\""
2732        }
2733        if {![tk_dialog $PRIV(base).warning "Revert State?" \
2734                "Are you sure you want to revert the state in $type \"$app\"?"\
2735                questhead 1 "Do It" "Cancel"]} {
2736            foreach i [lremove [EvalOther $app $type info commands *] \
2737                    $CPS($type,$app,cmd)] {
2738                catch {EvalOther $app $type rename $i {}}
2739            }
2740            foreach i [lremove [EvalOther $app $type info vars *] \
2741                    $CPS($type,$app,var)] {
2742                catch {EvalOther $app $type unset $i}
2743            }
2744        }
2745    }
2746
2747    ## ::tkcon::StateCleanup - cleans up state information in master array
2748    #
2749    ##
2750    proc ::tkcon::StateCleanup {args} {
2751        variable CPS
2752
2753        if {![llength $args]} {
2754            foreach state [array names CPS slave,*] {
2755                if {![interp exists [string range $state 6 end]]} {
2756                    unset CPS($state)
2757                }
2758            }
2759        } else {
2760            set app  [lindex $args 0]
2761            set type [lindex $args 1]
2762            if {[regexp {^(|slave)$} $type]} {
2763                foreach state [array names CPS "slave,$app\[, \]*"] {
2764                    if {![interp exists [string range $state 6 end]]} {
2765                        unset CPS($state)
2766                    }
2767                }
2768            } else {
2769                catch {unset CPS($type,$app)}
2770            }
2771        }
2772    }
2773}
2774
2775## ::tkcon::Event - get history event, search if string != {}
2776## look forward (next) if $int>0, otherwise look back (prev)
2777# ARGS: W       - console widget
2778##
2779proc ::tkcon::Event {int {str {}}} {
2780    if {!$int} return
2781
2782    variable PRIV
2783    set w $PRIV(console)
2784
2785    set nextid [EvalSlave history nextid]
2786    if {[string compare {} $str]} {
2787        ## String is not empty, do an event search
2788        set event $PRIV(event)
2789        if {$int < 0 && $event == $nextid} { set PRIV(cmdbuf) $str }
2790        set len [string len $PRIV(cmdbuf)]
2791        incr len -1
2792        if {$int > 0} {
2793            ## Search history forward
2794            while {$event < $nextid} {
2795                if {[incr event] == $nextid} {
2796                    $w delete limit end
2797                    $w insert limit $PRIV(cmdbuf)
2798                    break
2799                } elseif {
2800                    ![catch {EvalSlave history event $event} res] &&
2801                    [set p [string first $PRIV(cmdbuf) $res]] > -1
2802                } {
2803                    set p2 [expr {$p + [string length $PRIV(cmdbuf)]}]
2804                    $w delete limit end
2805                    $w insert limit $res
2806                    Blink $w "limit + $p c" "limit + $p2 c"
2807                    break
2808                }
2809            }
2810            set PRIV(event) $event
2811        } else {
2812            ## Search history reverse
2813            while {![catch {EvalSlave history event [incr event -1]} res]} {
2814                if {[set p [string first $PRIV(cmdbuf) $res]] > -1} {
2815                    set p2 [expr {$p + [string length $PRIV(cmdbuf)]}]
2816                    $w delete limit end
2817                    $w insert limit $res
2818                    set PRIV(event) $event
2819                    Blink $w "limit + $p c" "limit + $p2 c"
2820                    break
2821                }
2822            }
2823        }
2824    } else {
2825        ## String is empty, just get next/prev event
2826        if {$int > 0} {
2827            ## Goto next command in history
2828            if {$PRIV(event) < $nextid} {
2829                $w delete limit end
2830                if {[incr PRIV(event)] == $nextid} {
2831                    $w insert limit $PRIV(cmdbuf)
2832                } else {
2833                    $w insert limit [EvalSlave history event $PRIV(event)]
2834                }
2835            }
2836        } else {
2837            ## Goto previous command in history
2838            if {$PRIV(event) == $nextid} {
2839                set PRIV(cmdbuf) [CmdGet $w]
2840            }
2841            if {[catch {EvalSlave history event [incr PRIV(event) -1]} res]} {
2842                incr PRIV(event)
2843            } else {
2844                $w delete limit end
2845                $w insert limit $res
2846            }
2847        }
2848    }
2849    $w mark set insert end
2850    $w see end
2851}
2852
2853## ::tkcon::Highlight - magic highlighting
2854## beware: voodoo included
2855# ARGS:
2856##
2857proc ::tkcon::Highlight {w type} {
2858    variable COLOR
2859    variable OPT
2860
2861    switch -exact $type {
2862        "error" { HighlightError $w }
2863        "tcl" - "test" {
2864            if {[winfo class $w] != "Ctext"} { return }
2865
2866            foreach {app type} [tkcon attach] {break}
2867            set cmds [::tkcon::EvalOther $app $type info commands]
2868
2869            set classes [list \
2870                 [list comment ClassForRegexp "^\\s*#\[^\n\]*" $COLOR(stderr)] \
2871                 [list var     ClassWithOnlyCharStart "\$" $COLOR(stdout)] \
2872                 [list syntax  ClassForSpecialChars "\[\]{}\"" $COLOR(prompt)] \
2873                 [list command Class $cmds $COLOR(proc)] \
2874                ]
2875
2876            # Remove all highlight classes from a widget
2877            ctext::clearHighlightClasses $w
2878            foreach class $classes {
2879                foreach {cname ctype cptn ccol} $class break
2880                ctext::addHighlight$ctype $w $cname $ccol $cptn
2881            }
2882            $w highlight 1.0 end
2883        }
2884    }
2885}
2886
2887## ::tkcon::HighlightError - magic error highlighting
2888## beware: voodoo included
2889# ARGS:
2890##
2891proc ::tkcon::HighlightError w {
2892    variable COLOR
2893    variable OPT
2894
2895    ## do voodoo here
2896    set app [Attach]
2897    # we have to pull the text out, because text regexps are screwed on \n's.
2898    set info [$w get 1.0 end-1c]
2899    # Check for specific line error in a proc
2900    set exp(proc) "\"(\[^\"\]+)\"\n\[\t \]+\\\(procedure \"(\[^\"\]+)\""
2901    # Check for too few args to a proc
2902    set exp(param) "parameter \"(\[^\"\]+)\" to \"(\[^\"\]+)\""
2903    set start 1.0
2904    while {
2905        [regexp -indices -- $exp(proc) $info junk what cmd] ||
2906        [regexp -indices -- $exp(param) $info junk what cmd]
2907    } {
2908        foreach {w0 w1} $what {c0 c1} $cmd {break}
2909        set what [string range $info $w0 $w1]
2910        set cmd  [string range $info $c0 $c1]
2911        if {[string match *::* $cmd]} {
2912            set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \
2913                    [list [namespace qualifiers $cmd] \
2914                    [list info procs [namespace tail $cmd]]]]
2915        } else {
2916            set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]]
2917        }
2918        if {[llength $res]==1} {
2919            set tag [UniqueTag $w]
2920            $w tag add $tag $start+${c0}c $start+1c+${c1}c
2921            $w tag configure $tag -foreground $COLOR(stdout)
2922            $w tag bind $tag <Enter> [list $w tag configure $tag -under 1]
2923            $w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
2924            $w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
2925                    {[list $OPT(edit) -attach $app -type proc -find $what -- $cmd]}"
2926        }
2927        set info [string range $info $c1 end]
2928        set start [$w index $start+${c1}c]
2929    }
2930    ## Next stage, check for procs that start a line
2931    set start 1.0
2932    set exp(cmd) "^\"\[^\" \t\n\]+"
2933    while {
2934        [string compare {} [set ix \
2935                [$w search -regexp -count numc -- $exp(cmd) $start end]]]
2936    } {
2937        set start [$w index $ix+${numc}c]
2938        # +1c to avoid the first quote
2939        set cmd [$w get $ix+1c $start]
2940        if {[string match *::* $cmd]} {
2941            set res [uplevel 1 ::tkcon::EvalOther $app namespace eval \
2942                    [list [namespace qualifiers $cmd] \
2943                    [list info procs [namespace tail $cmd]]]]
2944        } else {
2945            set res [uplevel 1 ::tkcon::EvalOther $app info procs [list $cmd]]
2946        }
2947        if {[llength $res]==1} {
2948            set tag [UniqueTag $w]
2949            $w tag add $tag $ix+1c $start
2950            $w tag configure $tag -foreground $COLOR(proc)
2951            $w tag bind $tag <Enter> [list $w tag configure $tag -under 1]
2952            $w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
2953            $w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
2954                    {[list $OPT(edit) -attach $app -type proc -- $cmd]}"
2955        }
2956    }
2957}
2958
2959proc ::tkcon::ExpectInit {{termcap 1} {terminfo 1}} {
2960    global env
2961
2962    if {$termcap} {
2963        set env(TERM) "tt"
2964        set env(TERMCAP) {tt:
2965 :ks=\E[KS:
2966 :ke=\E[KE:
2967 :cm=\E[%d;%dH:
2968 :up=\E[A:
2969 :nd=\E[C:
2970 :cl=\E[H\E[J:
2971 :do=^J:
2972 :so=\E[7m:
2973 :se=\E[m:
2974 :k1=\EOP:
2975 :k2=\EOQ:
2976 :k3=\EOR:
2977 :k4=\EOS:
2978 :k5=\EOT:
2979 :k6=\EOU:
2980 :k7=\EOV:
2981 :k8=\EOW:
2982 :k9=\EOX:
2983    }
2984    }
2985
2986    if {$terminfo} {
2987        set env(TERM) "tkterm"
2988        if {![info exists env(TEMP)]} { set env(TEMP) /tmp }
2989        set env(TERMINFO) $env(TEMP)
2990
2991        set ttsrc [file join $env(TEMP) tt.src]
2992        set file [open $ttsrc w]
2993        puts $file {tkterm|Don Libes' tk text widget terminal emulator,
2994 smkx=\E[KS,
2995 rmkx=\E[KE,
2996 cup=\E[%p1%d;%p2%dH,
2997 cuu1=\E[A,
2998 cuf1=\E[C,
2999 clear=\E[H\E[J,
3000 ind=\n,
3001 cr=\r,
3002 smso=\E[7m,
3003 rmso=\E[m,
3004 kf1=\EOP,
3005 kf2=\EOQ,
3006 kf3=\EOR,
3007 kf4=\EOS,
3008 kf5=\EOT,
3009 kf6=\EOU,
3010 kf7=\EOV,
3011 kf8=\EOW,
3012 kf9=\EOX,
3013    }
3014        close $file
3015
3016        if {[catch {exec tic $ttsrc} msg]} {
3017            return -code error \
3018                "tic failed, you may not have terminfo support:\n$msg"
3019        }
3020
3021        file delete $ttsrc
3022    }
3023}
3024
3025# term_exit is called if the spawned process exits
3026proc ::tkcon::term_exit {w} {
3027    variable EXP
3028    catch {exp_close -i $EXP(spawn_id)}
3029    set EXP(forever) 1
3030    unset EXP
3031}
3032
3033# term_chars_changed is called after every change to the displayed chars
3034# You can use if you want matches to occur in the background (a la bind)
3035# If you want to test synchronously, then just do so - you don't need to
3036# redefine this procedure.
3037proc ::tkcon::term_chars_changed {w args} {
3038}
3039
3040# term_cursor_changed is called after the cursor is moved
3041proc ::tkcon::term_cursor_changed {w args} {
3042}
3043
3044proc ::tkcon::term_update_cursor {w args} {
3045    variable OPT
3046    variable EXP
3047
3048    $w mark set insert $EXP(row).$EXP(col)
3049    $w see insert
3050    term_cursor_changed $w
3051}
3052
3053proc ::tkcon::term_clear {w args} {
3054    $w delete 1.0 end
3055    term_init $w
3056}
3057
3058proc ::tkcon::term_init {w args} {
3059    variable OPT
3060    variable EXP
3061
3062    # initialize it with blanks to make insertions later more easily
3063    set blankline [string repeat " " $OPT(cols)]\n
3064    for {set i 1} {$i <= $OPT(rows)} {incr i} {
3065        $w insert $i.0 $blankline
3066    }
3067
3068    set EXP(row) 1
3069    set EXP(col) 0
3070
3071    $w mark set insert $EXP(row).$EXP(col)
3072}
3073
3074proc ::tkcon::term_down {w args} {
3075    variable OPT
3076    variable EXP
3077
3078    if {$EXP(row) < $OPT(rows)} {
3079        incr EXP(row)
3080    } else {
3081        # already at last line of term, so scroll screen up
3082        $w delete 1.0 2.0
3083
3084        # recreate line at end
3085        $w insert end [string repeat " " $OPT(cols)]\n
3086    }
3087}
3088
3089proc ::tkcon::term_insert {w s} {
3090    variable OPT
3091    variable EXP
3092
3093    set chars_rem_to_write [string length $s]
3094    set space_rem_on_line  [expr {$OPT(cols) - $EXP(col)}]
3095
3096    set tag_action [expr {$EXP(standout) ? "add" : "remove"}]
3097
3098    ##################
3099    # write first line
3100    ##################
3101
3102    if {$chars_rem_to_write > $space_rem_on_line} {
3103        set chars_to_write $space_rem_on_line
3104        set newline 1
3105    } else {
3106        set chars_to_write $chars_rem_to_write
3107        set newline 0
3108    }
3109
3110    $w delete $EXP(row).$EXP(col) \
3111        $EXP(row).[expr {$EXP(col) + $chars_to_write}]
3112    $w insert $EXP(row).$EXP(col) \
3113        [string range $s 0 [expr {$space_rem_on_line-1}]]
3114
3115    $w tag $tag_action standout $EXP(row).$EXP(col) \
3116        $EXP(row).[expr {$EXP(col) + $chars_to_write}]
3117
3118    # discard first line already written
3119    incr chars_rem_to_write -$chars_to_write
3120    set s [string range $s $chars_to_write end]
3121
3122    # update EXP(col)
3123    incr EXP(col) $chars_to_write
3124    # update EXP(row)
3125    if {$newline} { term_down $w }
3126
3127    ##################
3128    # write full lines
3129    ##################
3130    while {$chars_rem_to_write >= $OPT(cols)} {
3131        $w delete $EXP(row).0 $EXP(row).end
3132        $w insert $EXP(row).0 [string range $s 0 [expr {$OPT(cols)-1}]]
3133        $w tag $tag_action standout $EXP(row).0 $EXP(row).end
3134
3135        # discard line from buffer
3136        set s [string range $s $OPT(cols) end]
3137        incr chars_rem_to_write -$OPT(cols)
3138
3139        set EXP(col) 0
3140        term_down $w
3141    }
3142
3143    #################
3144    # write last line
3145    #################
3146
3147    if {$chars_rem_to_write} {
3148        $w delete $EXP(row).0 $EXP(row).$chars_rem_to_write
3149        $w insert $EXP(row).0 $s
3150        $w tag $tag_action standout $EXP(row).0 $EXP(row).$chars_rem_to_write
3151        set EXP(col) $chars_rem_to_write
3152    }
3153
3154    term_chars_changed $w
3155}
3156
3157proc ::tkcon::Expect {cmd} {
3158    variable OPT
3159    variable PRIV
3160    variable EXP
3161
3162    set EXP(standout) 0
3163    set EXP(row) 0
3164    set EXP(col) 0
3165
3166    set env(LINES)   $OPT(rows)
3167    set env(COLUMNS) $OPT(cols)
3168
3169    ExpectInit
3170    log_user 0
3171    set ::stty_init "-tabs"
3172    uplevel \#0 [linsert $cmd 0 spawn]
3173    set EXP(spawn_id) $::spawn_id
3174    if {[info exists ::spawn_out(slave,name)]} {
3175        set EXP(slave,name) $::spawn_out(slave,name)
3176        catch {stty rows $OPT(rows) columns $OPT(cols) < $::spawn_out(slave,name)}
3177    }
3178    if {[string index $cmd end] == "&"} {
3179        set cmd expect_background
3180    } else {
3181        set cmd expect
3182    }
3183    bind $PRIV(console) <Meta-KeyPress> {
3184        if {"%A" != ""} {
3185            exp_send -i $::tkcon::EXP(spawn_id) "\033%A"
3186            break
3187        }
3188    }
3189    bind $PRIV(console) <KeyPress> {
3190        exp_send -i $::tkcon::EXP(spawn_id) -- %A
3191        break
3192    }
3193    bind $PRIV(console) <Control-space> {exp_send -null}
3194    set code [catch {
3195        term_init $PRIV(console)
3196        while {[info exists EXP(spawn_id)]} {
3197        $cmd {
3198            -i $::tkcon::EXP(spawn_id)
3199            -re "^\[^\x01-\x1f\]+" {
3200                # Text
3201                ::tkcon::term_insert $::tkcon::PRIV(console) \
3202                    $expect_out(0,string)
3203                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3204            } "^\r" {
3205                # (cr,) Go to beginning of line
3206                update idle
3207                set ::tkcon::EXP(col) 0
3208                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3209            } "^\n" {
3210                # (ind,do) Move cursor down one line
3211                if {$::tcl_platform(platform) eq "windows"} {
3212                    # Windows seems to get the LF without the CR
3213                    update idle
3214                    set ::tkcon::EXP(col) 0
3215                }
3216                ::tkcon::term_down $::tkcon::PRIV(console)
3217                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3218            } "^\b" {
3219                # Backspace nondestructively
3220                incr ::tkcon::EXP(col) -1
3221                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3222            } "^\a" {
3223                bell
3224            } "^\t" {
3225                # Tab, shouldn't happen
3226                send_error "got a tab!?"
3227            } eof {
3228                ::tkcon::term_exit $::tkcon::PRIV(console)
3229            } "^\x1b\\\[A" {
3230                # Cursor Up (cuu1,up)
3231                incr ::tkcon::EXP(row) -1
3232                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3233            } "^\x1b\\\[B" {
3234                # Cursor Down
3235                incr ::tkcon::EXP(row)
3236                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3237            } "^\x1b\\\[C" {
3238                # Cursor Right (cuf1,nd)
3239                incr ::tkcon::EXP(col)
3240                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3241            } "^\x1b\\\[D" {
3242                # Cursor Left
3243                incr ::tkcon::EXP(col)
3244                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3245            } "^\x1b\\\[H" {
3246                # Cursor Home
3247            } -re "^\x1b\\\[(\[0-9\]*);(\[0-9\]*)H" {
3248                # (cup,cm) Move to row y col x
3249                set ::tkcon::EXP(row) [expr {$expect_out(1,string)+1}]
3250                set ::tkcon::EXP(col) $expect_out(2,string)
3251                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3252            } "^\x1b\\\[H\x1b\\\[J" {
3253                # (clear,cl) Clear screen
3254                ::tkcon::term_clear $::tkcon::PRIV(console)
3255                ::tkcon::term_update_cursor $::tkcon::PRIV(console)
3256            } "^\x1b\\\[7m" {
3257                # (smso,so) Begin standout mode
3258                set ::tkcon::EXP(standout) 1
3259            } "^\x1b\\\[m" {
3260                # (rmso,se) End standout mode
3261                set ::tkcon::EXP(standout) 0
3262            } "^\x1b\\\[KS" {
3263                # (smkx,ks) start keyboard-transmit mode
3264                # terminfo invokes these when going in/out of graphics mode
3265                # In graphics mode, we should have no scrollbars
3266                #graphicsSet 1
3267            } "^\x1b\\\[KE" {
3268                # (rmkx,ke) end keyboard-transmit mode
3269                # Out of graphics mode, we should have scrollbars
3270                #graphicsSet 0
3271            }
3272        }
3273        }
3274        #vwait ::tkcon::EXP(forever)
3275    } err]
3276    bind $PRIV(console) <Meta-KeyPress> {}
3277    bind $PRIV(console) <KeyPress>      {}
3278    bind $PRIV(console) <Control-space> {}
3279    catch {unset EXP}
3280    if {$code} {
3281        return -code $code -errorinfo $::errorInfo $err
3282    }
3283}
3284
3285## tkcon - command that allows control over the console
3286## This always exists in the main interpreter, and is aliased into
3287## other connected interpreters
3288# ARGS: totally variable, see internal comments
3289##
3290proc tkcon {cmd args} {
3291    variable ::tkcon::PRIV
3292    variable ::tkcon::OPT
3293    global errorInfo
3294
3295    switch -glob -- $cmd {
3296        buf* {
3297            ## 'buffer' Sets/Query the buffer size
3298            if {[llength $args]} {
3299                if {[regexp {^[1-9][0-9]*$} $args]} {
3300                    set OPT(buffer) $args
3301                    # catch in case the console doesn't exist yet
3302                    catch {::tkcon::ConstrainBuffer $PRIV(console) \
3303                            $OPT(buffer)}
3304                } else {
3305                    return -code error "buffer must be a valid integer"
3306                }
3307            }
3308            return $OPT(buffer)
3309        }
3310        linelen* {
3311            ## 'linelength' Sets/Query the maximum line length
3312            if {[llength $args]} {
3313                if {[regexp {^-?[0-9]+$} $args]} {
3314                    set OPT(maxlinelen) $args
3315                } else {
3316                    return -code error "buffer must be a valid integer"
3317                }
3318            }
3319            return $OPT(maxlinelen)
3320        }
3321        bg* {
3322            ## 'bgerror' Brings up an error dialog
3323            set errorInfo [lindex $args 1]
3324            bgerror [lindex $args 0]
3325        }
3326        cl* {
3327            ## 'close' Closes the console
3328            ::tkcon::Destroy
3329        }
3330        cons* {
3331            ## 'console' - passes the args to the text widget of the console.
3332            set result [uplevel 1 $PRIV(console) $args]
3333            ::tkcon::ConstrainBuffer $PRIV(console) \
3334                    $OPT(buffer)
3335            return $result
3336        }
3337        congets {
3338            ## 'congets' a replacement for [gets stdin]
3339            # Use the 'gets' alias of 'tkcon_gets' command instead of
3340            # calling the *get* methods directly for best compatability
3341            if {[llength $args]} {
3342                return -code error "wrong # args: must be \"tkcon congets\""
3343            }
3344            tkcon show
3345            set old [bind TkConsole <<TkCon_Eval>>]
3346            bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
3347            set w $PRIV(console)
3348            # Make sure to move the limit to get the right data
3349            $w mark set insert end
3350            $w mark set limit insert
3351            $w see end
3352            vwait ::tkcon::PRIV(wait)
3353            set line [::tkcon::CmdGet $w]
3354            $w insert end \n
3355            bind TkConsole <<TkCon_Eval>> $old
3356            return $line
3357        }
3358        exp* {
3359            ::tkcon::Expect [lindex $args 0]
3360        }
3361        getc* {
3362            ## 'getcommand' a replacement for [gets stdin]
3363            ## This forces a complete command to be input though
3364            if {[llength $args]} {
3365                return -code error "wrong # args: must be \"tkcon getcommand\""
3366            }
3367            tkcon show
3368            set old [bind TkConsole <<TkCon_Eval>>]
3369            bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
3370            set w $PRIV(console)
3371            # Make sure to move the limit to get the right data
3372            $w mark set insert end
3373            $w mark set limit insert
3374            $w see end
3375            vwait ::tkcon::PRIV(wait)
3376            set line [::tkcon::CmdGet $w]
3377            $w insert end \n
3378            while {![info complete $line] || [regexp {[^\\]\\$} $line]} {
3379                vwait ::tkcon::PRIV(wait)
3380                set line [::tkcon::CmdGet $w]
3381                $w insert end \n
3382                $w see end
3383            }
3384            bind TkConsole <<TkCon_Eval>> $old
3385            return $line
3386        }
3387        get - gets {
3388            ## 'gets' - a replacement for [gets stdin]
3389            ## This pops up a text widget to be used for stdin (local grabbed)
3390            if {[llength $args]} {
3391                return -code error "wrong # args: should be \"tkcon gets\""
3392            }
3393            set t $PRIV(base).gets
3394            if {![winfo exists $t]} {
3395                toplevel $t
3396                wm withdraw $t
3397                wm title $t "tkcon gets stdin request"
3398                label $t.gets -text "\"gets stdin\" request:"
3399                text $t.data -width 32 -height 5 -wrap none \
3400                        -xscrollcommand [list $t.sx set] \
3401                        -yscrollcommand [list $t.sy set]
3402                scrollbar $t.sx -orient h -takefocus 0 -highlightthick 0 \
3403                        -command [list $t.data xview]
3404                scrollbar $t.sy -orient v -takefocus 0 -highlightthick 0 \
3405                        -command [list $t.data yview]
3406                button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1}
3407                bind $t.ok <Return> { %W invoke }
3408                grid $t.gets -          -sticky ew
3409                grid $t.data $t.sy      -sticky news
3410                grid $t.sx              -sticky ew
3411                grid $t.ok   -          -sticky ew
3412                grid columnconfig $t 0 -weight 1
3413                grid rowconfig    $t 1 -weight 1
3414                wm transient $t $PRIV(root)
3415                wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
3416                        reqwidth $t]) / 2}]+[expr {([winfo \
3417                        screenheight $t]-[winfo reqheight $t]) / 2}]
3418            }
3419            $t.data delete 1.0 end
3420            wm deiconify $t
3421            raise $t
3422            grab $t
3423            focus $t.data
3424            vwait ::tkcon::PRIV(grab)
3425            grab release $t
3426            wm withdraw $t
3427            return [$t.data get 1.0 end-1c]
3428        }
3429        err* {
3430            ## Outputs stack caused by last error.
3431            ## error handling with pizazz (but with pizza would be nice too)
3432            if {[llength $args]==2} {
3433                set app  [lindex $args 0]
3434                set type [lindex $args 1]
3435                if {[catch {::tkcon::EvalOther $app $type set errorInfo} info]} {
3436                    set info "error getting info from $type $app:\n$info"
3437                }
3438            } else {
3439                set info $PRIV(errorInfo)
3440            }
3441            if {[string match {} $info]} { set info "errorInfo empty" }
3442            ## If args is empty, the -attach switch just ignores it
3443            $OPT(edit) -attach $args -type error -- $info
3444        }
3445        fi* {
3446            ## 'find' string
3447            ::tkcon::Find $PRIV(console) $args
3448        }
3449        fo* {
3450            ## 'font' ?fontname? - gets/sets the font of the console
3451            if {[llength $args]} {
3452                if {[info exists PRIV(console)] && \
3453                        [winfo exists $PRIV(console)]} {
3454                    $PRIV(console) config -font $args
3455                    set OPT(font) [$PRIV(console) cget -font]
3456                } else {
3457                    set OPT(font) $args
3458                }
3459            }
3460            return $OPT(font)
3461        }
3462        hid* - with* {
3463            ## 'hide' 'withdraw' - hides the console.
3464            if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} {
3465                wm withdraw $PRIV(root)
3466            }
3467        }
3468        his* {
3469            ## 'history'
3470            set sub {\2}
3471            if {[string match -new* $args]} { append sub "\n"}
3472            set h [::tkcon::EvalSlave history]
3473            regsub -all "( *\[0-9\]+  |\t)(\[^\n\]*\n?)" $h $sub h
3474            return $h
3475        }
3476        ico* {
3477            ## 'iconify' - iconifies the console with 'iconify'.
3478            if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} {
3479                wm iconify $PRIV(root)
3480            }
3481        }
3482        mas* - eval {
3483            ## 'master' - evals contents in master interpreter
3484            uplevel \#0 $args
3485        }
3486        set {
3487            ## 'set' - set (or get, or unset) simple vars (not whole arrays)
3488            ## from the master console interpreter
3489            ## possible formats:
3490            ##    tkcon set <var>
3491            ##    tkcon set <var> <value>
3492            ##    tkcon set <var> <interp> <var1> <var2> w
3493            ##    tkcon set <var> <interp> <var1> <var2> u
3494            ##    tkcon set <var> <interp> <var1> <var2> r
3495            if {[llength $args]==5} {
3496                ## This is for use w/ 'tkcon upvar' and only works with slaves
3497                foreach {var i var1 var2 op} $args break
3498                if {[string compare {} $var2]} { append var1 "($var2)" }
3499                switch $op {
3500                    u { uplevel \#0 [list unset $var] }
3501                    w {
3502                        return [uplevel \#0 [list set $var \
3503                                [interp eval $i [list set $var1]]]]
3504                    }
3505                    r {
3506                        return [interp eval $i [list set $var1 \
3507                                [uplevel \#0 [list set $var]]]]
3508                    }
3509                }
3510            } elseif {[llength $args] == 1} {
3511                upvar \#0 [lindex $args 0] var
3512                if {[array exists var]} {
3513                    return [array get var]
3514                } else {
3515                    return $var
3516                }
3517            }
3518            return [uplevel \#0 set $args]
3519        }
3520        append {
3521            ## Modify a var in the master environment using append
3522            return [uplevel \#0 append $args]
3523        }
3524        lappend {
3525            ## Modify a var in the master environment using lappend
3526            return [uplevel \#0 lappend $args]
3527        }
3528        sh* - dei* {
3529            ## 'show|deiconify' - deiconifies the console.
3530            if {![info exists PRIV(root)]} {
3531                set PRIV(showOnStartup) 0
3532                set PRIV(root) .tkcon
3533                set OPT(exec) ""
3534            }
3535            if {![winfo exists $PRIV(root)]} {
3536                ::tkcon::Init
3537            }
3538            wm deiconify $PRIV(root)
3539            raise $PRIV(root)
3540            focus -force $PRIV(console)
3541        }
3542        ti* {
3543            ## 'title' ?title? - gets/sets the console's title
3544            if {[llength $args]} {
3545                return [wm title $PRIV(root) [join $args]]
3546            } else {
3547                return [wm title $PRIV(root)]
3548            }
3549        }
3550        upv* {
3551            ## 'upvar' masterVar slaveVar
3552            ## link slave variable slaveVar to the master variable masterVar
3553            ## only works masters<->slave
3554            set masterVar [lindex $args 0]
3555            set slaveVar  [lindex $args 1]
3556            if {[info exists $masterVar]} {
3557                interp eval $OPT(exec) \
3558                        [list set $slaveVar [set $masterVar]]
3559            } else {
3560                catch {interp eval $OPT(exec) [list unset $slaveVar]}
3561            }
3562            interp eval $OPT(exec) \
3563                    [list trace variable $slaveVar rwu \
3564                    [list tkcon set $masterVar $OPT(exec)]]
3565            return
3566        }
3567        v* {
3568            return $PRIV(version)
3569        }
3570        default {
3571            ## tries to determine if the command exists, otherwise throws error
3572            set new ::tkcon::[string toupper \
3573                    [string index $cmd 0]][string range $cmd 1 end]
3574            if {[llength [info command $new]]} {
3575                uplevel \#0 $new $args
3576            } else {
3577                return -code error "bad option \"$cmd\": must be\
3578                        [join [lsort [list attach close console destroy \
3579                        font hide iconify load main master new save show \
3580                        slave deiconify version title bgerror]] {, }]"
3581            }
3582        }
3583    }
3584}
3585
3586##
3587## Some procedures to make up for lack of built-in shell commands
3588##
3589
3590## tkcon_puts -
3591## This allows me to capture all stdout/stderr to the console window
3592## This will be renamed to 'puts' at the appropriate time during init
3593##
3594# ARGS: same as usual   
3595# Outputs:      the string with a color-coded text tag
3596##
3597proc tkcon_puts args {
3598    set len [llength $args]
3599    foreach {arg1 arg2 arg3} $args { break }
3600
3601    if {$len == 1} {
3602        tkcon console insert output "$arg1\n" stdout
3603    } elseif {$len == 2} {
3604        if {![string compare $arg1 -nonewline]} {
3605            tkcon console insert output $arg2 stdout
3606        } elseif {![string compare $arg1 stdout] \
3607                || ![string compare $arg1 stderr]} {
3608            tkcon console insert output "$arg2\n" $arg1
3609        } else {
3610            set len 0
3611        }
3612    } elseif {$len == 3} {
3613        if {![string compare $arg1 -nonewline] \
3614                && (![string compare $arg2 stdout] \
3615                || ![string compare $arg2 stderr])} {
3616            tkcon console insert output $arg3 $arg2
3617        } elseif {(![string compare $arg1 stdout] \
3618                || ![string compare $arg1 stderr]) \
3619                && ![string compare $arg3 nonewline]} {
3620            tkcon console insert output $arg2 $arg1
3621        } else {
3622            set len 0
3623        }
3624    } else {
3625        set len 0
3626    }
3627
3628    ## $len == 0 means it wasn't handled by tkcon above.
3629    ##
3630    if {$len == 0} {
3631        global errorCode errorInfo
3632        if {[catch "tkcon_tcl_puts $args" msg]} {
3633            regsub tkcon_tcl_puts $msg puts msg
3634            regsub -all tkcon_tcl_puts $errorInfo puts errorInfo
3635            return -code error $msg
3636        }
3637        return $msg
3638    }
3639
3640    ## WARNING: This update should behave well because it uses idletasks,
3641    ## however, if there are weird looping problems with events, or
3642    ## hanging in waits, try commenting this out.
3643    if {$len} {
3644        tkcon console see output
3645        update idletasks
3646    }
3647}
3648
3649## tkcon_gets -
3650## This allows me to capture all stdin input without needing to stdin
3651## This will be renamed to 'gets' at the appropriate time during init
3652##
3653# ARGS:         same as gets   
3654# Outputs:      same as gets
3655##
3656proc tkcon_gets args {
3657    set len [llength $args]
3658    if {$len != 1 && $len != 2} {
3659        return -code error \
3660                "wrong # args: should be \"gets channelId ?varName?\""
3661    }
3662    if {[string compare stdin [lindex $args 0]]} {
3663        return [uplevel 1 tkcon_tcl_gets $args]
3664    }
3665    set gtype [tkcon set ::tkcon::OPT(gets)]
3666    if {$gtype == ""} { set gtype congets }
3667    set data [tkcon $gtype]
3668    if {$len == 2} {
3669        upvar 1 [lindex $args 1] var
3670        set var $data
3671        return [string length $data]
3672    }
3673    return $data
3674}
3675
3676## edit - opens a file/proc/var for reading/editing
3677##
3678# Arguments:
3679#   type        proc/file/var
3680#   what        the actual name of the item
3681# Returns:      nothing
3682##
3683proc edit {args} {
3684    array set opts {-find {} -type {} -attach {}}
3685    while {[string match -* [lindex $args 0]]} {
3686        switch -glob -- [lindex $args 0] {
3687            -f* { set opts(-find) [lindex $args 1] }
3688            -a* { set opts(-attach) [lindex $args 1] }
3689            -t* { set opts(-type) [lindex $args 1] }
3690            --  { set args [lreplace $args 0 0]; break }
3691            default {return -code error "unknown option \"[lindex $args 0]\""}
3692        }
3693        set args [lreplace $args 0 1]
3694    }
3695    # determine who we are dealing with
3696    if {[llength $opts(-attach)]} {
3697        foreach {app type} $opts(-attach) {break}
3698    } else {
3699        foreach {app type} [tkcon attach] {break}
3700    }
3701
3702    set word [lindex $args 0]
3703    if {[string match {} $opts(-type)]} {
3704        if {[llength [::tkcon::EvalOther $app $type info commands [list $word]]]} {
3705            set opts(-type) "proc"
3706        } elseif {[llength [::tkcon::EvalOther $app $type info vars [list $word]]]} {
3707            set opts(-type) "var"
3708        } elseif {[::tkcon::EvalOther $app $type file isfile [list $word]]} {
3709            set opts(-type) "file"
3710        }
3711    }
3712    if {[string compare $opts(-type) {}]} {
3713        # Create unique edit window toplevel
3714        set w $::tkcon::PRIV(base).__edit
3715        set i 0
3716        while {[winfo exists $w[incr i]]} {}
3717        append w $i
3718        toplevel $w
3719        wm withdraw $w
3720        if {[string length $word] > 20} {
3721            wm title $w "[string range $word 0 16]... - tkcon Edit"
3722        } else {
3723            wm title $w "$word - tkcon Edit"
3724        }
3725
3726        if {[package provide ctext] != ""} {
3727            set txt [ctext $w.text]
3728        } else {
3729            set txt [text $w.text]
3730        }
3731        $w.text configure -wrap none \
3732                -xscrollcommand [list $w.sx set] \
3733                -yscrollcommand [list $w.sy set] \
3734                -foreground $::tkcon::COLOR(stdin) \
3735                -background $::tkcon::COLOR(bg) \
3736                -insertbackground $::tkcon::COLOR(cursor) \
3737                -font $::tkcon::OPT(font)
3738        catch {$w.text configure -undo 1}
3739        scrollbar $w.sx -orient h -takefocus 0 -bd 1 \
3740                -command [list $w.text xview]
3741        scrollbar $w.sy -orient v -takefocus 0 -bd 1 \
3742                -command [list $w.text yview]
3743
3744        set menu [menu $w.mbar]
3745        $w configure -menu $menu
3746
3747        ## File Menu
3748        ##
3749        set m [menu [::tkcon::MenuButton $menu File file]]
3750        $m add command -label "Save As..."  -underline 0 \
3751                -command [list ::tkcon::Save {} widget $w.text]
3752        $m add command -label "Append To..."  -underline 0 \
3753                -command [list ::tkcon::Save {} widget $w.text a+]
3754        $m add separator
3755        $m add command -label "Dismiss" -underline 0 -accel "Ctrl-w" \
3756                -command [list destroy $w]
3757        bind $w <Control-w>                     [list destroy $w]
3758        bind $w <$::tkcon::PRIV(meta)-w>        [list destroy $w]
3759
3760        ## Edit Menu
3761        ##
3762        set text $w.text
3763        set m [menu [::tkcon::MenuButton $menu Edit edit]]
3764        $m add command -label "Cut"   -under 2 \
3765                -command [list tk_textCut $text]
3766        $m add command -label "Copy"  -under 0 \
3767                -command [list tk_textCopy $text]
3768        $m add command -label "Paste" -under 0 \
3769                -command [list tk_textPaste $text]
3770        $m add separator
3771        $m add command -label "Find" -under 0 \
3772                -command [list ::tkcon::FindBox $text]
3773
3774        ## Send To Menu
3775        ##
3776        set m [menu [::tkcon::MenuButton $menu "Send To..." send]]
3777        $m add command -label "Send To $app" -underline 0 \
3778                -command "::tkcon::EvalOther [list $app] $type \
3779                eval \[$w.text get 1.0 end-1c\]"
3780        set other [tkcon attach]
3781        if {[string compare $other [list $app $type]]} {
3782            $m add command -label "Send To [lindex $other 0]" \
3783                    -command "::tkcon::EvalOther $other \
3784                    eval \[$w.text get 1.0 end-1c\]"
3785        }
3786
3787        grid $w.text - $w.sy -sticky news
3788        grid $w.sx - -sticky ew
3789        grid columnconfigure $w 0 -weight 1
3790        grid columnconfigure $w 1 -weight 1
3791        grid rowconfigure $w 0 -weight 1
3792    } else {
3793        return -code error "unrecognized type '$word'"
3794    }
3795    switch -glob -- $opts(-type) {
3796        proc*   {
3797            $w.text insert 1.0 \
3798                    [::tkcon::EvalOther $app $type dump proc [list $word]]
3799            after idle [::tkcon::Highlight $w.text tcl]
3800        }
3801        var*    {
3802            $w.text insert 1.0 \
3803                    [::tkcon::EvalOther $app $type dump var [list $word]]
3804            after idle [::tkcon::Highlight $w.text tcl]
3805        }
3806        file    {
3807            $w.text insert 1.0 [::tkcon::EvalOther $app $type eval \
3808                    [subst -nocommands {
3809                set __tkcon(fid) [open $word r]
3810                set __tkcon(data) [read \$__tkcon(fid)]
3811                close \$__tkcon(fid)
3812                after 1000 unset __tkcon
3813                return \$__tkcon(data)
3814            }
3815            ]]
3816            after idle [::tkcon::Highlight $w.text \
3817                            [string trimleft [file extension $word] .]]
3818        }
3819        error*  {
3820            $w.text insert 1.0 [join $args \n]
3821            after idle [::tkcon::Highlight $w.text error]
3822        }
3823        default {
3824            $w.text insert 1.0 [join $args \n]
3825        }
3826    }
3827    wm deiconify $w
3828    focus $w.text
3829    if {[string compare $opts(-find) {}]} {
3830        ::tkcon::Find $w.text $opts(-find) -case 1
3831    }
3832}
3833interp alias {} ::more {} ::edit
3834interp alias {} ::less {} ::edit
3835
3836## echo
3837## Relaxes the one string restriction of 'puts'
3838# ARGS: any number of strings to output to stdout
3839##
3840proc echo args { puts stdout [concat $args] }
3841
3842## clear - clears the buffer of the console (not the history though)
3843## This is executed in the parent interpreter
3844##
3845proc clear {{pcnt 100}} {
3846    if {![regexp {^[0-9]*$} $pcnt] || $pcnt < 1 || $pcnt > 100} {
3847        return -code error \
3848                "invalid percentage to clear: must be 1-100 (100 default)"
3849    } elseif {$pcnt == 100} {
3850        tkcon console delete 1.0 end
3851    } else {
3852        set tmp [expr {$pcnt/100.0*[tkcon console index end]}]
3853        tkcon console delete 1.0 "$tmp linestart"
3854    }
3855}
3856
3857## alias - akin to the csh alias command
3858## If called with no args, then it dumps out all current aliases
3859## If called with one arg, returns the alias of that arg (or {} if none)
3860# ARGS: newcmd  - (optional) command to bind alias to
3861#       args    - command and args being aliased
3862##
3863proc alias {{newcmd {}} args} {
3864    if {[string match {} $newcmd]} {
3865        set res {}
3866        foreach a [interp aliases] {
3867            lappend res [list $a -> [interp alias {} $a]]
3868        }
3869        return [join $res \n]
3870    } elseif {![llength $args]} {
3871        interp alias {} $newcmd
3872    } else {
3873        eval interp alias [list {} $newcmd {}] $args
3874    }
3875}
3876
3877## unalias - unaliases an alias'ed command
3878# ARGS: cmd     - command to unbind as an alias
3879##
3880proc unalias {cmd} {
3881    interp alias {} $cmd {}
3882}
3883
3884## dump - outputs variables/procedure/widget info in source'able form.
3885## Accepts glob style pattern matching for the names
3886#
3887# ARGS: type    - type of thing to dump: must be variable, procedure, widget
3888#
3889# OPTS: -nocomplain
3890#               don't complain if no items of the specified type are found
3891#       -filter pattern
3892#               specifies a glob filter pattern to be used by the variable
3893#               method as an array filter pattern (it filters down for
3894#               nested elements) and in the widget method as a config
3895#               option filter pattern
3896#       --      forcibly ends options recognition
3897#
3898# Returns:      the values of the requested items in a 'source'able form
3899##
3900proc dump {type args} {
3901    set whine 1
3902    set code  ok
3903    if {![llength $args]} {
3904        ## If no args, assume they gave us something to dump and
3905        ## we'll try anything
3906        set args $type
3907        set type any
3908    }
3909    while {[string match -* [lindex $args 0]]} {
3910        switch -glob -- [lindex $args 0] {
3911            -n* { set whine 0; set args [lreplace $args 0 0] }
3912            -f* { set fltr [lindex $args 1]; set args [lreplace $args 0 1] }
3913            --  { set args [lreplace $args 0 0]; break }
3914            default {return -code error "unknown option \"[lindex $args 0]\""}
3915        }
3916    }
3917    if {$whine && ![llength $args]} {
3918        return -code error "wrong \# args: [lindex [info level 0] 0] type\
3919                ?-nocomplain? ?-filter pattern? ?--? pattern ?pattern ...?"
3920    }
3921    set res {}
3922    switch -glob -- $type {
3923        c* {
3924            # command
3925            # outputs commands by figuring out, as well as possible, what it is
3926            # this does not attempt to auto-load anything
3927            foreach arg $args {
3928                if {[llength [set cmds [info commands $arg]]]} {
3929                    foreach cmd [lsort $cmds] {
3930                        if {[lsearch -exact [interp aliases] $cmd] > -1} {
3931                            append res "\#\# ALIAS:   $cmd =>\
3932                                    [interp alias {} $cmd]\n"
3933                        } elseif {
3934                            [llength [info procs $cmd]] ||
3935                            ([string match *::* $cmd] &&
3936                            [llength [namespace eval [namespace qual $cmd] \
3937                                    info procs [namespace tail $cmd]]])
3938                        } {
3939                            if {[catch {dump p -- $cmd} msg] && $whine} {
3940                                set code error
3941                            }
3942                            append res $msg\n
3943                        } else {
3944                            append res "\#\# COMMAND: $cmd\n"
3945                        }
3946                    }
3947                } elseif {$whine} {
3948                    append res "\#\# No known command $arg\n"
3949                    set code error
3950                }
3951            }
3952        }
3953        v* {
3954            # variable
3955            # outputs variables value(s), whether array or simple.
3956            if {![info exists fltr]} { set fltr * }
3957            foreach arg $args {
3958                if {![llength [set vars [uplevel 1 info vars [list $arg]]]]} {
3959                    if {[uplevel 1 info exists $arg]} {
3960                        set vars $arg
3961                    } elseif {$whine} {
3962                        append res "\#\# No known variable $arg\n"
3963                        set code error
3964                        continue
3965                    } else { continue }
3966                }
3967                foreach var [lsort $vars] {
3968                    if {[uplevel 1 [list info locals $var]] == ""} {
3969                        # use the proper scope of the var, but namespace which
3970                        # won't id locals or some upvar'ed vars correctly
3971                        set new [uplevel 1 \
3972                                [list namespace which -variable $var]]
3973                        if {$new != ""} {
3974                            set var $new
3975                        }
3976                    }
3977                    upvar 1 $var v
3978                    if {[array exists v] || [catch {string length $v}]} {
3979                        set nst {}
3980                        append res "array set [list $var] \{\n"
3981                        if {[array size v]} {
3982                            foreach i \
3983                                    [lsort -dictionary [array names v $fltr]] {
3984                                upvar 0 v\($i\) __a
3985                                if {[array exists __a]} {
3986                                    append nst "\#\# NESTED ARRAY ELEM: $i\n"
3987                                    append nst "upvar 0 [list $var\($i\)] __a;\
3988                                            [dump v -filter $fltr __a]\n"
3989                                } else {
3990                                    append res "    [list $i]\t[list $v($i)]\n"
3991                                }
3992                            }
3993                        } else {
3994                            ## empty array
3995                            append res "    empty array\n"
3996                            if {$var == ""} {
3997                                append nst "unset (empty)\n"
3998                            } else {
3999                                append nst "unset [list $var](empty)\n"
4000                            }
4001                        }
4002                        append res "\}\n$nst"
4003                    } else {
4004                        append res [list set $var $v]\n
4005                    }
4006                }
4007            }
4008        }
4009        p* {
4010            # procedure
4011            foreach arg $args {
4012                if {
4013                    ![llength [set procs [info proc $arg]]] &&
4014                    ([string match *::* $arg] &&
4015                    [llength [set ps [namespace eval \
4016                            [namespace qualifier $arg] \
4017                            info procs [namespace tail $arg]]]])
4018                } {
4019                    set procs {}
4020                    set namesp [namespace qualifier $arg]
4021                    foreach p $ps {
4022                        lappend procs ${namesp}::$p
4023                    }
4024                }
4025                if {[llength $procs]} {
4026                    foreach p [lsort $procs] {
4027                        set as {}
4028                        foreach a [info args $p] {
4029                            if {[info default $p $a tmp]} {
4030                                lappend as [list $a $tmp]
4031                            } else {
4032                                lappend as $a
4033                            }
4034                        }
4035                        append res [list proc $p $as [info body $p]]\n
4036                    }
4037                } elseif {$whine} {
4038                    append res "\#\# No known proc $arg\n"
4039                    set code error
4040                }
4041            }
4042        }
4043        w* {
4044            # widget
4045            ## The user should have Tk loaded
4046            if {![llength [info command winfo]]} {
4047                return -code error "winfo not present, cannot dump widgets"
4048            }
4049            if {![info exists fltr]} { set fltr .* }
4050            foreach arg $args {
4051                if {[llength [set ws [info command $arg]]]} {
4052                    foreach w [lsort $ws] {
4053                        if {[winfo exists $w]} {
4054                            if {[catch {$w configure} cfg]} {
4055                                append res "\#\# Widget $w\
4056                                        does not support configure method"
4057                                set code error
4058                            } else {
4059                                append res "\#\# [winfo class $w]\
4060                                        $w\n$w configure"
4061                                foreach c $cfg {
4062                                    if {[llength $c] != 5} continue
4063                                    ## Check to see that the option does
4064                                    ## not match the default, then check
4065                                    ## the item against the user filter
4066                                    if {[string compare [lindex $c 3] \
4067                                            [lindex $c 4]] && \
4068                                            [regexp -nocase -- $fltr $c]} {
4069                                        append res " \\\n\t[list [lindex $c 0]\
4070                                                [lindex $c 4]]"
4071                                    }
4072                                }
4073                                append res \n
4074                            }
4075                        }
4076                    }
4077                } elseif {$whine} {
4078                    append res "\#\# No known widget $arg\n"
4079                    set code error
4080                }
4081            }
4082        }
4083        a* {
4084            ## see if we recognize it, other complain
4085            if {[regexp {(var|com|proc|widget)} \
4086                    [set types [uplevel 1 what $args]]]} {
4087                foreach type $types {
4088                    if {[regexp {(var|com|proc|widget)} $type]} {
4089                        append res "[uplevel 1 dump $type $args]\n"
4090                    }
4091                }
4092            } else {
4093                set res "dump was unable to resolve type for \"$args\""
4094                set code error
4095            }
4096        }
4097        default {
4098            return -code error "bad [lindex [info level 0] 0] option\
4099                    \"$type\": must be variable, command, procedure,\
4100                    or widget"
4101        }
4102    }
4103    return -code $code [string trimright $res \n]
4104}
4105
4106## idebug - interactive debugger
4107#
4108# idebug body ?level?
4109#
4110#       Prints out the body of the command (if it is a procedure) at the
4111#       specified level.  <i>level</i> defaults to the current level.
4112#
4113# idebug break
4114#
4115#       Creates a breakpoint within a procedure.  This will only trigger
4116#       if idebug is on and the id matches the pattern.  If so, TkCon will
4117#       pop to the front with the prompt changed to an idebug prompt.  You
4118#       are given the basic ability to observe the call stack an query/set
4119#       variables or execute Tcl commands at any level.  A separate history
4120#       is maintained in debugging mode.
4121#
4122# idebug echo|{echo ?id?} ?args?
4123#
4124#       Behaves just like "echo", but only triggers when idebug is on.
4125#       You can specify an optional id to further restrict triggering.
4126#       If no id is specified, it defaults to the name of the command
4127#       in which the call was made.
4128#
4129# idebug id ?id?
4130#
4131#       Query or set the idebug id.  This id is used by other idebug
4132#       methods to determine if they should trigger or not.  The idebug
4133#       id can be a glob pattern and defaults to *.
4134#
4135# idebug off
4136#
4137#       Turns idebug off.
4138#
4139# idebug on ?id?
4140#
4141#       Turns idebug on.  If 'id' is specified, it sets the id to it.
4142#
4143# idebug puts|{puts ?id?} args
4144#
4145#       Behaves just like "puts", but only triggers when idebug is on.
4146#       You can specify an optional id to further restrict triggering.
4147#       If no id is specified, it defaults to the name of the command
4148#       in which the call was made.
4149#
4150# idebug show type ?level? ?VERBOSE?
4151#
4152#       'type' must be one of vars, locals or globals.  This method
4153#       will output the variables/locals/globals present in a particular
4154#       level.  If VERBOSE is added, then it actually 'dump's out the
4155#       values as well.  'level' defaults to the level in which this
4156#       method was called.
4157#
4158# idebug trace ?level?
4159#
4160#       Prints out the stack trace from the specified level up to the top
4161#       level.  'level' defaults to the current level.
4162#
4163##
4164proc idebug {opt args} {
4165    global IDEBUG
4166
4167    if {![info exists IDEBUG(on)]} {
4168        array set IDEBUG { on 0 id * debugging 0 }
4169    }
4170    set level [expr {[info level]-1}]
4171    switch -glob -- $opt {
4172        on      {
4173            if {[llength $args]} { set IDEBUG(id) $args }
4174            return [set IDEBUG(on) 1]
4175        }
4176        off     { return [set IDEBUG(on) 0] }
4177        id  {
4178            if {![llength $args]} {
4179                return $IDEBUG(id)
4180            } else { return [set IDEBUG(id) $args] }
4181        }
4182        break {
4183            if {!$IDEBUG(on) || $IDEBUG(debugging) || \
4184                    ([llength $args] && \
4185                    ![string match $IDEBUG(id) $args]) || [info level]<1} {
4186                return
4187            }
4188            set IDEBUG(debugging) 1
4189            puts stderr "idebug at level \#$level: [lindex [info level -1] 0]"
4190            set tkcon [llength [info command tkcon]]
4191            if {$tkcon} {
4192                tkcon master eval set ::tkcon::OPT(prompt2) \$::tkcon::OPT(prompt1)
4193                tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(debugPrompt)
4194                set slave [tkcon set ::tkcon::OPT(exec)]
4195                set event [tkcon set ::tkcon::PRIV(event)]
4196                tkcon set ::tkcon::OPT(exec) [tkcon master interp create debugger]
4197                tkcon set ::tkcon::PRIV(event) 1
4198            }
4199            set max $level
4200            while 1 {
4201                set err {}
4202                if {$tkcon} {
4203                    # tkcon's overload of gets is advanced enough to not need
4204                    # this, but we get a little better control this way.
4205                    tkcon evalSlave set level $level
4206                    tkcon prompt
4207                    set line [tkcon getcommand]
4208                    tkcon console mark set output end
4209                } else {
4210                    puts -nonewline stderr "(level \#$level) debug > "
4211                    gets stdin line
4212                    while {![info complete $line]} {
4213                        puts -nonewline "> "
4214                        append line "\n[gets stdin]"
4215                    }
4216                }
4217                if {[string match {} $line]} continue
4218                set key [lindex $line 0]
4219                if {![regexp {^([#-]?[0-9]+)} [lreplace $line 0 0] lvl]} {
4220                    set lvl \#$level
4221                }
4222                set res {}; set c 0
4223                switch -- $key {
4224                    + {
4225                        ## Allow for jumping multiple levels
4226                        if {$level < $max} {
4227                            idebug trace [incr level] $level 0 VERBOSE
4228                        }
4229                    }
4230                    - {
4231                        ## Allow for jumping multiple levels
4232                        if {$level > 1} {
4233                            idebug trace [incr level -1] $level 0 VERBOSE
4234                        }
4235                    }
4236                    . { set c [catch {idebug trace $level $level 0 VERBOSE} res] }
4237                    v { set c [catch {idebug show vars $lvl } res] }
4238                    V { set c [catch {idebug show vars $lvl VERBOSE} res] }
4239                    l { set c [catch {idebug show locals $lvl } res] }
4240                    L { set c [catch {idebug show locals $lvl VERBOSE} res] }
4241                    g { set c [catch {idebug show globals $lvl } res] }
4242                    G { set c [catch {idebug show globals $lvl VERBOSE} res] }
4243                    t { set c [catch {idebug trace 1 $max $level } res] }
4244                    T { set c [catch {idebug trace 1 $max $level VERBOSE} res]}
4245                    b { set c [catch {idebug body $lvl} res] }
4246                    o { set res [set IDEBUG(on) [expr {!$IDEBUG(on)}]] }
4247                    h - ?       {
4248                        puts stderr "    +              Move down in call stack
4249    -           Move up in call stack
4250    .           Show current proc name and params
4251
4252    v           Show names of variables currently in scope
4253    V           Show names of variables currently in scope with values
4254    l           Show names of local (transient) variables
4255    L           Show names of local (transient) variables with values
4256    g           Show names of declared global variables
4257    G           Show names of declared global variables with values
4258    t           Show a stack trace
4259    T           Show a verbose stack trace
4260
4261    b           Show body of current proc
4262    o           Toggle on/off any further debugging
4263    c,q         Continue regular execution (Quit debugger)
4264    h,?         Print this help
4265    default     Evaluate line at current level (\#$level)"
4266                    }
4267                    c - q break
4268                    default { set c [catch {uplevel \#$level $line} res] }
4269                }
4270                if {$tkcon} {
4271                    tkcon set ::tkcon::PRIV(event) \
4272                            [tkcon evalSlave eval history add [list $line]\
4273                            \; history nextid]
4274                }
4275                if {$c} {
4276                    puts stderr $res
4277                } elseif {[string compare {} $res]} {
4278                    puts $res
4279                }
4280            }
4281            set IDEBUG(debugging) 0
4282            if {$tkcon} {
4283                tkcon master interp delete debugger
4284                tkcon master eval set ::tkcon::OPT(prompt1) \$::tkcon::OPT(prompt2)
4285                tkcon set ::tkcon::OPT(exec) $slave
4286                tkcon set ::tkcon::PRIV(event) $event
4287                tkcon prompt
4288            }
4289        }
4290        bo* {
4291            if {[regexp {^([#-]?[0-9]+)} $args level]} {
4292                return [uplevel $level {dump c -no [lindex [info level 0] 0]}]
4293            }
4294        }
4295        t* {
4296            if {[llength $args]<2} return
4297            set min [set max [set lvl $level]]
4298            set exp {^#?([0-9]+)? ?#?([0-9]+) ?#?([0-9]+)? ?(VERBOSE)?}
4299            if {![regexp $exp $args junk min max lvl verbose]} return
4300            for {set i $max} {
4301                $i>=$min && ![catch {uplevel \#$i info level 0} info]
4302            } {incr i -1} {
4303                if {$i==$lvl} {
4304                    puts -nonewline stderr "* \#$i:\t"
4305                } else {
4306                    puts -nonewline stderr "  \#$i:\t"
4307                }
4308                set name [lindex $info 0]
4309                if {[string compare VERBOSE $verbose] || \
4310                        ![llength [info procs $name]]} {
4311                    puts $info
4312                } else {
4313                    puts "proc $name {[info args $name]} { ... }"
4314                    set idx 0
4315                    foreach arg [info args $name] {
4316                        if {[string match args $arg]} {
4317                            puts "\t$arg = [lrange $info [incr idx] end]"
4318                            break
4319                        } else {
4320                            puts "\t$arg = [lindex $info [incr idx]]"
4321                        }
4322                    }
4323                }
4324            }
4325        }
4326        s* {
4327            #var, local, global
4328            set level \#$level
4329            if {![regexp {^([vgl][^ ]*) ?([#-]?[0-9]+)? ?(VERBOSE)?} \
4330                    $args junk type level verbose]} return
4331            switch -glob -- $type {
4332                v* { set vars [uplevel $level {lsort [info vars]}] }
4333                l* { set vars [uplevel $level {lsort [info locals]}] }
4334                g* { set vars [lremove [uplevel $level {info vars}] \
4335                        [uplevel $level {info locals}]] }
4336            }
4337            if {[string match VERBOSE $verbose]} {
4338                return [uplevel $level dump var -nocomplain $vars]
4339            } else {
4340                return $vars
4341            }
4342        }
4343        e* - pu* {
4344            if {[llength $opt]==1 && [catch {lindex [info level -1] 0} id]} {
4345                set id [lindex [info level 0] 0]
4346            } else {
4347                set id [lindex $opt 1]
4348            }
4349            if {$IDEBUG(on) && [string match $IDEBUG(id) $id]} {
4350                if {[string match e* $opt]} {
4351                    puts [concat $args]
4352                } else { eval puts $args }
4353            }
4354        }
4355        default {
4356            return -code error "bad [lindex [info level 0] 0] option \"$opt\",\
4357                    must be: [join [lsort [list on off id break print body\
4358                    trace show puts echo]] {, }]"
4359        }
4360    }
4361}
4362
4363## observe - like trace, but not
4364# ARGS: opt     - option
4365#       name    - name of variable or command
4366##
4367proc observe {opt name args} {
4368    global tcl_observe
4369    switch -glob -- $opt {
4370        co* {
4371            if {[regexp {^(catch|lreplace|set|puts|for|incr|info|uplevel)$} \
4372                    $name]} {
4373                return -code error "cannot observe \"$name\":\
4374                        infinite eval loop will occur"
4375            }
4376            set old ${name}@
4377            while {[llength [info command $old]]} { append old @ }
4378            rename $name $old
4379            set max 4
4380            regexp {^[0-9]+} $args max
4381            # handle the observe'ing of 'proc'
4382            set proccmd "proc"
4383            if {[string match "proc" $name]} { set proccmd $old }
4384            ## idebug trace could be used here
4385            $proccmd $name args "
4386            for {set i \[info level\]; set max \[expr \[info level\]-$max\]} {
4387                \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\]
4388            } {incr i -1} {
4389                puts -nonewline stderr \"  \#\$i:\t\"
4390                puts \$info
4391            }
4392            uplevel \[lreplace \[info level 0\] 0 0 $old\]
4393            "
4394            set tcl_observe($name) $old
4395        }
4396        cd* {
4397            if {[info exists tcl_observe($name)] && [catch {
4398                rename $name {}
4399                rename $tcl_observe($name) $name
4400                unset tcl_observe($name)
4401            } err]} { return -code error $err }
4402        }
4403        ci* {
4404            ## What a useless method...
4405            if {[info exists tcl_observe($name)]} {
4406                set i $tcl_observe($name)
4407                set res "\"$name\" observes true command \"$i\""
4408                while {[info exists tcl_observe($i)]} {
4409                    append res "\n\"$name\" observes true command \"$i\""
4410                    set i $tcl_observe($name)
4411                }
4412                return $res
4413            }
4414        }
4415        va* - vd* {
4416            set type [lindex $args 0]
4417            set args [lrange $args 1 end]
4418            if {![regexp {^[rwu]} $type type]} {
4419                return -code error "bad [lindex [info level 0] 0] $opt type\
4420                        \"$type\", must be: read, write or unset"
4421            }
4422            if {![llength $args]} { set args observe_var }
4423            foreach c [uplevel 1 [list trace vinfo $name]] {
4424                # don't double up on the traces
4425                if {[list $type $args] == $c} { return }
4426            }
4427            uplevel 1 [list trace $opt $name $type $args]
4428        }
4429        vi* {
4430            uplevel 1 [list trace vinfo $name]
4431        }
4432        default {
4433            return -code error "bad [lindex [info level 0] 0] option\
4434                    \"[lindex $args 0]\", must be: [join [lsort \
4435                    [list command cdelete cinfo variable vdelete vinfo]] {, }]"
4436        }
4437    }
4438}
4439
4440## observe_var - auxilary function for observing vars, called by trace
4441## via observe
4442# ARGS: name    - variable name
4443#       el      - array element name, if any
4444#       op      - operation type (rwu)
4445##
4446proc observe_var {name el op} {
4447    if {[string match u $op]} {
4448        if {[string compare {} $el]} {
4449            puts "unset \"${name}($el)\""
4450        } else {
4451            puts "unset \"$name\""
4452        }
4453    } else {
4454        upvar 1 $name $name
4455        if {[info exists ${name}($el)]} {
4456            puts [dump v ${name}($el)]
4457        } else {
4458            puts [dump v $name]
4459        }
4460    }
4461}
4462
4463## which - tells you where a command is found
4464# ARGS: cmd     - command name
4465# Returns:      where command is found (internal / external / unknown)
4466##
4467proc which cmd {
4468    ## This tries to auto-load a command if not recognized
4469    set types [uplevel 1 [list what $cmd 1]]
4470    if {[llength $types]} {
4471        set out {}
4472       
4473        foreach type $types {
4474            switch -- $type {
4475                alias           { set res "$cmd: aliased to [alias $cmd]" }
4476                procedure       { set res "$cmd: procedure" }
4477                command         { set res "$cmd: internal command" }
4478                executable      { lappend out [auto_execok $cmd] }
4479                variable        { lappend out "$cmd: $type" }
4480            }
4481            if {[info exists res]} {
4482                global auto_index
4483                if {[info exists auto_index($cmd)]} {
4484                    ## This tells you where the command MIGHT have come from -
4485                    ## not true if the command was redefined interactively or
4486                    ## existed before it had to be auto_loaded.  This is just
4487                    ## provided as a hint at where it MAY have come from
4488                    append res " ($auto_index($cmd))"
4489                }
4490                lappend out $res
4491                unset res
4492            }
4493        }
4494        return [join $out \n]
4495    } else {
4496        return -code error "$cmd: command not found"
4497    }
4498}
4499
4500## what - tells you what a string is recognized as
4501# ARGS: str     - string to id
4502# Returns:      id types of command as list
4503##
4504proc what {str {autoload 0}} {
4505    set types {}
4506    if {[llength [info commands $str]] || ($autoload && \
4507            [auto_load $str] && [llength [info commands $str]])} {
4508        if {[lsearch -exact [interp aliases] $str] > -1} {
4509            lappend types "alias"
4510        } elseif {
4511            [llength [info procs $str]] ||
4512            ([string match *::* $str] &&
4513            [llength [namespace eval [namespace qualifier $str] \
4514                    info procs [namespace tail $str]]])
4515        } {
4516            lappend types "procedure"
4517        } else {
4518            lappend types "command"
4519        }
4520    }
4521    if {[llength [uplevel 1 info vars $str]]} {
4522        upvar 1 $str var
4523        if {[array exists var]} {
4524            lappend types array variable
4525        } else {
4526            lappend types scalar variable
4527        }
4528    }
4529    if {[file isdirectory $str]} {
4530        lappend types "directory"
4531    }
4532    if {[file isfile $str]} {
4533        lappend types "file"
4534    }
4535    if {[llength [info commands winfo]] && [winfo exists $str]} {
4536        lappend types "widget"
4537    }
4538    if {[string compare {} [auto_execok $str]]} {
4539        lappend types "executable"
4540    }
4541    return $types
4542}
4543
4544## dir - directory list
4545# ARGS: args    - names/glob patterns of directories to list
4546# OPTS: -all    - list hidden files as well (Unix dot files)
4547#       -long   - list in full format "permissions size date filename"
4548#       -full   - displays / after directories and link paths for links
4549# Returns:      a directory listing
4550##
4551proc dir {args} {
4552    array set s {
4553        all 0 full 0 long 0
4554        0 --- 1 --x 2 -w- 3 -wx 4 r-- 5 r-x 6 rw- 7 rwx
4555    }
4556    while {[string match \-* [lindex $args 0]]} {
4557        set str [lindex $args 0]
4558        set args [lreplace $args 0 0]
4559        switch -glob -- $str {
4560            -a* {set s(all) 1} -f* {set s(full) 1}
4561            -l* {set s(long) 1} -- break
4562            default {
4563                return -code error "unknown option \"$str\",\
4564                        should be one of: -all, -full, -long"
4565            }
4566        }
4567    }
4568    set sep [string trim [file join . .] .]
4569    if {![llength $args]} { set args [list [pwd]] }
4570    if {$::tcl_version >= 8.3} {
4571        # Newer glob args allow safer dir processing.  The user may still
4572        # want glob chars, but really only for file matching.
4573        foreach arg $args {
4574            if {[file isdirectory $arg]} {
4575                if {$s(all)} {
4576                    lappend out [list $arg [lsort \
4577                            [glob -nocomplain -directory $arg .* *]]]
4578                } else {
4579                    lappend out [list $arg [lsort \
4580                            [glob -nocomplain -directory $arg *]]]
4581                }
4582            } else {
4583                set dir [file dirname $arg]
4584                lappend out [list $dir$sep [lsort \
4585                        [glob -nocomplain -directory $dir [file tail $arg]]]]
4586            }
4587        }
4588    } else {
4589        foreach arg $args {
4590            if {[file isdirectory $arg]} {
4591                set arg [string trimright $arg $sep]$sep
4592                if {$s(all)} {
4593                    lappend out [list $arg [lsort [glob -nocomplain -- $arg.* $arg*]]]
4594                } else {
4595                    lappend out [list $arg [lsort [glob -nocomplain -- $arg*]]]
4596                }
4597            } else {
4598                lappend out [list [file dirname $arg]$sep \
4599                        [lsort [glob -nocomplain -- $arg]]]
4600            }
4601        }
4602    }
4603    if {$s(long)} {
4604        set old [clock scan {1 year ago}]
4605        set fmt "%s%9ld %s %s\n"
4606        foreach o $out {
4607            set d [lindex $o 0]
4608            append res $d:\n
4609            foreach f [lindex $o 1] {
4610                file lstat $f st
4611                set f [file tail $f]
4612                if {$s(full)} {
4613                    switch -glob $st(type) {
4614                        d* { append f $sep }
4615                        l* { append f "@ -> [file readlink $d$sep$f]" }
4616                        default { if {[file exec $d$sep$f]} { append f * } }
4617                    }
4618                }
4619                if {[string match file $st(type)]} {
4620                    set mode -
4621                } else {
4622                    set mode [string index $st(type) 0]
4623                }
4624                foreach j [split [format %03o [expr {$st(mode)&0777}]] {}] {
4625                    append mode $s($j)
4626                }
4627                if {$st(mtime)>$old} {
4628                    set cfmt {%b %d %H:%M}
4629                } else {
4630                    set cfmt {%b %%Y}
4631                }
4632                append res [format $fmt $mode $st(size) \
4633                        [clock format $st(mtime) -format $cfmt] $f]
4634            }
4635            append res \n
4636        }
4637    } else {
4638        foreach o $out {
4639            set d [lindex $o 0]
4640            append res "$d:\n"
4641            set i 0
4642            foreach f [lindex $o 1] {
4643                if {[string len [file tail $f]] > $i} {
4644                    set i [string len [file tail $f]]
4645                }
4646            }
4647            set i [expr {$i+2+$s(full)}]
4648            set j 80
4649            ## This gets the number of cols in the tkcon console widget
4650            if {[llength [info commands tkcon]]} {
4651                set j [expr {[tkcon master set ::tkcon::OPT(cols)]/$i}]
4652            }
4653            set k 0
4654            foreach f [lindex $o 1] {
4655                set f [file tail $f]
4656                if {$s(full)} {
4657                    switch -glob [file type $d$sep$f] {
4658                        d* { append f $sep }
4659                        l* { append f @ }
4660                        default { if {[file exec $d$sep$f]} { append f * } }
4661                    }
4662                }
4663                append res [format "%-${i}s" $f]
4664                if {$j == 0 || [incr k]%$j == 0} {
4665                    set res [string trimright $res]\n
4666                }
4667            }
4668            append res \n\n
4669        }
4670    }
4671    return [string trimright $res]
4672}
4673interp alias {} ::ls {} ::dir -full
4674
4675## lremove - remove items from a list
4676# OPTS:
4677#   -all        remove all instances of each item
4678#   -glob       remove all instances matching glob pattern
4679#   -regexp     remove all instances matching regexp pattern
4680# ARGS: l       a list to remove items from
4681#       args    items to remove (these are 'join'ed together)
4682##
4683proc lremove {args} {
4684    array set opts {-all 0 pattern -exact}
4685    while {[string match -* [lindex $args 0]]} {
4686        switch -glob -- [lindex $args 0] {
4687            -a* { set opts(-all) 1 }
4688            -g* { set opts(pattern) -glob }
4689            -r* { set opts(pattern) -regexp }
4690            --  { set args [lreplace $args 0 0]; break }
4691            default {return -code error "unknown option \"[lindex $args 0]\""}
4692        }
4693        set args [lreplace $args 0 0]
4694    }
4695    set l [lindex $args 0]
4696    foreach i [join [lreplace $args 0 0]] {
4697        if {[set ix [lsearch $opts(pattern) $l $i]] == -1} continue
4698        set l [lreplace $l $ix $ix]
4699        if {$opts(-all)} {
4700            while {[set ix [lsearch $opts(pattern) $l $i]] != -1} {
4701                set l [lreplace $l $ix $ix]
4702            }
4703        }
4704    }
4705    return $l
4706}
4707
4708if {!$::tkcon::PRIV(WWW)} {;
4709
4710## Unknown changed to get output into tkcon window
4711# unknown:
4712# Invoked automatically whenever an unknown command is encountered.
4713# Works through a list of "unknown handlers" that have been registered
4714# to deal with unknown commands.  Extensions can integrate their own
4715# handlers into the 'unknown' facility via 'unknown_handler'.
4716#
4717# If a handler exists that recognizes the command, then it will
4718# take care of the command action and return a valid result or a
4719# Tcl error.  Otherwise, it should return "-code continue" (=2)
4720# and responsibility for the command is passed to the next handler.
4721#
4722# Arguments:
4723# args -        A list whose elements are the words of the original
4724#               command, including the command name.
4725
4726proc unknown args {
4727    global unknown_handler_order unknown_handlers errorInfo errorCode
4728
4729    #
4730    # Be careful to save error info now, and restore it later
4731    # for each handler.  Some handlers generate their own errors
4732    # and disrupt handling.
4733    #
4734    set savedErrorCode $errorCode
4735    set savedErrorInfo $errorInfo
4736
4737    if {![info exists unknown_handler_order] || \
4738            ![info exists unknown_handlers]} {
4739        set unknown_handlers(tcl) tcl_unknown
4740        set unknown_handler_order tcl
4741    }
4742
4743    foreach handler $unknown_handler_order {
4744        set status [catch {uplevel 1 $unknown_handlers($handler) $args} result]
4745
4746        if {$status == 1} {
4747            #
4748            # Strip the last five lines off the error stack (they're
4749            # from the "uplevel" command).
4750            #
4751            set new [split $errorInfo \n]
4752            set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n]
4753            return -code $status -errorcode $errorCode \
4754                -errorinfo $new $result
4755
4756        } elseif {$status != 4} {
4757            return -code $status $result
4758        }
4759
4760        set errorCode $savedErrorCode
4761        set errorInfo $savedErrorInfo
4762    }
4763
4764    set name [lindex $args 0]
4765    return -code error "invalid command name \"$name\""
4766}
4767
4768# tcl_unknown:
4769# Invoked when a Tcl command is invoked that doesn't exist in the
4770# interpreter:
4771#
4772#       1. See if the autoload facility can locate the command in a
4773#          Tcl script file.  If so, load it and execute it.
4774#       2. If the command was invoked interactively at top-level:
4775#           (a) see if the command exists as an executable UNIX program.
4776#               If so, "exec" the command.
4777#           (b) see if the command requests csh-like history substitution
4778#               in one of the common forms !!, !<number>, or ^old^new.  If
4779#               so, emulate csh's history substitution.
4780#           (c) see if the command is a unique abbreviation for another
4781#               command.  If so, invoke the command.
4782#
4783# Arguments:
4784# args -        A list whose elements are the words of the original
4785#               command, including the command name.
4786
4787proc tcl_unknown args {
4788    global auto_noexec auto_noload env unknown_pending tcl_interactive
4789    global errorCode errorInfo
4790
4791    # If the command word has the form "namespace inscope ns cmd"
4792    # then concatenate its arguments onto the end and evaluate it.
4793
4794    set cmd [lindex $args 0]
4795    if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] \
4796            && [llength $cmd] == 4} {
4797        set arglist [lrange $args 1 end]
4798        set ret [catch {uplevel 1 $cmd $arglist} result]
4799        if {$ret == 0} {
4800            return $result
4801        } else {
4802            return -code $ret -errorcode $errorCode $result
4803        }
4804    }
4805
4806    # Save the values of errorCode and errorInfo variables, since they
4807    # may get modified if caught errors occur below.  The variables will
4808    # be restored just before re-executing the missing command.
4809
4810    set savedErrorCode $errorCode
4811    set savedErrorInfo $errorInfo
4812    set name [lindex $args 0]
4813    if {![info exists auto_noload]} {
4814        #
4815        # Make sure we're not trying to load the same proc twice.
4816        #
4817        if {[info exists unknown_pending($name)]} {
4818            return -code error "self-referential recursion in \"unknown\" for command \"$name\""
4819        }
4820        set unknown_pending($name) pending
4821        if {[llength [info args auto_load]]==1} {
4822            set ret [catch {auto_load $name} msg]
4823        } else {
4824            set ret [catch {auto_load $name [uplevel 1 {namespace current}]} msg]
4825        }
4826        unset unknown_pending($name)
4827        if {$ret} {
4828            return -code $ret -errorcode $errorCode \
4829                    "error while autoloading \"$name\": $msg"
4830        }
4831        if {![array size unknown_pending]} { unset unknown_pending }
4832        if {$msg} {
4833            set errorCode $savedErrorCode
4834            set errorInfo $savedErrorInfo
4835            set code [catch {uplevel 1 $args} msg]
4836            if {$code ==  1} {
4837                #
4838                # Strip the last five lines off the error stack (they're
4839                # from the "uplevel" command).
4840                #
4841
4842                set new [split $errorInfo \n]
4843                set new [join [lrange $new 0 [expr {[llength $new]-6}]] \n]
4844                return -code error -errorcode $errorCode \
4845                        -errorinfo $new $msg
4846            } else {
4847                return -code $code $msg
4848            }
4849        }
4850    }
4851    if {[info level] == 1 && [string match {} [info script]] \
4852            && [info exists tcl_interactive] && $tcl_interactive} {
4853        if {![info exists auto_noexec]} {
4854            set new [auto_execok $name]
4855            if {[string compare {} $new]} {
4856                set errorCode $savedErrorCode
4857                set errorInfo $savedErrorInfo
4858                if {[info exists ::tkcon::EXPECT] && $::tkcon::EXPECT && [package provide Expect] != ""} {
4859                    return [tkcon expect [concat $new [lrange $args 1 end]]]
4860                } else {
4861                    return [uplevel 1 exec $new [lrange $args 1 end]]
4862                }
4863                #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]]
4864            }
4865        }
4866        set errorCode $savedErrorCode
4867        set errorInfo $savedErrorInfo
4868        ##
4869        ## History substitution moved into ::tkcon::EvalCmd
4870        ##
4871        if {[string compare $name "::"] == 0} {
4872            set name ""
4873        }
4874        if {$ret != 0} {
4875            return -code $ret -errorcode $errorCode \
4876                "error in unknown while checking if \"$name\" is a unique command abbreviation: $msg"
4877        }
4878        set cmds [info commands $name*]
4879        if {[llength $cmds] == 1} {
4880            return [uplevel 1 [lreplace $args 0 0 $cmds]]
4881        }
4882        if {[llength $cmds]} {
4883            if {$name == ""} {
4884                return -code error "empty command name \"\""
4885            } else {
4886                return -code error \
4887                        "ambiguous command name \"$name\": [lsort $cmds]"
4888            }
4889        }
4890        ## We've got nothing so far
4891        ## Check and see if Tk wasn't loaded, but it appears to be a Tk cmd
4892        if {![uplevel \#0 info exists tk_version]} {
4893            lappend tkcmds bell bind bindtags button \
4894                    canvas checkbutton clipboard destroy \
4895                    entry event focus font frame grab grid image \
4896                    label labelframe listbox lower menu menubutton message \
4897                    option pack panedwindow place radiobutton raise \
4898                    scale scrollbar selection send spinbox \
4899                    text tk tkwait toplevel winfo wm
4900            if {[lsearch -exact $tkcmds $name] >= 0 && \
4901                    [tkcon master tk_messageBox -icon question -parent . \
4902                    -title "Load Tk?" -type retrycancel -default retry \
4903                    -message "This appears to be a Tk command, but Tk\
4904                    has not yet been loaded.  Shall I retry the command\
4905                    with loading Tk first?"] == "retry"} {
4906                return [uplevel 1 "load {} Tk; $args"]
4907            }
4908        }
4909    }
4910    return -code continue
4911}
4912
4913} ; # end exclusionary code for WWW
4914
4915proc ::tkcon::Bindings {} {
4916    variable PRIV
4917    global tcl_platform tk_version
4918
4919    #-----------------------------------------------------------------------
4920    # Elements of tkPriv that are used in this file:
4921    #
4922    # char -            Character position on the line;  kept in order
4923    #                   to allow moving up or down past short lines while
4924    #                   still remembering the desired position.
4925    # mouseMoved -      Non-zero means the mouse has moved a significant
4926    #                   amount since the button went down (so, for example,
4927    #                   start dragging out a selection).
4928    # prevPos -         Used when moving up or down lines via the keyboard.
4929    #                   Keeps track of the previous insert position, so
4930    #                   we can distinguish a series of ups and downs, all
4931    #                   in a row, from a new up or down.
4932    # selectMode -      The style of selection currently underway:
4933    #                   char, word, or line.
4934    # x, y -            Last known mouse coordinates for scanning
4935    #                   and auto-scanning.
4936    #-----------------------------------------------------------------------
4937
4938    switch -glob $tcl_platform(platform) {
4939        win*    { set PRIV(meta) Alt }
4940        mac*    { set PRIV(meta) Command }
4941        default { set PRIV(meta) Meta }
4942    }
4943
4944    ## Get all Text bindings into TkConsole
4945    foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] }
4946    ## We really didn't want the newline insertion
4947    bind TkConsole <Control-Key-o> {}
4948
4949    ## Now make all our virtual event bindings
4950    foreach {ev key} [subst -nocommand -noback {
4951        <<TkCon_Exit>>          <Control-q>
4952        <<TkCon_New>>           <Control-N>
4953        <<TkCon_NewTab>>        <Control-T>
4954        <<TkCon_NextTab>>       <Control-Key-Tab>
4955        <<TkCon_PrevTab>>       <Control-Shift-Key-Tab>
4956        <<TkCon_Close>>         <Control-w>
4957        <<TkCon_About>>         <Control-A>
4958        <<TkCon_Help>>          <Control-H>
4959        <<TkCon_Find>>          <Control-F>
4960        <<TkCon_Slave>>         <Control-Key-1>
4961        <<TkCon_Master>>        <Control-Key-2>
4962        <<TkCon_Main>>          <Control-Key-3>
4963        <<TkCon_Expand>>        <Key-Tab>
4964        <<TkCon_ExpandFile>>    <Key-Escape>
4965        <<TkCon_ExpandProc>>    <Control-P>
4966        <<TkCon_ExpandVar>>     <Control-V>
4967        <<TkCon_Tab>>           <Control-i>
4968        <<TkCon_Tab>>           <$PRIV(meta)-i>
4969        <<TkCon_Newline>>       <Control-o>
4970        <<TkCon_Newline>>       <$PRIV(meta)-o>
4971        <<TkCon_Newline>>       <Control-Key-Return>
4972        <<TkCon_Newline>>       <Control-Key-KP_Enter>
4973        <<TkCon_Eval>>          <Return>
4974        <<TkCon_Eval>>          <KP_Enter>
4975        <<TkCon_Clear>>         <Control-l>
4976        <<TkCon_Previous>>      <Up>
4977        <<TkCon_PreviousImmediate>>     <Control-p>
4978        <<TkCon_PreviousSearch>>        <Control-r>
4979        <<TkCon_Next>>          <Down>
4980        <<TkCon_NextImmediate>> <Control-n>
4981        <<TkCon_NextSearch>>    <Control-s>
4982        <<TkCon_Transpose>>     <Control-t>
4983        <<TkCon_ClearLine>>     <Control-u>
4984        <<TkCon_SaveCommand>>   <Control-z>
4985        <<TkCon_Popup>>         <Button-3>
4986    }] {
4987        event add $ev $key
4988        ## Make sure the specific key won't be defined
4989        bind TkConsole $key {}
4990    }
4991
4992    ## Make the ROOT bindings
4993    bind $PRIV(root) <<TkCon_Exit>>     exit
4994    bind $PRIV(root) <<TkCon_New>>      { ::tkcon::New }
4995    bind $PRIV(root) <<TkCon_NewTab>>   { ::tkcon::NewTab }
4996    bind $PRIV(root) <<TkCon_NextTab>>  { ::tkcon::GotoTab 1 ; break }
4997    bind $PRIV(root) <<TkCon_PrevTab>>  { ::tkcon::GotoTab -1 ; break }
4998    bind $PRIV(root) <<TkCon_Close>>    { ::tkcon::Destroy }
4999    bind $PRIV(root) <<TkCon_About>>    { ::tkcon::About }
5000    bind $PRIV(root) <<TkCon_Help>>     { ::tkcon::Help }
5001    bind $PRIV(root) <<TkCon_Find>>     { ::tkcon::FindBox $::tkcon::PRIV(console) }
5002    bind $PRIV(root) <<TkCon_Slave>>    {
5003        ::tkcon::Attach {}
5004        ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
5005    }
5006    bind $PRIV(root) <<TkCon_Master>>   {
5007        if {[string compare {} $::tkcon::PRIV(name)]} {
5008            ::tkcon::Attach $::tkcon::PRIV(name)
5009        } else {
5010            ::tkcon::Attach Main
5011        }
5012        ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
5013    }
5014    bind $PRIV(root) <<TkCon_Main>>     {
5015        ::tkcon::Attach Main
5016        ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
5017    }
5018    bind $PRIV(root) <<TkCon_Popup>> {
5019        ::tkcon::PopupMenu %X %Y
5020    }
5021
5022    ## Menu items need null TkConsolePost bindings to avoid the TagProc
5023    ##
5024    foreach ev [bind $PRIV(root)] {
5025        bind TkConsolePost $ev {
5026            # empty
5027        }
5028    }
5029
5030
5031    # ::tkcon::ClipboardKeysyms --
5032    # This procedure is invoked to identify the keys that correspond to
5033    # the copy, cut, and paste functions for the clipboard.
5034    #
5035    # Arguments:
5036    # copy -    Name of the key (keysym name plus modifiers, if any,
5037    #           such as "Meta-y") used for the copy operation.
5038    # cut -             Name of the key used for the cut operation.
5039    # paste -   Name of the key used for the paste operation.
5040
5041    proc ::tkcon::ClipboardKeysyms {copy cut paste} {
5042        bind TkConsole <$copy>  {::tkcon::Copy %W}
5043        bind TkConsole <$cut>   {::tkcon::Cut %W}
5044        bind TkConsole <$paste> {::tkcon::Paste %W}
5045    }
5046
5047    proc ::tkcon::GetSelection {w} {
5048        if {
5049            ![catch {selection get -displayof $w -type UTF8_STRING} txt] ||
5050            ![catch {selection get -displayof $w} txt] ||
5051            ![catch {selection get -displayof $w -selection CLIPBOARD} txt]
5052        } {
5053            return $txt
5054        }
5055        return -code error "could not find default selection"
5056    }
5057
5058    proc ::tkcon::Cut w {
5059        if {[string match $w [selection own -displayof $w]]} {
5060            clipboard clear -displayof $w
5061            catch {
5062                set txt [selection get -displayof $w]
5063                clipboard append -displayof $w $txt
5064                if {[$w compare sel.first >= limit]} {
5065                    $w delete sel.first sel.last
5066                }
5067            }
5068        }
5069    }
5070    proc ::tkcon::Copy w {
5071        if {[string match $w [selection own -displayof $w]]} {
5072            clipboard clear -displayof $w
5073            catch {
5074                set txt [selection get -displayof $w]
5075                clipboard append -displayof $w $txt
5076            }
5077        }
5078    }
5079    proc ::tkcon::Paste w {
5080        if {![catch {GetSelection $w} txt]} {
5081            if {[$w compare insert < limit]} { $w mark set insert end }
5082            $w insert insert $txt
5083            $w see insert
5084            if {[string match *\n* $txt]} { ::tkcon::Eval $w }
5085        }
5086    }
5087
5088    ## Redefine for TkConsole what we need
5089    ##
5090    event delete <<Paste>> <Control-V>
5091    ::tkcon::ClipboardKeysyms <Copy> <Cut> <Paste>
5092
5093    bind TkConsole <Insert> {
5094        catch { ::tkcon::Insert %W [::tkcon::GetSelection %W] }
5095    }
5096
5097    bind TkConsole <Triple-1> {+
5098        catch {
5099            eval %W tag remove sel [%W tag nextrange prompt sel.first sel.last]
5100            eval %W tag remove sel sel.last-1c
5101            %W mark set insert sel.first
5102        }
5103    }
5104
5105    ## binding editor needed
5106    ## binding <events> for .tkconrc
5107
5108    bind TkConsole <<TkCon_ExpandFile>> {
5109        if {[%W compare insert > limit]} {::tkcon::Expand %W path}
5110        break
5111    }
5112    bind TkConsole <<TkCon_ExpandProc>> {
5113        if {[%W compare insert > limit]} {::tkcon::Expand %W proc}
5114    }
5115    bind TkConsole <<TkCon_ExpandVar>> {
5116        if {[%W compare insert > limit]} {::tkcon::Expand %W var}
5117    }
5118    bind TkConsole <<TkCon_Expand>> {
5119        if {[%W compare insert > limit]} {::tkcon::Expand %W}
5120    }
5121    bind TkConsole <<TkCon_Tab>> {
5122        if {[%W compare insert >= limit]} {
5123            ::tkcon::Insert %W \t
5124        }
5125    }
5126    bind TkConsole <<TkCon_Newline>> {
5127        if {[%W compare insert >= limit]} {
5128            ::tkcon::Insert %W \n
5129        }
5130    }
5131    bind TkConsole <<TkCon_Eval>> {
5132        ::tkcon::Eval %W
5133    }
5134    bind TkConsole <Delete> {
5135        if {[llength [%W tag nextrange sel 1.0 end]] \
5136                && [%W compare sel.first >= limit]} {
5137            %W delete sel.first sel.last
5138        } elseif {[%W compare insert >= limit]} {
5139            %W delete insert
5140            %W see insert
5141        }
5142    }
5143    bind TkConsole <BackSpace> {
5144        if {[llength [%W tag nextrange sel 1.0 end]] \
5145                && [%W compare sel.first >= limit]} {
5146            %W delete sel.first sel.last
5147        } elseif {[%W compare insert != 1.0] && [%W compare insert > limit]} {
5148            %W delete insert-1c
5149            %W see insert
5150        }
5151    }
5152    bind TkConsole <Control-h> [bind TkConsole <BackSpace>]
5153
5154    bind TkConsole <KeyPress> {
5155        ::tkcon::Insert %W %A
5156    }
5157
5158    bind TkConsole <Control-a> {
5159        if {[%W compare {limit linestart} == {insert linestart}]} {
5160            tkTextSetCursor %W limit
5161        } else {
5162            tkTextSetCursor %W {insert linestart}
5163        }
5164    }
5165    bind TkConsole <Key-Home> [bind TkConsole <Control-a>]
5166    bind TkConsole <Control-d> {
5167        if {[%W compare insert < limit]} break
5168        %W delete insert
5169    }
5170    bind TkConsole <Control-k> {
5171        if {[%W compare insert < limit]} break
5172        if {[%W compare insert == {insert lineend}]} {
5173            %W delete insert
5174        } else {
5175            %W delete insert {insert lineend}
5176        }
5177    }
5178    bind TkConsole <<TkCon_Clear>> {
5179        ## Clear console buffer, without losing current command line input
5180        set ::tkcon::PRIV(tmp) [::tkcon::CmdGet %W]
5181        clear
5182        ::tkcon::Prompt {} $::tkcon::PRIV(tmp)
5183    }
5184    bind TkConsole <<TkCon_Previous>> {
5185        if {[%W compare {insert linestart} != {limit linestart}]} {
5186            tkTextSetCursor %W [tkTextUpDownLine %W -1]
5187        } else {
5188            ::tkcon::Event -1
5189        }
5190    }
5191    bind TkConsole <<TkCon_Next>> {
5192        if {[%W compare {insert linestart} != {end-1c linestart}]} {
5193            tkTextSetCursor %W [tkTextUpDownLine %W 1]
5194        } else {
5195            ::tkcon::Event 1
5196        }
5197    }
5198    bind TkConsole <<TkCon_NextImmediate>>  { ::tkcon::Event 1 }
5199    bind TkConsole <<TkCon_PreviousImmediate>> { ::tkcon::Event -1 }
5200    bind TkConsole <<TkCon_PreviousSearch>> {
5201        ::tkcon::Event -1 [::tkcon::CmdGet %W]
5202    }
5203    bind TkConsole <<TkCon_NextSearch>>     {
5204        ::tkcon::Event 1 [::tkcon::CmdGet %W]
5205    }
5206    bind TkConsole <<TkCon_Transpose>>  {
5207        ## Transpose current and previous chars
5208        if {[%W compare insert > "limit+1c"]} { tkTextTranspose %W }
5209    }
5210    bind TkConsole <<TkCon_ClearLine>> {
5211        ## Clear command line (Unix shell staple)
5212        %W delete limit end
5213    }
5214    bind TkConsole <<TkCon_SaveCommand>> {
5215        ## Save command buffer (swaps with current command)
5216        set ::tkcon::PRIV(tmp) $::tkcon::PRIV(cmdsave)
5217        set ::tkcon::PRIV(cmdsave) [::tkcon::CmdGet %W]
5218        if {[string match {} $::tkcon::PRIV(cmdsave)]} {
5219            set ::tkcon::PRIV(cmdsave) $::tkcon::PRIV(tmp)
5220        } else {
5221            %W delete limit end-1c
5222        }
5223        ::tkcon::Insert %W $::tkcon::PRIV(tmp)
5224        %W see end
5225    }
5226    catch {bind TkConsole <Key-Page_Up>   { tkTextScrollPages %W -1 }}
5227    catch {bind TkConsole <Key-Prior>     { tkTextScrollPages %W -1 }}
5228    catch {bind TkConsole <Key-Page_Down> { tkTextScrollPages %W 1 }}
5229    catch {bind TkConsole <Key-Next>      { tkTextScrollPages %W 1 }}
5230    bind TkConsole <$PRIV(meta)-d> {
5231        if {[%W compare insert >= limit]} {
5232            %W delete insert {insert wordend}
5233        }
5234    }
5235    bind TkConsole <$PRIV(meta)-BackSpace> {
5236        if {[%W compare {insert -1c wordstart} >= limit]} {
5237            %W delete {insert -1c wordstart} insert
5238        }
5239    }
5240    bind TkConsole <$PRIV(meta)-Delete> {
5241        if {[%W compare insert >= limit]} {
5242            %W delete insert {insert wordend}
5243        }
5244    }
5245    bind TkConsole <ButtonRelease-2> {
5246        if {
5247            (!$tkPriv(mouseMoved) || $tk_strictMotif) &&
5248            ![catch {::tkcon::GetSelection %W} ::tkcon::PRIV(tmp)]
5249        } {
5250            if {[%W compare @%x,%y < limit]} {
5251                %W insert end $::tkcon::PRIV(tmp)
5252            } else {
5253                %W insert @%x,%y $::tkcon::PRIV(tmp)
5254            }
5255            if {[string match *\n* $::tkcon::PRIV(tmp)]} {::tkcon::Eval %W}
5256        }
5257    }
5258
5259    ##
5260    ## End TkConsole bindings
5261    ##
5262
5263    ##
5264    ## Bindings for doing special things based on certain keys
5265    ##
5266    bind TkConsolePost <Key-parenright> {
5267        if {$::tkcon::OPT(lightbrace) && $::tkcon::OPT(blinktime)>99 && \
5268                [string compare \\ [%W get insert-2c]]} {
5269            ::tkcon::MatchPair %W