Changeset 986


Ignore:
Timestamp:
Apr 21, 2010 2:42:21 PM (10 years ago)
Author:
toby
Message:

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

Location:
trunk
Files:
1 added
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/expgui

    r983 r986  
    41744174    $expgui(fm).help.menu add command -label "Open tkcon console" \
    41754175        -command {tkcon show}
     4176} elseif {[file exists [file join $expgui(scriptdir) tkcon tkcon.tcl]]} {
     4177    $expgui(fm).help.menu add command -label "Open tkcon console" \
     4178        -command {source [file join $expgui(scriptdir) tkcon tkcon.tcl]}
     4179} else {
     4180    $expgui(fm).help.menu add command -label "Turn on debug puts" \
     4181        -command {set expgui(debug) 1}
    41764182}
    41774183# add update commands to buffer
  • trunk/gsascmds.tcl

    r985 r986  
    27112711    }
    27122712} else {
    2713     # this creates a xterm window to run a program in
    2714     proc forknewterm {title command "wait 1" "scrollbar 1"} {
    2715         global env expgui
    2716         # UNIX environment variables
    2717         set env(GSAS) [file nativename $expgui(gsasdir)]
    2718         set env(gsas) [file nativename $expgui(gsasdir)]
    2719         set env(GSASEXE) $expgui(gsasexe)
    2720         set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
    2721         set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
    2722         # PGPLOT_DIR is needed by PGPLOT
    2723         set env(PGPLOT_DIR) $expgui(pgplotdir)
    2724         # this is the number of lines/page in the .LST (etc.) file
    2725         set env(LENPAGE) 60
    2726         set termopts {}
    2727         if $env(GSASBACKSPACE) {
    2728             append termopts \
     2713    # UNIX-based machines
     2714    if {[auto_execok xterm] != ""} {
     2715        # this creates a xterm window for running programs inside
     2716        proc forknewterm {title command "wait 1" "scrollbar 1"} {
     2717            global env expgui
     2718            # UNIX environment variables
     2719            set env(GSAS) [file nativename $expgui(gsasdir)]
     2720            set env(gsas) [file nativename $expgui(gsasdir)]
     2721            set env(GSASEXE) $expgui(gsasexe)
     2722            set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
     2723            set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
     2724            # PGPLOT_DIR is needed by PGPLOT
     2725            set env(PGPLOT_DIR) $expgui(pgplotdir)
     2726            # this is the number of lines/page in the .LST (etc.) file
     2727            set env(LENPAGE) 60
     2728            set termopts {}
     2729            if $env(GSASBACKSPACE) {
     2730                append termopts \
    27292731                    {-xrm "xterm*VT100.Translations: #override\\n <KeyPress>BackSpace: string(\\177)"}
    2730         }
    2731         if $scrollbar {
    2732             append termopts " -sb"
    2733         } else {
    2734             append termopts " +sb"
    2735         }
    2736         if {$wait} {
    2737             set suffix {}
    2738         } else {
    2739             set suffix {&}
    2740         }
    2741 
    2742         # hold window open after commands finish
    2743         if {$expgui(execprompt)} {
    2744             append command "\; echo -n Press Enter to continue \; read x"
    2745         }
    2746         if {$wait && $expgui(autoiconify)} {wm iconify .}
    2747         catch {eval exec xterm $termopts -title [list $title] \
    2748                 -e /bin/sh -c [list $command] $suffix} errmsg
    2749         if $expgui(debug) {puts "xterm result = $errmsg"}
    2750         if {$expgui(MacroRunning)} {
    2751             update
    2752             update idletasks
    2753         }
    2754         if {$wait} {
    2755             if {$expgui(autoiconify)} {wm deiconify .}
    2756             # check for changes in the .EXP file immediately
    2757             whenidle
    2758         }
     2732            }
     2733            if $scrollbar {
     2734                append termopts " -sb"
     2735            } else {
     2736                append termopts " +sb"
     2737            }
     2738            if {$wait} {
     2739                set suffix {}
     2740            } else {
     2741                set suffix {&}
     2742            }
     2743           
     2744            # hold window open after commands finish
     2745            if {$expgui(execprompt)} {
     2746                append command "\; echo -n Press Enter to continue \; read x"
     2747            }
     2748            if {$wait && $expgui(autoiconify)} {wm iconify .}
     2749            catch {eval exec xterm $termopts -title [list $title] \
     2750                       -e /bin/sh -c [list $command] $suffix} errmsg
     2751            if $expgui(debug) {puts "xterm result = $errmsg"}
     2752            if {$expgui(MacroRunning)} {
     2753                update
     2754                update idletasks
     2755            }
     2756            if {$wait} {
     2757                if {$expgui(autoiconify)} {wm deiconify .}
     2758                # check for changes in the .EXP file immediately
     2759                whenidle
     2760            }
     2761        }
     2762    } elseif {[auto_execok gnome-terminal] != ""} {
     2763        # this creates a xterm window for running programs inside
     2764        proc forknewterm {title command "wait 1" "scrollbar 1"} {
     2765            global env expgui
     2766            # UNIX environment variables
     2767            set env(GSAS) [file nativename $expgui(gsasdir)]
     2768            set env(gsas) [file nativename $expgui(gsasdir)]
     2769            set env(GSASEXE) $expgui(gsasexe)
     2770            set env(ATOMDATA) [file join $expgui(gsasdir) data atmdata.dat]
     2771            set env(ATMXSECT) [file join $expgui(gsasdir) data atmxsect.dat]
     2772            # PGPLOT_DIR is needed by PGPLOT
     2773            set env(PGPLOT_DIR) $expgui(pgplotdir)
     2774            # this is the number of lines/page in the .LST (etc.) file
     2775            set env(LENPAGE) 60
     2776            if {$wait} {
     2777                set suffix {}
     2778            } else {
     2779                set suffix {&}
     2780            }
     2781           
     2782            # hold window open after commands finish
     2783            if {$expgui(execprompt)} {
     2784                append command "\; echo -n Press Enter to continue \; read x"
     2785            }
     2786            if {$wait && $expgui(autoiconify)} {wm iconify .}
     2787            catch {exec gnome-terminal --title $title \
     2788                       -e " /bin/sh -c \" $command \" " $suffix} errmsg
     2789            if $expgui(debug) {puts "gnome-terminal result = $errmsg"}
     2790            if {$expgui(MacroRunning)} {
     2791                update
     2792                update idletasks
     2793            }
     2794            if {$wait} {
     2795                if {$expgui(autoiconify)} {wm deiconify .}
     2796                # check for changes in the .EXP file immediately
     2797                whenidle
     2798            }
     2799        }
     2800    } else {
     2801        MyMessageBox -parent . -title "Error: no terminal program" \
     2802            -message "Error, the xterm or gnome-terminal utility programs could not be found. It is not possible to run the GSAS programs without this." \
     2803            -icon error -type NOT-OK -default not-ok
    27592804    }
    27602805}
  • trunk/tkcon/tkcon.tcl

    r931 r986  
    1111##
    1212## Thanks to the following (among many) for early bug reports & code ideas:
    13 ## Steven Wahl <steven@indra.com>, Jan Nijtmans <nijtmans@nici.kun.nl>
    14 ## Crimmins <markcrim@umich.edu>, Wart <wart@ugcs.caltech.edu>
     13## Steven Wahl, Jan Nijtmans, Mark Crimmins, Wart
    1514##
    16 ## Copyright 1995-2001 Jeffrey Hobbs
     15## Copyright (c) 1995-2004 Jeffrey Hobbs, jeff(a)hobbs(.)org
    1716## Initiated: Thu Aug 17 15:36:47 PDT 1995
    18 ##
    19 ## jeff.hobbs@acm.org, jeff@hobbs.org
    2017##
    2118## source standard_disclaimer.tcl
     
    2522# Proxy support for retrieving the current version of Tkcon.
    2623#
    27 # Mon Jun 25 12:19:56 2001 - Pat Thoyts <Pat.Thoyts@bigfoot.com>
     24# Mon Jun 25 12:19:56 2001 - Pat Thoyts
    2825#
    2926# In your tkcon.cfg or .tkconrc file put your proxy details into the
     
    4542    return -code error "tkcon requires at least Tcl/Tk8"
    4643} else {
    47     package require -exact Tk $tcl_version
    48 }
    49 
    50 catch {package require bogus-package-name}
     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}
    5151foreach pkg [info loaded {}] {
    5252    set file [lindex $pkg 0]
     
    7575#
    7676namespace eval ::tkcon {
     77    # when modifying this line, make sure that the auto-upgrade check
     78    # for version still works.
     79    variable VERSION "2.4"
    7780    # The OPT variable is an array containing most of the optional
    7881    # info to configure.  COLOR has the color data.
     
    8386    variable PRIV
    8487    set PRIV(WWW) [info exists embed_args]
     88
     89    variable EXPECT 0
    8590}
    8691
     
    9095# Outputs:      errors found in tkcon's resource file
    9196##
    92 proc ::tkcon::Init {} {
     97proc ::tkcon::Init {args} {
     98    variable VERSION
    9399    variable OPT
    94100    variable COLOR
    95101    variable PRIV
    96     global tcl_platform env argc argv tcl_interactive errorInfo
    97 
    98     if {![info exists argv]} {
    99         set argv {}
    100         set argc 0
    101     }
     102    global tcl_platform env tcl_interactive errorInfo
    102103
    103104    set tcl_interactive 1
    104 
    105     if {[info exists PRIV(name)]} {
    106         set title $PRIV(name)
    107     } else {
    108         MainInit
    109         # some main initialization occurs later in this proc,
    110         # to go after the UI init
    111         set MainInit 1
    112         set title Main
    113     }
     105    set argc [llength $args]
    114106
    115107    ##
     
    135127    }
    136128
     129    # expandorder could also include 'Xotcl' (before Procname)
    137130    foreach {key default} {
    138131        autoload        {}
     
    140133        blinkrange      1
    141134        buffer          512
     135        maxlinelen      0
    142136        calcmode        0
    143137        cols            80
    144138        debugPrompt     {(level \#$level) debug [history nextid] > }
    145139        dead            {}
     140        edit            edit
    146141        expandorder     {Pathname Variable Procname}
    147142        font            {}
     
    152147        lightcmd        1
    153148        maineval        {}
    154         maxmenu         15
     149        maxmenu         18
    155150        nontcl          0
    156151        prompt1         {ignore this, it's set below}
     
    159154        showmenu        1
    160155        showmultiple    1
    161         showstatusbar   0
     156        showstatusbar   1
    162157        slaveeval       {}
    163158        slaveexit       close
     
    165160        gc-delay        60000
    166161        gets            {congets}
     162        overrideexit    1
    167163        usehistory      1
    168164
     
    190186        find,reg        0
    191187        errorInfo       {}
     188        protocol        exit
    192189        showOnStartup   1
    193         slavealias      { edit more less tkcon }
    194190        slaveprocs      {
    195191            alias clear dir dump echo idebug lremove
    196192            tkcon_puts tkcon_gets observe observe_var unalias which what
    197193        }
    198         version         2.3
    199         RCS             {RCS: @(#) $Id: tkcon.tcl,v 1.52 2002/01/24 19:50:36 hobbs Exp $}
    200         HEADURL         {http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tkcon/tkcon/tkcon.tcl?rev=HEAD}
     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
    201197        docs            "http://tkcon.sourceforge.net/"
    202         email           {jeff@hobbs.org}
     198        email           {jeff(a)hobbs(.)org}
    203199        root            .
     200        uid             0
     201        tabs            {}
    204202    } {
    205203        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
    206223    }
    207224
     
    254271    }
    255272    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        }
    256278        if {![info exists PRIV(rcfile)]} {
    257             set PRIV(rcfile)    [file join $env($envHome) $rcfile]
     279            set PRIV(rcfile)    [file join $home $rcfile]
    258280        }
    259281        if {![info exists PRIV(histfile)]} {
    260             set PRIV(histfile)  [file join $env($envHome) $histfile]
     282            set PRIV(histfile)  [file join $home $histfile]
    261283        }
    262284    }
     
    264286    ## Handle command line arguments before sourcing resource file to
    265287    ## find if resource file is being specified (let other args pass).
    266     if {[set i [lsearch -exact $argv -rcfile]] != -1} {
    267         set PRIV(rcfile) [lindex $argv [incr i]]
     288    if {[set i [lsearch -exact $args -rcfile]] != -1} {
     289        set PRIV(rcfile) [lindex $args [incr i]]
    268290    }
    269291
     
    274296    if {[info exists env(TK_CON_LIBRARY)]} {
    275297        lappend ::auto_path $env(TK_CON_LIBRARY)
    276     } else {
     298    } elseif {$OPT(library) != ""} {
    277299        lappend ::auto_path $OPT(library)
    278300    }
     
    293315    set truth {^(1|yes|true|on)$}
    294316    for {set i 0} {$i < $argc} {incr i} {
    295         set arg [lindex $argv $i]
     317        set arg [lindex $args $i]
    296318        if {[string match {-*} $arg]} {
    297             set val [lindex $argv [incr i]]
     319            set val [lindex $args [incr i]]
    298320            ## Handle arg based options
    299321            switch -glob -- $arg {
    300                 -- - -argv      {
     322                -- - -argv - -args {
    301323                    set argv [concat -- [lrange $argv $i end]]
    302324                    set argc [llength $argv]
     
    322344
    323345    ## Create slave executable
    324     if {[string compare {} $OPT(exec)]} {
     346    if {"" != $OPT(exec)} {
    325347        uplevel \#0 ::tkcon::InitSlave $OPT(exec) $slaveargs
    326348    } else {
    327349        set argc [llength $slaveargs]
    328         set argv $slaveargs
     350        set args $slaveargs
    329351        uplevel \#0 $slaveargs
    330352    }
     
    333355    Attach $PRIV(appname) $PRIV(apptype)
    334356    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    }
    335361
    336362    ## swap puts and gets with the tkcon versions to make sure all
     
    407433    StateCheckpoint $PRIV(name) slave
    408434
     435    puts "buffer line limit:\
     436        [expr {$OPT(buffer)?$OPT(buffer):{unlimited}}]  \
     437        max line length:\
     438        [expr {$OPT(maxlinelen)?$OPT(maxlinelen):{unlimited}}]"
     439
    409440    Prompt "$title console display active (Tcl$::tcl_patchLevel / Tk$::tk_patchLevel)\n"
    410441}
     
    420451    variable COLOR
    421452    variable PRIV
    422     global argv0 tcl_interactive tcl_library env auto_path
     453    global argv0 tcl_interactive tcl_library env auto_path tk_library
    423454
    424455    if {[string match {} $slave]} {
     
    431462        $slave alias open SafeOpen $slave
    432463        $slave alias file file
    433         interp eval $slave [dump var -nocomplain tcl_library auto_path env]
     464        interp eval $slave \
     465            [list set auto_path [lremove $auto_path $tk_library]]
     466        interp eval $slave [dump var -nocomplain tcl_library env]
    434467        interp eval $slave { catch {source [file join $tcl_library init.tcl]} }
    435468        interp eval $slave { catch unknown }
    436469    }
     470    # This will likely be overridden to call DeleteTab where possible
    437471    $slave alias exit exit
    438472    interp eval $slave {
     
    451485    if {[info exists argv0]} {interp eval $slave [list set argv0 $argv0]}
    452486    interp eval $slave set tcl_interactive $tcl_interactive \; \
    453             set auto_path [list $auto_path] \; \
     487            set auto_path [list [lremove $auto_path $tk_library]] \; \
    454488            set argc [llength $args] \; \
    455489            set argv  [list $args] \; {
     
    499533            }
    500534            interp {
    501                 set thistkcon [tk appname]
     535                set thistkcon [::send::appname]
    502536                foreach cmd $PRIV(slavealias) {
    503                     EvalAttached "proc $cmd args { send [list $thistkcon] $cmd \$args }"
     537                    EvalAttached "proc $cmd args { ::send::send [list $thistkcon] $cmd \$args }"
    504538                }
    505539            }
     
    542576    if {!$PRIV(WWW)} {
    543577        wm withdraw $root
    544         wm protocol $root WM_DELETE_WINDOW exit
     578        wm protocol $root WM_DELETE_WINDOW $PRIV(protocol)
    545579    }
    546580    set PRIV(base) $w
    547581
    548     ## Text Console
    549     set PRIV(console) [set con $w.text]
    550     text $con -wrap char -yscrollcommand [list $w.sy set] \
    551             -foreground $COLOR(stdin) \
    552             -insertbackground $COLOR(cursor)
     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)
    553678    $con mark set output 1.0
    554679    $con mark set limit 1.0
     
    560685        ## Set user-requested font, if any
    561686        $con configure -font $OPT(font)
    562     } else {
     687    } elseif {[string compare unix $::tcl_platform(platform)]} {
    563688        ## otherwise make sure the font is monospace
    564689        set font [$con cget -font]
    565690        if {![font metrics $font -fixed]} {
    566             font create tkconfixed -family Courier -size 12
    567691            $con configure -font tkconfixed
    568692        }
     693    } else {
     694        $con configure -font tkconfixed
    569695    }
    570696    set OPT(font) [$con cget -font]
     697    bindtags $con [list $con TkConsole TkConsolePost $PRIV(root) all]
     698
     699    # scrollbar
    571700    if {!$PRIV(WWW)} {
    572         $con configure -setgrid 1 -width $OPT(cols) -height $OPT(rows)
    573     }
    574     bindtags $con [list $con TkConsole TkConsolePost $root all]
    575     ## Menus
    576     ## catch against use in plugin
    577     if {[catch {menu $w.mbar} PRIV(menubar)]} {
    578         set PRIV(menubar) [frame $w.mbar -relief raised -bd 1]
    579     }
    580     ## Scrollbar
    581     set PRIV(scrolly) [scrollbar $w.sy -takefocus 0 -bd 1 \
    582             -command [list $con yview]]
    583 
    584     InitMenus $PRIV(menubar) $title
    585     Bindings
    586 
    587     if {$OPT(showmenu)} {
    588         $root configure -menu $PRIV(menubar)
    589     }
    590     pack $w.sy -side $OPT(scrollypos) -fill y
    591     pack $con -fill both -expand 1
    592 
    593     set PRIV(statusbar) [set sbar [frame $w.sbar]]
    594     label $sbar.attach -relief sunken -bd 1 -anchor w \
    595             -textvariable ::tkcon::PRIV(StatusAttach)
    596     label $sbar.mode -relief sunken -bd 1 -anchor w  \
    597             -textvariable ::tkcon::PRIV(StatusMode)
    598     label $sbar.cursor -relief sunken -bd 1 -anchor w -width 6 \
    599             -textvariable ::tkcon::PRIV(StatusCursor)
    600     grid $sbar.attach $sbar.mode $sbar.cursor -sticky news -padx 1
    601     grid columnconfigure $sbar 0 -weight 1
    602     grid columnconfigure $sbar 1 -weight 1
    603     grid columnconfigure $sbar 2 -weight 0
    604 
    605     if {$OPT(showstatusbar)} {
    606         pack $sbar -side bottom -fill x -before $::tkcon::PRIV(scrolly)
    607     }
     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)
    608721
    609722    foreach col {prompt stdout stderr stdin proc} {
     
    615728    $con tag configure find -background $COLOR(blink)
    616729
    617     if {!$PRIV(WWW)} {
    618         wm title $root "tkcon $PRIV(version) $title"
    619         bind $con <Configure> {
    620             scan [wm geometry [winfo toplevel %W]] "%%dx%%d" \
    621                     ::tkcon::OPT(cols) ::tkcon::OPT(rows)
    622         }
    623         if {$PRIV(showOnStartup)} { wm deiconify $root }
    624     }
    625     if {$PRIV(showOnStartup)} { focus -force $PRIV(console) }
    626     if {$OPT(gc-delay)} {
    627         after $OPT(gc-delay) ::tkcon::GarbageCollect
    628     }
     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
    629846}
    630847
     
    635852    variable PRIV
    636853
    637     set w $PRIV(console)
    638     ## Remove error tags that no longer span anything
    639     ## Make sure the tag pattern matches the unique tag prefix
    640     foreach tag [$w tag names] {
    641         if {[string match _tag* $tag] && ![llength [$w tag ranges $tag]]} {
    642             $w tag delete $tag
     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            }
    643864        }
    644865    }
     
    666887        EvalCmd $w $last
    667888    }
    668     $w see insert
     889    if {[winfo exists $w]} {
     890        $w see insert
     891    }
    669892}
    670893
     
    686909            set ev [EvalSlave history nextid]
    687910            incr ev -1
     911            ## FIX: calcmode doesn't work with requesting history events
    688912            if {[string match !! $cmd]} {
    689913                set code [catch {EvalSlave history event $ev} cmd]
     
    703927                }
    704928            } elseif {$OPT(calcmode) && ![catch {expr $cmd} err]} {
    705                 EvalSlave history add $cmd
     929                AddSlaveHistory $cmd
    706930                set cmd $err
    707931                set code -1
     
    736960                }
    737961            }
    738             EvalSlave history add $cmd
     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            }
    739976            if {$code} {
    740977                if {$OPT(hoterrors)} {
    741978                    set tag [UniqueTag $w]
    742                     $w insert output $res [list stderr $tag] \n stderr
     979                    $w insert output $res [list stderr $tag] \n$trailer stderr
    743980                    $w tag bind $tag <Enter> \
    744981                            [list $w tag configure $tag -under 1]
     
    747984                    $w tag bind $tag <ButtonRelease-1> \
    748985                            "if {!\[info exists tkPriv(mouseMoved)\] || !\$tkPriv(mouseMoved)} \
    749                             {[list edit -attach [Attach] -type error -- $PRIV(errorInfo)]}"
     986                            {[list $OPT(edit) -attach [Attach] -type error -- $PRIV(errorInfo)]}"
    750987                } else {
    751                     $w insert output $res\n stderr
     988                    $w insert output $res\n$trailer stderr
    752989                }
    753990            } elseif {[string compare {} $res]} {
    754                 $w insert output $res\n stdout
     991                $w insert output $res stdout $trailer stderr \n stdout
    755992            }
    756993        }
     
    7781015        return [Slave $app $args]
    7791016    } else {
    780         return [uplevel 1 send [list $app] $args]
     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
    7811033    }
    7821034}
     
    7931045
    7941046    if {$PRIV(deadapp)} {
    795         if {[lsearch -exact [winfo interps] $PRIV(app)]<0} {
     1047        if {[lsearch -exact [::send::interps] $PRIV(app)]<0} {
    7961048            return
    7971049        } else {
     
    8011053        }
    8021054    }
    803     set code [catch {send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result]
    804     if {$code && [lsearch -exact [winfo interps] $PRIV(app)]<0} {
     1055    set code [catch {::send::send -displayof $PRIV(displayWin) $PRIV(app) $cmd} result]
     1056    if {$code && [lsearch -exact [::send::interps] $PRIV(app)]<0} {
    8051057        ## Interpreter disappeared
    8061058        if {[string compare leave $OPT(dead)] && \
    8071059                ([string match ignore $OPT(dead)] || \
    808                 [tk_dialog $PRIV(base).dead "Dead Attachment" \
    809                 "\"$PRIV(app)\" appears to have died.\
    810                 \nReturn to primary slave interpreter?" questhead 0 OK No])} {
     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")} {
    8111064            set PRIV(appname) "DEAD:$PRIV(appname)"
    8121065            set PRIV(deadapp) 1
     
    8541107        ## Interpreter died or disappeared
    8551108        puts "$code eof [eof $PRIV(app)]"
    856         EvalSocketClosed
     1109        EvalSocketClosed $PRIV(app)
    8571110    }
    8581111    return -code $code $result
     
    8651118# Returns:      the result of the command
    8661119##
    867 proc ::tkcon::EvalSocketEvent {} {
     1120proc ::tkcon::EvalSocketEvent {sock} {
    8681121    variable PRIV
    8691122
    870     if {[gets $PRIV(app) line] == -1} {
    871         if {[eof $PRIV(app)]} {
    872             EvalSocketClosed
     1123    if {[gets $sock line] == -1} {
     1124        if {[eof $sock]} {
     1125            EvalSocketClosed $sock
    8731126        }
    8741127        return
     
    8821135# Returns:      the result of the command
    8831136##
    884 proc ::tkcon::EvalSocketClosed {} {
     1137proc ::tkcon::EvalSocketClosed {sock} {
    8851138    variable OPT
    8861139    variable PRIV
    8871140
    888     catch {close $PRIV(app)}
     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    }
    8891147    if {[string compare leave $OPT(dead)] && \
    8901148            ([string match ignore $OPT(dead)] || \
    891             [tk_dialog $PRIV(base).dead "Dead Attachment" \
    892             "\"$PRIV(app)\" appears to have died.\
    893             \nReturn to primary slave interpreter?" questhead 0 OK No])} {
     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")} {
    8941153        set PRIV(appname) "DEAD:$PRIV(appname)"
    8951154        set PRIV(deadapp) 1
     
    10141273##
    10151274proc ::tkcon::ConstrainBuffer {w size} {
    1016     if {[$w index end] > $size} {
     1275    if {$size && ([$w index end] > $size)} {
    10171276        $w delete 1.0 [expr {int([$w index end])-$size}].0
    10181277    }
     
    10281287
    10291288    set w $PRIV(console)
     1289    if {![winfo exists $w]} { return }
    10301290    if {[string compare {} $pre]} { $w insert end $pre stdout }
    10311291    set i [$w index end-1c]
     
    10521312    $w see end
    10531313}
     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}
    10541323
    10551324## ::tkcon::About - gives about info for tkcon
     
    10611330
    10621331    set w $PRIV(base).about
    1063     if {[winfo exists $w]} {
    1064         wm deiconify $w
    1065     } else {
     1332    if {![winfo exists $w]} {
    10661333        global tk_patchLevel tcl_patchLevel tcl_version
    10671334        toplevel $w
     1335        wm withdraw $w
     1336        wm transient $w $PRIV(root)
     1337        wm group $w $PRIV(root)
    10681338        wm title $w "About tkcon v$PRIV(version)"
    10691339        button $w.b -text Dismiss -command [list wm withdraw $w]
     
    10791349        regexp {,v ([0-9\./: ]*)} $PRIV(RCS) -> RCS
    10801350        $w.text insert 1.0 "About tkcon v$PRIV(version)" title \
    1081                 "\n\nCopyright 1995-2001 Jeffrey Hobbs, $PRIV(email)\
     1351                "\n\nCopyright 1995-2002 Jeffrey Hobbs, $PRIV(email)\
    10821352                \nRelease Info: v$PRIV(version), CVS v$RCS\
    10831353                \nDocumentation available at:\n$PRIV(docs)\
    10841354                \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
    10851355        $w.text config -state disabled
    1086     }
     1356        bind $w <Escape> [list destroy $w]
     1357    }
     1358    wm deiconify $w
    10871359}
    10881360
     
    10961368    global tcl_platform
    10971369
    1098     if {[catch {menu $w.pop -tearoff 0}]} {
     1370    if {[catch {menu $w.pop}]} {
    10991371        label $w.label -text "Menus not available in plugin mode"
    1100         pack $w.label
     1372        grid $w.label -sticky ew
    11011373        return
    11021374    }
    1103     menu $w.context -tearoff 0 -disabledforeground $COLOR(disabled)
     1375    menu $w.context -disabledforeground $COLOR(disabled)
    11041376    set PRIV(context) $w.context
    11051377    set PRIV(popup) $w.pop
     
    11081380        $w add cascade -label $m -underline 0 -menu $w.$l
    11091381        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
    11101387    }
    11111388
     
    11281405        ##
    11291406        set s $m.save
    1130         menu $s -disabledforeground $COLOR(disabled) -tearoff 0
     1407        menu $s -disabledforeground $COLOR(disabled)
    11311408        $s add command -label "All"     -underline 0 \
    11321409                -command {::tkcon::Save {} all}
     
    11481425        $m add command -label "New Console"     -underline 0 -accel Ctrl-N \
    11491426                -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
    11501431        $m add command -label "Close Console"   -underline 0 -accel Ctrl-w \
    11511432                -command ::tkcon::Destroy
     
    11581439        }
    11591440        $m add separator
    1160         $m add cascade -label "Attach To ..."   -underline 0 -menu $m.attach
     1441        $m add cascade -label "Attach To ..." -underline 0 -menu $m.attach
    11611442
    11621443        ## Attach Console Menu
    11631444        ##
    11641445        set sub [menu $m.attach -disabledforeground $COLOR(disabled)]
    1165         $sub add cascade -label "Interpreter"   -underline 0 -menu $sub.apps
    1166         $sub add cascade -label "Namespace" -underline 1 -menu $sub.name
    1167         $sub add cascade -label "Socket" -underline 1 -menu $sub.sock \
    1168                 -state [expr {([info tclversion] < 8.3)?"disabled":"normal"}]
     1446        $sub add cascade -label "Interpreter" -underline 0 -menu $sub.apps
     1447        $sub add cascade -label "Namespace"   -underline 0 -menu $sub.name
    11691448
    11701449        ## Attach Console Menu
     
    11751454        ## Attach Namespace Menu
    11761455        ##
    1177         menu $sub.name -disabledforeground $COLOR(disabled) -tearoff 0 \
     1456        menu $sub.name -disabledforeground $COLOR(disabled) \
    11781457                -postcommand [list ::tkcon::NamespaceMenu $sub.name]
    11791458
    11801459        if {$::tcl_version >= 8.3} {
     1460            ## Attach Socket Menu
     1461            ##
    11811462            # This uses [file channels] to create the menu, so we only
    11821463            # want it for newer versions of Tcl.
    1183 
    1184             ## Attach Socket Menu
     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
    11851471            ##
    1186             menu $sub.sock -disabledforeground $COLOR(disabled) -tearoff 0 \
    1187                     -postcommand [list ::tkcon::SocketMenu $sub.sock]
    1188         }
    1189 
    1190         ## Attach Display Menu
    1191         ##
    1192         if {![string compare "unix" $tcl_platform(platform)]} {
    1193             $sub add cascade -label "Display" -und 1 -menu $sub.disp
     1472            $sub add cascade -label "Display" -underline 0 -menu $sub.disp
    11941473            menu $sub.disp -disabledforeground $COLOR(disabled) \
    1195                     -tearoff 0 \
    11961474                    -postcommand [list ::tkcon::DisplayMenu $sub.disp]
    11971475        }
     
    12301508                -underline 0 -variable ::tkcon::OPT(subhistory)
    12311509        $m add check -label "Hot Errors" \
    1232                 -underline 0 -variable ::tkcon::OPT(hoterrors)
     1510                -underline 4 -variable ::tkcon::OPT(hoterrors)
    12331511        $m add check -label "Non-Tcl Attachments" \
    12341512                -underline 0 -variable ::tkcon::OPT(nontcl)
     
    12421520                {$::tkcon::OPT(showmenu) ? $::tkcon::PRIV(menubar) : {}}]}
    12431521        $m add check -label "Show Statusbar" \
    1244                 -underline 5 -variable ::tkcon::OPT(showstatusbar) \
    1245                 -command {
    1246             if {$::tkcon::OPT(showstatusbar)} {
    1247                 pack $::tkcon::PRIV(statusbar) -side bottom -fill x \
    1248                         -before $::tkcon::PRIV(scrolly)
    1249             } else { pack forget $::tkcon::PRIV(statusbar) }
    1250         }
     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            }
    12511528        $m add cascade -label "Scrollbar" -underline 2 -menu $m.scroll
    12521529
    12531530        ## Scrollbar Menu
    12541531        ##
    1255         set m [menu $m.scroll -tearoff 0]
     1532        set m [menu $m.scroll]
    12561533        $m add radio -label "Left" -value left \
    12571534                -variable ::tkcon::OPT(scrollypos) \
    1258                 -command { pack config $::tkcon::PRIV(scrolly) -side left }
     1535                -command { grid configure $::tkcon::PRIV(scrolly) -column 0 }
    12591536        $m add radio -label "Right" -value right \
    12601537                -variable ::tkcon::OPT(scrollypos) \
    1261                 -command { pack config $::tkcon::PRIV(scrolly) -side right }
     1538                -command { grid configure $::tkcon::PRIV(scrolly) -column 2 }
    12621539    }
    12631540
     
    12761553        $m add command -label "Retrieve Latest Version" -underline 0 \
    12771554                -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        }
    12781585    }
    12791586}
     
    13321639    ##
    13331640    $w add separator
    1334     $w add cascade -label Packages -underline 0 -menu $w.pkg
    1335     set m $w.pkg
    1336     if {![winfo exists $m]} {
    1337         menu $m -tearoff no -disabledforeground $COLOR(disabled) \
    1338                 -postcommand [list ::tkcon::PkgMenu $m $app $type]
    1339     }
     1641    $w add command -label "Manage Packages" -underline 0 \
     1642        -command [list ::tkcon::InterpPkgs $app $type]
    13401643
    13411644    ## State Checkpoint/Revert
     
    13591662## with a list of all the applications that currently exist.
    13601663##
    1361 proc ::tkcon::PkgMenu {m app type} {
     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
    13621707    # just in case stuff has been added to the auto_path
    13631708    # we have to make sure that the errorInfo doesn't get screwed up
     
    13681713        unset __tkcon_error
    13691714    }
    1370     $m delete 0 end
     1715    # get all packages loaded into current interp
    13711716    foreach pkg [EvalAttached [list info loaded {}]] {
    1372         set loaded([lindex $pkg 1]) [package provide $pkg]
    1373     }
     1717        set pkg [lindex $pkg 1]
     1718        set loaded($pkg) [package provide $pkg]
     1719    }
     1720    # get all package names currently visible
    13741721    foreach pkg [lremove [EvalAttached {package names}] Tcl] {
    13751722        set version [EvalAttached [list package provide $pkg]]
     
    13771724            set loaded($pkg) $version
    13781725        } elseif {![info exists loaded($pkg)]} {
    1379             set loadable($pkg) [list package require $pkg]
    1380         }
    1381     }
     1726            set loadable($pkg) package
     1727        }
     1728    }
     1729    # get packages that are loaded in any interp
    13821730    foreach pkg [EvalAttached {info loaded}] {
    13831731        set pkg [lindex $pkg 1]
    13841732        if {![info exists loaded($pkg)] && ![info exists loadable($pkg)]} {
    1385             set loadable($pkg) [list load {} $pkg]
    1386         }
    1387     }
    1388     set npkg 0
     1733            set loadable($pkg) load
     1734        }
     1735    }
    13891736    foreach pkg [lsort -dictionary [array names loadable]] {
    13901737        foreach v [EvalAttached [list package version $pkg]] {
    1391             set brkcol [expr {([incr npkg]%16)==0}]
    1392             $m add command -label "Load $pkg ($v)" -command \
    1393                     "::tkcon::EvalOther [list $app] $type $loadable($pkg) $v" \
    1394                     -columnbreak $brkcol
    1395         }
    1396     }
    1397     if {[info exists loaded] && [info exists loadable]} {
    1398         $m add separator
     1738            $t.loadable insert end [list $pkg $v "($loadable($pkg))"]
     1739        }
    13991740    }
    14001741    foreach pkg [lsort -dictionary [array names loaded]] {
    1401         $m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled
    1402     }
     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
    14031769}
    14041770
     
    14141780
    14151781    $m delete 0 end
    1416     set cmd {::tkcon::Prompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
     1782    set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
    14171783    $m add radio -label {None (use local slave) } -accel Ctrl-1 \
    14181784            -variable ::tkcon::PRIV(app) \
     
    14211787    $m add separator
    14221788    $m add command -label "Foreign Tk Interpreters" -state disabled
    1423     foreach i [lsort [lremove [winfo interps] [array names tknames]]] {
     1789    foreach i [lsort [lremove [::send::interps] [array names tknames]]] {
    14241790        $m add radio -label $i -variable ::tkcon::PRIV(app) -value $i \
    14251791                -command "::tkcon::Attach [list $i] interp; $cmd"
     
    14571823proc ::tkcon::DisplayMenu m {
    14581824    $m delete 0 end
    1459     set cmd {::tkcon::Prompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
     1825    set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
    14601826
    14611827    $m add command -label "New Display" -command ::tkcon::NewDisplay
     
    14761842proc ::tkcon::SocketMenu m {
    14771843    $m delete 0 end
    1478     set cmd {::tkcon::Prompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
     1844    set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
    14791845
    14801846    $m add command -label "Create Connection" \
     
    15001866
    15011867    ## Same command as for ::tkcon::AttachMenu items
    1502     set cmd {::tkcon::Prompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
     1868    set cmd {::tkcon::RePrompt \n [::tkcon::CmdGet $::tkcon::PRIV(console)]}
    15031869
    15041870    set names [lsort [Namespaces ::]]
     
    15571923        ## Catch in case the namespace disappeared on us
    15581924        catch { ::tkcon::AttachNamespace [%W get [%W nearest %y]] }
    1559         ::tkcon::Prompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
     1925        ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
    15601926        destroy [winfo toplevel %W]
    15611927    }
     
    16852051#               appropriate interpreter
    16862052##
    1687 proc ::tkcon::Attach {{name <NONE>} {type slave}} {
     2053proc ::tkcon::Attach {{name <NONE>} {type slave} {ns {}}} {
    16882054    variable PRIV
    16892055    variable OPT
     2056    variable ATTACH
    16902057
    16912058    if {[llength [info level 0]] == 1} {
    16922059        # no args were specified, return the attach info instead
    1693         if {[string match {} $PRIV(appname)]} {
    1694             return [list [concat $PRIV(name) $OPT(exec)] $PRIV(apptype)]
    1695         } else {
    1696             return [list $PRIV(appname) $PRIV(apptype)]
    1697         }
     2060        return [AttachId]
    16982061    }
    16992062    set path [concat $PRIV(name) $OPT(exec)]
     
    17322095            set name [concat $path $name]
    17332096            set type slave
    1734         } elseif {[lsearch -exact [winfo interps] $name] > -1} {
     2097        } elseif {[lsearch -exact [::send::interps] $name] > -1} {
    17352098            if {[EvalSlave info exists tk_library] \
    17362099                    && [string match $name [EvalSlave tk appname]]} {
     
    17612124    # ARGS:     args    - the command and args to evaluate
    17622125    ##
     2126    set PRIV(namesp) ::
     2127    set namespOK 0
    17632128    switch -glob -- $type {
    17642129        slave {
     
    17742139                        ::tkcon::Slave $::tkcon::PRIV(app)
    17752140            }
     2141            set namespOK 1
    17762142        }
    17772143        sock* {
     
    17812147            # into the interpreter
    17822148            fconfigure $name -buffering line -blocking 0
    1783             fileevent $name readable ::tkcon::EvalSocketEvent
     2149            fileevent $name readable [list ::tkcon::EvalSocketEvent $name]
    17842150        }
    17852151        dpy:* -
     
    17872153            if {$OPT(nontcl)} {
    17882154                interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSlave
    1789                 set PRIV(namesp) ::
    17902155            } else {
    17912156                interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSend
     2157                set namespOK 1
    17922158            }
    17932159        }
     
    17972163        }
    17982164    }
    1799     if {[string match slave $type] || \
    1800             (!$OPT(nontcl) && [regexp {^(interp|dpy)} $type])} {
    1801         set PRIV(namesp) ::
    1802     }
    1803     set PRIV(StatusAttach) "$PRIV(app) ($PRIV(apptype))"
    1804     return
     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
    18052190}
    18062191
     
    18362221    }
    18372222    set PRIV(namesp) $name
    1838     set PRIV(StatusAttach) "$PRIV(app) $PRIV(namesp) ($PRIV(apptype))"
     2223    return [AttachId]
    18392224}
    18402225
     
    18522237        wm title $t "tkcon Create Socket"
    18532238        label $t.lhost -text "Host: "
    1854         entry $t.host -width 20
     2239        entry $t.host -width 16 -takefocus 1
    18552240        label $t.lport -text "Port: "
    1856         entry $t.port -width 4
    1857         button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1}
     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
    18582244        bind $t.host <Return> [list focus $t.port]
    18592245        bind $t.port <Return> [list focus $t.ok]
    18602246        bind $t.ok   <Return> [list $t.ok invoke]
    1861         grid $t.lhost $t.host $t.lport $t.port -sticky ew
    1862         grid $t.ok      -       -       -        -sticky ew
     2247        grid $t.lhost $t.host $t.lport $t.port $t.ok -sticky ew
     2248        grid configure $t.ok -padx 4 -pady 2
    18632249        grid columnconfig $t 1 -weight 1
    18642250        grid rowconfigure $t 1 -weight 1
    18652251        wm transient $t $PRIV(root)
     2252        wm group $t $PRIV(root)
    18662253        wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
    18672254                reqwidth $t]) / 2}]+[expr {([winfo \
    18682255                screenheight $t]-[winfo reqheight $t]) / 2}]
     2256        bind $t <Escape> [list destroy $t]
    18692257    }
    18702258    #$t.host delete 0 end
     
    19642352proc ::tkcon::MainInit {} {
    19652353    variable PRIV
     2354    variable OPT
    19662355
    19672356    if {![info exists PRIV(slaves)]} {
     
    19922381        lappend PRIV(slaves) $tmp
    19932382        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} }
    19942386        lappend PRIV(interps) [$tmp eval [list tk appname \
    19952387                "[tk appname] $tmp"]]
    1996         if {[info exist argv0]} {$tmp eval [list set argv0 $argv0]}
    1997         $tmp eval set argc $argc
    1998         $tmp eval [list set argv $argv]
     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]}
    19992391        $tmp eval [list namespace eval ::tkcon {}]
    20002392        $tmp eval [list set ::tkcon::PRIV(name) $tmp]
     
    20032395        $tmp alias ::tkcon::Destroy             ::tkcon::Destroy $tmp
    20042396        $tmp alias ::tkcon::New                 ::tkcon::New
     2397        $tmp alias ::tkcon::GetSlaveNum         ::tkcon::GetSlaveNum
    20052398        $tmp alias ::tkcon::Main                ::tkcon::InterpEval Main
    20062399        $tmp alias ::tkcon::Slave               ::tkcon::InterpEval
     
    20272420
    20282421        ## Slave interpreter exit request
    2029         if {[string match exit $OPT(slaveexit)]} {
    2030             ## Only exit if it specifically is stated to do so
     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
    20312426            uplevel 1 exit $args
    2032         }
    2033         ## Otherwise we will delete the slave interp and associated data
    2034         set name [InterpEval $slave]
    2035         set PRIV(interps) [lremove $PRIV(interps) [list $name]]
    2036         set PRIV(slaves)  [lremove $PRIV(slaves) [list $slave]]
    2037         interp delete $slave
    2038         StateCleanup $slave
    2039         return
     2427        } else {
     2428            ## Otherwise we will delete the slave interp and associated data
     2429            Destroy $slave
     2430        }
    20402431    }
    20412432
     
    20482439        variable PRIV
    20492440
    2050         if {[string match {} $slave]} {
     2441        # Just close on the last one
     2442        if {[llength $PRIV(interps)] == 1} { exit }
     2443        if {"" == $slave} {
    20512444            ## Main interpreter close request
    2052             if {[tk_dialog $PRIV(base).destroyme {Quit tkcon?} \
    2053                     {Closing the Main console will quit tkcon} \
    2054                     warning 0 "Don't Quit" "Quit tkcon"]} exit
     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"
    20552452        } else {
    20562453            ## Slave interpreter close request
    20572454            set name [InterpEval $slave]
    2058             set PRIV(interps) [lremove $PRIV(interps) [list $name]]
    2059             set PRIV(slaves)  [lremove $PRIV(slaves) [list $slave]]
    20602455            interp delete $slave
    20612456        }
     2457        set PRIV(interps) [lremove $PRIV(interps) [list $name]]
     2458        set PRIV(slaves)  [lremove $PRIV(slaves) [list $slave]]
    20622459        StateCleanup $slave
    2063         return
    2064     }
    2065 
    2066     ## We want to do a couple things before exiting...
    2067     if {[catch {rename ::exit ::tkcon::FinalExit} err]} {
    2068         puts stderr "tkcon might panic:\n$err"
    2069     }
    2070     proc ::exit args {
    2071         if {$::tkcon::OPT(usehistory)} {
    2072             if {[catch {open $::tkcon::PRIV(histfile) w} fid]} {
    2073                 puts stderr "unable to save history file:\n$fid"
    2074                 # pause a moment, because we are about to die finally...
    2075                 after 1000
    2076             } else {
    2077                 set max [::tkcon::EvalSlave history nextid]
    2078                 set id [expr {$max - $::tkcon::OPT(history)}]
    2079                 if {$id < 1} { set id 1 }
    2080                 ## FIX: This puts history in backwards!!
    2081                 while {($id < $max) && \
    2082                         ![catch {::tkcon::EvalSlave history event $id} cmd]} {
    2083                     if {[string compare {} $cmd]} {
    2084                         puts $fid "::tkcon::EvalSlave history add [list $cmd]"
     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
    20852485                    }
    2086                     incr id
     2486                    close $fid
    20872487                }
    2088                 close $fid
    2089             }
    2090         }
    2091         uplevel 1 ::tkcon::FinalExit $args
     2488            }
     2489            uplevel 1 ::tkcon::FinalExit $args
     2490        }
    20922491    }
    20932492
     
    20992498        variable PRIV
    21002499
    2101         if {[string match {} $slave]} {
     2500        if {[llength [info level 0]] == 1} {
     2501            # no args given
    21022502            return $PRIV(slaves)
    21032503        } elseif {[string match {[Mm]ain} $slave]} {
     
    21072507            return [interp eval $slave uplevel \#0 $args]
    21082508        } else {
    2109             return [interp eval $slave tk appname]
     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            }
    21102516        }
    21112517    }
    21122518
    21132519    proc ::tkcon::Interps {{ls {}} {interp {}}} {
    2114         if {[string match {} $interp]} { lappend ls {} [tk appname] }
     2520        if {[string match {} $interp]} {
     2521            lappend ls {} [tk appname]
     2522        }
    21152523        foreach i [interp slaves $interp] {
    21162524            if {[string compare {} $interp]} { set i "$interp $i" }
    21172525            if {[string compare {} [interp eval $i package provide Tk]]} {
    2118                 lappend ls $i [interp eval $i tk appname]
     2526                # beware safe interps with Tk
     2527                if {[catch {interp eval $i tk appname} name]} {
     2528                    set name {}
     2529                }
     2530                lappend ls $i $name
    21192531            } else {
    21202532                lappend ls $i {}
     
    21782590                error "No other Tk interpreters on $disp"
    21792591            }
    2180             send -displayof $dt [lindex $interps 0] [list info tclversion]
     2592            ::send::send -displayof $dt [lindex $interps 0] [list info tclversion]
    21812593        } err]} {
    21822594            global env
     
    24392851}
    24402852
    2441 ## ::tkcon::ErrorHighlight - magic error highlighting
     2853## ::tkcon::Highlight - magic highlighting
    24422854## beware: voodoo included
    24432855# ARGS:
    24442856##
    2445 proc ::tkcon::ErrorHighlight w {
     2857proc ::tkcon::Highlight {w type} {
    24462858    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
    24472894
    24482895    ## do voodoo here
     
    24762923            $w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
    24772924            $w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
    2478                     {[list edit -attach $app -type proc -find $what -- $cmd]}"
     2925                    {[list $OPT(edit) -attach $app -type proc -find $what -- $cmd]}"
    24792926        }
    24802927        set info [string range $info $c1 end]
     
    25052952            $w tag bind $tag <Leave> [list $w tag configure $tag -under 0]
    25062953            $w tag bind $tag <ButtonRelease-1> "if {!\$tkPriv(mouseMoved)} \
    2507                     {[list edit -attach $app -type proc -- $cmd]}"
    2508         }
     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
    25093282    }
    25103283}
     
    25163289##
    25173290proc tkcon {cmd args} {
     3291    variable ::tkcon::PRIV
     3292    variable ::tkcon::OPT
    25183293    global errorInfo
    25193294
     
    25233298            if {[llength $args]} {
    25243299                if {[regexp {^[1-9][0-9]*$} $args]} {
    2525                     set ::tkcon::OPT(buffer) $args
     3300                    set OPT(buffer) $args
    25263301                    # catch in case the console doesn't exist yet
    2527                     catch {::tkcon::ConstrainBuffer $::tkcon::PRIV(console) \
    2528                             $::tkcon::OPT(buffer)}
     3302                    catch {::tkcon::ConstrainBuffer $PRIV(console) \
     3303                            $OPT(buffer)}
    25293304                } else {
    25303305                    return -code error "buffer must be a valid integer"
    25313306                }
    25323307            }
    2533             return $::tkcon::OPT(buffer)
     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)
    25343320        }
    25353321        bg* {
     
    25443330        cons* {
    25453331            ## 'console' - passes the args to the text widget of the console.
    2546             set result [uplevel 1 $::tkcon::PRIV(console) $args]
    2547             ::tkcon::ConstrainBuffer $::tkcon::PRIV(console) \
    2548                     $::tkcon::OPT(buffer)
     3332            set result [uplevel 1 $PRIV(console) $args]
     3333            ::tkcon::ConstrainBuffer $PRIV(console) \
     3334                    $OPT(buffer)
    25493335            return $result
    25503336        }
     
    25593345            set old [bind TkConsole <<TkCon_Eval>>]
    25603346            bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
    2561             set w $::tkcon::PRIV(console)
     3347            set w $PRIV(console)
    25623348            # Make sure to move the limit to get the right data
    25633349            $w mark set insert end
     
    25703356            return $line
    25713357        }
     3358        exp* {
     3359            ::tkcon::Expect [lindex $args 0]
     3360        }
    25723361        getc* {
    25733362            ## 'getcommand' a replacement for [gets stdin]
     
    25793368            set old [bind TkConsole <<TkCon_Eval>>]
    25803369            bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
    2581             set w $::tkcon::PRIV(console)
     3370            set w $PRIV(console)
    25823371            # Make sure to move the limit to get the right data
    25833372            $w mark set insert end
     
    26023391                return -code error "wrong # args: should be \"tkcon gets\""
    26033392            }
    2604             set t $::tkcon::PRIV(base).gets
     3393            set t $PRIV(base).gets
    26053394            if {![winfo exists $t]} {
    26063395                toplevel $t
     
    26233412                grid columnconfig $t 0 -weight 1
    26243413                grid rowconfig    $t 1 -weight 1
    2625                 wm transient $t $::tkcon::PRIV(root)
     3414                wm transient $t $PRIV(root)
    26263415                wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
    26273416                        reqwidth $t]) / 2}]+[expr {([winfo \
     
    26483437                }
    26493438            } else {
    2650                 set info $::tkcon::PRIV(errorInfo)
     3439                set info $PRIV(errorInfo)
    26513440            }
    26523441            if {[string match {} $info]} { set info "errorInfo empty" }
    26533442            ## If args is empty, the -attach switch just ignores it
    2654             edit -attach $args -type error -- $info
     3443            $OPT(edit) -attach $args -type error -- $info
    26553444        }
    26563445        fi* {
    26573446            ## 'find' string
    2658             ::tkcon::Find $::tkcon::PRIV(console) $args
     3447            ::tkcon::Find $PRIV(console) $args
    26593448        }
    26603449        fo* {
    26613450            ## 'font' ?fontname? - gets/sets the font of the console
    26623451            if {[llength $args]} {
    2663                 if {[info exists ::tkcon::PRIV(console)] && \
    2664                         [winfo exists $::tkcon::PRIV(console)]} {
    2665                     $::tkcon::PRIV(console) config -font $args
    2666                     set ::tkcon::OPT(font) [$::tkcon::PRIV(console) cget -font]
     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]
    26673456                } else {
    2668                     set ::tkcon::OPT(font) $args
     3457                    set OPT(font) $args
    26693458                }
    26703459            }
    2671             return $::tkcon::OPT(font)
     3460            return $OPT(font)
    26723461        }
    26733462        hid* - with* {
    26743463            ## 'hide' 'withdraw' - hides the console.
    2675             wm withdraw $::tkcon::PRIV(root)
     3464            if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} {
     3465                wm withdraw $PRIV(root)
     3466            }
    26763467        }
    26773468        his* {
     
    26853476        ico* {
    26863477            ## 'iconify' - iconifies the console with 'iconify'.
    2687             wm iconify $::tkcon::PRIV(root)
     3478            if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} {
     3479                wm iconify $PRIV(root)
     3480            }
    26883481        }
    26893482        mas* - eval {
     
    27353528        sh* - dei* {
    27363529            ## 'show|deiconify' - deiconifies the console.
    2737             wm deiconify $::tkcon::PRIV(root)
    2738             raise $::tkcon::PRIV(root)
    2739             focus -force $::tkcon::PRIV(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)
    27403541        }
    27413542        ti* {
    27423543            ## 'title' ?title? - gets/sets the console's title
    27433544            if {[llength $args]} {
    2744                 return [wm title $::tkcon::PRIV(root) [join $args]]
     3545                return [wm title $PRIV(root) [join $args]]
    27453546            } else {
    2746                 return [wm title $::tkcon::PRIV(root)]
     3547                return [wm title $PRIV(root)]
    27473548            }
    27483549        }
     
    27543555            set slaveVar  [lindex $args 1]
    27553556            if {[info exists $masterVar]} {
    2756                 interp eval $::tkcon::OPT(exec) \
     3557                interp eval $OPT(exec) \
    27573558                        [list set $slaveVar [set $masterVar]]
    27583559            } else {
    2759                 catch {interp eval $::tkcon::OPT(exec) [list unset $slaveVar]}
    2760             }
    2761             interp eval $::tkcon::OPT(exec) \
     3560                catch {interp eval $OPT(exec) [list unset $slaveVar]}
     3561            }
     3562            interp eval $OPT(exec) \
    27623563                    [list trace variable $slaveVar rwu \
    2763                     [list tkcon set $masterVar $::tkcon::OPT(exec)]]
     3564                    [list tkcon set $masterVar $OPT(exec)]]
    27643565            return
    27653566        }
    27663567        v* {
    2767             return $::tkcon::PRIV(version)
     3568            return $PRIV(version)
    27683569        }
    27693570        default {
     
    29173718        toplevel $w
    29183719        wm withdraw $w
    2919         if {[string length $word] > 12} {
    2920             wm title $w "tkcon Edit: [string range $word 0 9]..."
     3720        if {[string length $word] > 20} {
     3721            wm title $w "[string range $word 0 16]... - tkcon Edit"
    29213722        } else {
    2922             wm title $w "tkcon Edit: $word"
    2923         }
    2924 
    2925         text $w.text -wrap none \
     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 \
    29263732                -xscrollcommand [list $w.sx set] \
    29273733                -yscrollcommand [list $w.sy set] \
     
    29303736                -insertbackground $::tkcon::COLOR(cursor) \
    29313737                -font $::tkcon::OPT(font)
     3738        catch {$w.text configure -undo 1}
    29323739        scrollbar $w.sx -orient h -takefocus 0 -bd 1 \
    29333740                -command [list $w.text xview]
     
    29903797            $w.text insert 1.0 \
    29913798                    [::tkcon::EvalOther $app $type dump proc [list $word]]
     3799            after idle [::tkcon::Highlight $w.text tcl]
    29923800        }
    29933801        var*    {
    29943802            $w.text insert 1.0 \
    29953803                    [::tkcon::EvalOther $app $type dump var [list $word]]
     3804            after idle [::tkcon::Highlight $w.text tcl]
    29963805        }
    29973806        file    {
     
    30053814            }
    30063815            ]]
     3816            after idle [::tkcon::Highlight $w.text \
     3817                            [string trimleft [file extension $word] .]]
    30073818        }
    30083819        error*  {
    30093820            $w.text insert 1.0 [join $args \n]
    3010             ::tkcon::ErrorHighlight $w.text
     3821            after idle [::tkcon::Highlight $w.text error]
    30113822        }
    30123823        default {
     
    30273838# ARGS: any number of strings to output to stdout
    30283839##
    3029 proc echo args { puts [concat $args] }
     3840proc echo args { puts stdout [concat $args] }
    30303841
    30313842## clear - clears the buffer of the console (not the history though)
     
    31563967                foreach var [lsort $vars] {
    31573968                    if {[uplevel 1 [list info locals $var]] == ""} {
    3158                         # use the proper scope of the var, but
    3159                         # namespace which won't id locals correctly
    3160                         set var [uplevel 1 \
     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 \
    31613972                                [list namespace which -variable $var]]
     3973                        if {$new != ""} {
     3974                            set var $new
     3975                        }
    31623976                    }
    31633977                    upvar 1 $var v
     
    31663980                        append res "array set [list $var] \{\n"
    31673981                        if {[array size v]} {
    3168                             foreach i [lsort [array names v $fltr]] {
     3982                            foreach i \
     3983                                    [lsort -dictionary [array names v $fltr]] {
    31693984                                upvar 0 v\($i\) __a
    31703985                                if {[array exists __a]} {
     
    31793994                            ## empty array
    31803995                            append res "    empty array\n"
    3181                             append nst "unset [list $var](empty)\n"
     3996                            if {$var == ""} {
     3997                                append nst "unset (empty)\n"
     3998                            } else {
     3999                                append nst "unset [list $var](empty)\n"
     4000                            }
    31824001                        }
    31834002                        append res "\}\n$nst"
     
    35604379            set max 4
    35614380            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 }
    35624384            ## idebug trace could be used here
    3563             proc $name args "
     4385            $proccmd $name args "
    35644386            for {set i \[info level\]; set max \[expr \[info level\]-$max\]} {
    35654387                \$i>=\$max && !\[catch {uplevel \#\$i info level 0} info\]
     
    35994421            }
    36004422            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            }
    36014427            uplevel 1 [list trace $opt $name $type $args]
    36024428        }
     
    37414567    }
    37424568    set sep [string trim [file join . .] .]
    3743     if {![llength $args]} { set args . }
     4569    if {![llength $args]} { set args [list [pwd]] }
    37444570    if {$::tcl_version >= 8.3} {
    37454571        # Newer glob args allow safer dir processing.  The user may still
     
    37774603    if {$s(long)} {
    37784604        set old [clock scan {1 year ago}]
    3779         set fmt "%s%9d %s %s\n"
     4605        set fmt "%s%9ld %s %s\n"
    37804606        foreach o $out {
    37814607            set d [lindex $o 0]
     
    39674793
    39684794    set cmd [lindex $args 0]
    3969     if {[regexp "^namespace\[ \t\n\]+inscope" $cmd] && [llength $cmd] == 4} {
     4795    if {[regexp "^:*namespace\[ \t\n\]+inscope" $cmd] \
     4796            && [llength $cmd] == 4} {
    39704797        set arglist [lrange $args 1 end]
    39714798        set ret [catch {uplevel 1 $cmd $arglist} result]
     
    40294856                set errorCode $savedErrorCode
    40304857                set errorInfo $savedErrorInfo
    4031                 return [uplevel 1 exec $new [lrange $args 1 end]]
     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                }
    40324863                #return [uplevel exec >&@stdout <@stdin $new [lrange $args 1 end]]
    40334864            }
     
    40634894                    canvas checkbutton clipboard destroy \
    40644895                    entry event focus font frame grab grid image \
    4065                     label listbox lower menu menubutton message \
    4066                     option pack place radiobutton raise \
     4896                    label labelframe listbox lower menu menubutton message \
     4897                    option pack panedwindow place radiobutton raise \
    40674898                    scale scrollbar selection send spinbox \
    40684899                    text tk tkwait toplevel winfo wm
     
    41124943
    41134944    ## Get all Text bindings into TkConsole
    4114     foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] }       
     4945    foreach ev [bind Text] { bind TkConsole $ev [bind Text $ev] }
    41154946    ## We really didn't want the newline insertion
    41164947    bind TkConsole <Control-Key-o> {}
     
    41204951        <<TkCon_Exit>>          <Control-q>
    41214952        <<TkCon_New>>           <Control-N>
     4953        <<TkCon_NewTab>>        <Control-T>
     4954        <<TkCon_NextTab>>       <Control-Key-Tab>
     4955        <<TkCon_PrevTab>>       <Control-Shift-Key-Tab>
    41224956        <<TkCon_Close>>         <Control-w>
    41234957        <<TkCon_About>>         <Control-A>
     
    41594993    bind $PRIV(root) <<TkCon_Exit>>     exit
    41604994    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 }
    41614998    bind $PRIV(root) <<TkCon_Close>>    { ::tkcon::Destroy }
    41624999    bind $PRIV(root) <<TkCon_About>>    { ::tkcon::About }
     
    41655002    bind $PRIV(root) <<TkCon_Slave>>    {
    41665003        ::tkcon::Attach {}
    4167         ::tkcon::Prompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
     5004        ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
    41685005    }
    41695006    bind $PRIV(root) <<TkCon_Master>>   {
     
    41735010            ::tkcon::Attach Main
    41745011        }
    4175         ::tkcon::Prompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
     5012        ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
    41765013    }
    41775014    bind $PRIV(root) <<TkCon_Main>>     {
    41785015        ::tkcon::Attach Main
    4179         ::tkcon::Prompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
     5016        ::tkcon::RePrompt "\n" [::tkcon::CmdGet $::tkcon::PRIV(console)]
    41805017    }
    41815018    bind $PRIV(root) <<TkCon_Popup>> {
     
    44575294
    44585295    bind TkConsolePost <KeyPress> {
    4459         if {$::tkcon::OPT(lightcmd) && [string compare {} %A]} {
    4460             ::tkcon::TagProc %W
    4461         }
    4462         set ::tkcon::PRIV(StatusCursor) [%W index insert]
     5296        if {[winfo exists "%W"]} {
     5297            if {$::tkcon::OPT(lightcmd) && [string compare {} %A]} {
     5298                ::tkcon::TagProc %W
     5299            }
     5300            set ::tkcon::PRIV(StatusCursor) [%W index insert]
     5301        }
    44635302    }
    44645303
     
    44775316proc ::tkcon::PopupMenu {X Y} {
    44785317    variable PRIV
     5318    variable OPT
    44795319
    44805320    set w $PRIV(console)
     
    45345374    if {[lsearch $type proc] != -1} {
    45355375        $PRIV(context) add command -label "View Procedure" \
    4536                 -command [list edit -attach $app -type proc -- $word]
     5376                -command [list $OPT(edit) -attach $app -type proc -- $word]
    45375377    }
    45385378    if {[lsearch $type var] != -1} {
    45395379        $PRIV(context) add command -label "View Variable" \
    4540                 -command [list edit -attach $app -type var -- $word]
     5380                -command [list $OPT(edit) -attach $app -type var -- $word]
    45415381    }
    45425382    if {[lsearch $type file] != -1} {
    45435383        $PRIV(context) add command -label "View File" \
    4544                 -command [list edit -attach $app -type file -- $word]
     5384                -command [list $OPT(edit) -attach $app -type file -- $word]
    45455385    }
    45465386    tk_popup $PRIV(context) $X $Y
     
    46635503        return
    46645504    }
     5505    variable EXP
     5506    if {[info exists EXP(spawn_id)]} {
     5507        exp_send -i $EXP(spawn_id) -- $s
     5508        return
     5509    }
    46655510    if {[$w comp insert < limit]} {
    46665511        $w mark set insert end
     
    47995644}
    48005645
     5646## ::tkcon::ExpandXotcl - expand an xotcl method name based on $str
     5647# ARGS: str     - partial proc name to expand
     5648# Calls:        ::tkcon::ExpandBestMatch
     5649# Returns:      list containing longest unique match followed by all the
     5650#               possible further matches
     5651##
     5652proc ::tkcon::ExpandXotcl str {
     5653    # in a first step, get the cmd to check, if we should handle subcommands
     5654    set cmd [::tkcon::CmdGet $::tkcon::PRIV(console)]
     5655    # Only do the xotcl magic if there are two cmds and xotcl is loaded
     5656    if {[llength $cmd] != 2
     5657        || ![EvalAttached [list info exists ::xotcl::version]]} {
     5658        return
     5659    }
     5660    set obj [lindex $cmd 0]
     5661    set sub [lindex $cmd 1]
     5662    set match [EvalAttached [list $obj info methods $sub*]]
     5663    if {[llength $match] > 1} {
     5664        regsub -all {([^\\]) } [ExpandBestMatch $match $str] {\1\\ } str
     5665        set match [linsert $match 0 $str]
     5666    } else {
     5667        regsub -all {([^\\]) } $match {\1\\ } match
     5668    }
     5669    return $match
     5670}
     5671
    48015672## ::tkcon::ExpandVariable - expand a tcl variable name based on $str
    48025673# ARGS: str     - partial tcl var name to expand
     
    48135684            foreach var $match {lappend vars $ary\($var\)}
    48145685            return $vars
    4815         } else {set match $ary\($match\)}
     5686        } elseif {[llength $match] == 1} {
     5687            set match $ary\($match\)
     5688        }
    48165689        ## Space transformation avoided for array names.
    48175690    } else {
     
    48905763# - Other (e.g. bind, bindtag, image), which need their own function.
    48915764#
    4892 ## These functions courtesy Jan Nijtmans (nijtmans@nici.kun.nl)
     5765## These functions courtesy Jan Nijtmans
    48935766##
    4894 if {[string compare [info command tk] tk]} {
     5767if {![llength [info commands tk]]} {
    48955768    proc tk {option args} {
    48965769        if {![string match app* $option]} {
     
    49015774}
    49025775
    4903 if {[string compare [info command toplevel] toplevel]} {
     5776if {![llength [info command toplevel]]} {
    49045777    proc toplevel {name args} {
    4905         eval frame $name $args
    4906         pack $name
     5778        eval [linsert $args 0 frame $name]
     5779        grid $name -sticky news
    49075780    }
    49085781}
     
    49465819        $i alias . ::tkcon::SafeWindow $i {}
    49475820        foreach var {tk_version tk_patchLevel tk_library auto_path} {
    4948             $i eval set $var [list [set $var]]
     5821            $i eval [list set $var [set $var]]
    49495822        }
    49505823        $i eval {
     
    51846057    if {[string compare $file ""]} {
    51856058        package require http 2
     6059        set headers {}
     6060        if {[info exists PRIV(proxy)]} {
     6061            ::http::config -proxyfilter [namespace origin RetrieveFilter]
     6062            if {[lindex $PRIV(proxy) 1] != {}} {
     6063                set headers [RetrieveAuthentication]
     6064            }
     6065        }
     6066        set token [::http::geturl $PRIV(HEADURL) \
     6067                -headers $headers -timeout 30000]
    51866068        set token [::http::geturl $PRIV(HEADURL) -timeout 30000]
    51876069        ::http::wait $token
    51886070        set code [catch {
    5189             if {[::http::status $token] == "ok"} {
     6071            set ncode [::http::ncode $token]
     6072            if {$ncode != 200} {
     6073                return "expected http return code 200, received $ncode"
     6074            }
     6075            set status [::http::status $token]
     6076            if {$status == "ok"} {
     6077                set data [::http::data $token]
     6078                regexp {Id: tkcon.tcl,v (\d+\.\d+)} $data -> rcsVersion
     6079                regexp {VERSION\s+"(\d+\.\d+[^\"]*)"} $data -> tkconVersion
     6080                if {(![info exists rcsVersion] || ![info exists tkconVersion])
     6081                    && [tk_messageBox -type yesno -icon warning \
     6082                            -parent $PRIV(root) \
     6083                            -title "Invalid tkcon source code" \
     6084                            -message "Source code retrieved does not appear\
     6085                        to be correct.\nContinue with save to \"$file\"?"] \
     6086                        == "no"} {
     6087                    return "invalid tkcon source code retrieved"
     6088                }
    51906089                set fid [open $file w]
    51916090                # We don't want newline mode to change
    51926091                fconfigure $fid -translation binary
    5193                 set data [::http::data $token]
    51946092                puts -nonewline $fid $data
    51956093                close $fid
    5196                 regexp {Id: tkcon.tcl,v (\d+\.\d+)} $data -> rcsVersion
    5197                 regexp {version\s+(\d+\.\d[^\n]*)} $data -> tkconVersion
     6094            } else {
     6095                return "expected http status ok, received $status"
    51986096            }
    51996097        } err]
    52006098        ::http::cleanup $token
    5201         if {$code} {
     6099        if {$code == 2} {
     6100            tk_messageBox -type ok -icon info -parent $PRIV(root) \
     6101                    -title "Failed to retrieve source" \
     6102                    -message "Failed to retrieve latest tkcon source:\n$err"
     6103        } elseif {$code} {
    52026104            return -code error $err
    5203         } elseif {[tk_messageBox -type yesno -icon info -parent $PRIV(root) \
    5204                 -title "Retrieved tkcon v$tkconVersion, RCS $rcsVersion" \
    5205                 -message "Successfully retrieved tkcon v$tkconVersion,\
    5206                 RCS $rcsVersion.  Shall I resource (not restart) this\
    5207                 version now?"] == "yes"} {
    5208             set PRIV(SCRIPT) $file
    5209             set PRIV(version) $tkconVersion.$rcsVersion
    5210             ::tkcon::Resource
     6105        } else {
     6106            if {![info exists rcsVersion]}   { set rcsVersion   "UNKNOWN" }
     6107            if {![info exists tkconVersion]} { set tkconVersion "UNKNOWN" }
     6108            if {[tk_messageBox -type yesno -icon info -parent $PRIV(root) \
     6109                    -title "Retrieved tkcon v$tkconVersion, RCS $rcsVersion" \
     6110                    -message "Successfully retrieved tkcon v$tkconVersion,\
     6111                    RCS $rcsVersion.  Shall I resource (not restart) this\
     6112                    version now?"] == "yes"} {
     6113                set PRIV(SCRIPT) $file
     6114                set PRIV(version) $tkconVersion.$rcsVersion
     6115                ::tkcon::Resource
     6116            }
     6117        }
     6118    }
     6119}
     6120
     6121## 'send' package that handles multiple communication variants
     6122##
     6123# Try using Tk send first, then look for a winsend interp,
     6124# then try dde and finally have a go at comm
     6125namespace eval ::send {}
     6126proc ::send::send {args} {
     6127    set winfoInterpCmd [list ::winfo interps]
     6128    array set opts [list displayof {} async 0]
     6129    while {[string match -* [lindex $args 0]]} {
     6130        switch -exact -- [lindex $args 0] {
     6131            -displayof {
     6132                set opts(displayof) [Pop args 1]
     6133                lappend winfoInterpCmd -displayof $opts(displayof)
     6134            }
     6135            -async     { set opts(async) 1 }
     6136            -- { Pop args ; break }
     6137            default {
     6138                return -code error "bad option \"[lindex $args 0]\":\
     6139                    should be -displayof, -async or --"
     6140            }
     6141        }
     6142        Pop args
     6143    }
     6144    set app [Pop args]
     6145
     6146    if {[llength [info commands ::winfo]]
     6147        && [lsearch -exact [eval $winfoInterpCmd] $app] > -1} {
     6148        set cmd [list ::send]
     6149        if {$opts(async) == 1} {lappend cmd -async}
     6150        if {$opts(displayof) != {}} {lappend cmd -displayof $opts(displayof)}
     6151        lappend cmd $app
     6152        eval $cmd $args
     6153    } elseif {[llength [info commands ::winsend]]
     6154              && [lsearch -exact [::winsend interps] $app] > -1} {
     6155        eval [list ::winsend send $app] $args
     6156    } elseif {[llength [info commands ::dde]]
     6157              && [lsearch -exact [dde services TclEval {}] \
     6158                      [list TclEval $app]] > -1} {
     6159        eval [list ::dde eval $app] $args
     6160    } elseif {[package provide comm] != {}
     6161              && [regexp {^[0-9]+$} [lindex $app 0]]} {
     6162        #if {$opts(displayof) != {} && [llength $app] == 1} {
     6163        #    lappend app $opts(displayof)
     6164        #}
     6165        eval [list ::comm::comm send $app] $args
     6166    } else {
     6167        return -code error "bad interp: \"$app\" could not be found"
     6168    }
     6169}
     6170
     6171proc ::send::interps {args} {
     6172    set winfoInterpCmd [list ::winfo interps]
     6173    array set opts [list displayof {}]
     6174    while {[string match -* [lindex $args 0]]} {
     6175        switch -exact -- [lindex $args 0] {
     6176            -displayof {
     6177                set opts(displayof) [Pop args 1]
     6178                lappend winfoInterpCmd -displayof $opts(displayof)
     6179            }
     6180            --         { Pop args ; break }
     6181            default {
     6182                return -code error "bad option \"[lindex $args 0]\":\
     6183                    should be -displayof or --"
     6184            }
     6185        }
     6186        Pop args
     6187    }
     6188
     6189    set interps {}
     6190    if {[llength [info commands ::winfo]]} {
     6191        set interps [concat $interps [eval $winfoInterpCmd]]
     6192    }
     6193    if {[llength [info commands ::winsend]]} {
     6194        set interps [concat $interps [::winsend interps]]
     6195    }
     6196    if {[llength [info commands ::dde]]} {
     6197        set servers {}
     6198        foreach server [::dde services TclEval {}] {
     6199            lappend servers [lindex $server 1]
     6200        }
     6201        set interps [concat $interps $servers]
     6202    }
     6203    if {[package provide comm] != {}} {
     6204        set interps [concat $interps [::comm::comm interps]]
     6205    }
     6206    return $interps
     6207}
     6208
     6209proc ::send::appname {args} {
     6210    set appname {}
     6211    if {[llength [info commands ::tk]]} {
     6212        set appname [eval ::tk appname $args]
     6213    }
     6214    if {[llength [info commands ::winsend]]} {
     6215        set appname [concat $appname [eval ::winsend appname $args]]
     6216    }
     6217    if {[llength [info commands ::dde]]} {
     6218        set appname [concat $appname [eval ::dde servername $args]]
     6219    }
     6220    # comm? can set port num and local/global interface.
     6221    return [lsort -unique $appname]
     6222}
     6223
     6224proc ::send::Pop {varname {nth 0}} {
     6225    upvar $varname args
     6226    set r [lindex $args $nth]
     6227    set args [lreplace $args $nth $nth]
     6228    return $r
     6229}
     6230##
     6231## end 'send' pacakge
     6232
     6233## special case 'tk appname' in Tcl plugin
     6234if {$::tkcon::PRIV(WWW)} {
     6235    rename tk ::tkcon::_tk
     6236    proc tk {cmd args} {
     6237        if {$cmd == "appname"} {
     6238            return "tkcon/WWW"
     6239        } else {
     6240            return [uplevel 1 ::tkcon::_tk [list $cmd] $args]
    52116241        }
    52126242    }
     
    52166246## Meant primarily for my development of this program.  It follows
    52176247## links until the ultimate source is found.
    5218 ##
    5219 set ::tkcon::PRIV(SCRIPT) [info script]
    5220 if {!$::tkcon::PRIV(WWW) && [string compare $::tkcon::PRIV(SCRIPT) {}]} {
    5221     # we use a catch here because some wrap apps choke on 'file type'
    5222     # because TclpLstat wasn't wrappable until 8.4.
    5223     catch {
    5224         while {[string match link [file type $::tkcon::PRIV(SCRIPT)]]} {
    5225             set link [file readlink $::tkcon::PRIV(SCRIPT)]
    5226             if {[string match relative [file pathtype $link]]} {
    5227                 set ::tkcon::PRIV(SCRIPT) \
    5228                         [file join [file dirname $::tkcon::PRIV(SCRIPT)] $link]
    5229             } else {
    5230                 set ::tkcon::PRIV(SCRIPT) $link
    5231             }
    5232         }
    5233         catch {unset link}
    5234         if {[string match relative [file pathtype $::tkcon::PRIV(SCRIPT)]]} {
    5235             set ::tkcon::PRIV(SCRIPT) [file join [pwd] $::tkcon::PRIV(SCRIPT)]
    5236         }
    5237     }
    5238 }
    5239 
     6248##
    52406249proc ::tkcon::Resource {} {
    52416250    uplevel \#0 {
     
    52466255}
    52476256
    5248 ## Initialize only if we haven't yet
     6257## Initialize only if we haven't yet, and do other stuff that prepares to
     6258## run.  It only actually inits (and runs) tkcon if it is the main script.
    52496259##
    5250 if {![info exists ::tkcon::PRIV(root)] || \
    5251         ![winfo exists $::tkcon::PRIV(root)]} {
    5252     ::tkcon::Init
    5253 }
     6260proc ::tkcon::AtSource {} {
     6261    variable PRIV
     6262
     6263    # the info script assumes we always call this while being sourced
     6264    set PRIV(SCRIPT) [info script]
     6265    if {!$PRIV(WWW) && [string length $PRIV(SCRIPT)]} {
     6266        if {[info tclversion] >= 8.4} {
     6267            set PRIV(SCRIPT) [file normalize $PRIV(SCRIPT)]
     6268        } else {
     6269            # we use a catch here because some wrap apps choke on 'file type'
     6270            # because TclpLstat wasn't wrappable until 8.4.
     6271            catch {
     6272                while {[string match link [file type $PRIV(SCRIPT)]]} {
     6273                    set link [file readlink $PRIV(SCRIPT)]
     6274                    if {[string match relative [file pathtype $link]]} {
     6275                        set PRIV(SCRIPT) \
     6276                            [file join [file dirname $PRIV(SCRIPT)] $link]
     6277                    } else {
     6278                        set PRIV(SCRIPT) $link
     6279                    }
     6280                }
     6281                catch {unset link}
     6282                if {[string match relative [file pathtype $PRIV(SCRIPT)]]} {
     6283                    set PRIV(SCRIPT) [file join [pwd] $PRIV(SCRIPT)]
     6284                }
     6285            }
     6286        }
     6287    }
     6288    # normalize argv0 if it was tkcon to ensure that we'll be able
     6289    # to load slaves correctly.
     6290    if {[info exists ::argv0] && [info script] == $::argv0} {
     6291        set ::argv0 $PRIV(SCRIPT)
     6292    }
     6293
     6294    if {(![info exists PRIV(root)] || ![winfo exists $PRIV(root)]) \
     6295            && (![info exists ::argv0] || $PRIV(SCRIPT) == $::argv0)} {
     6296        global argv
     6297        if {[info exists argv]} {
     6298            eval ::tkcon::Init $argv
     6299        } else {
     6300            ::tkcon::Init
     6301        }
     6302    }
     6303}
     6304tkcon::AtSource
     6305
     6306package provide tkcon $::tkcon::VERSION
Note: See TracChangeset for help on using the changeset viewer.