From 29768c1211d3b5e58a3160b7223fe6b011c0ae45 Mon Sep 17 00:00:00 2001 From: Jeff Hobbs Date: Thu, 12 Feb 2004 20:35:22 +0000 Subject: [PATCH] Show Attach info in tab text, maintain namespace attachment between console switches. --- ChangeLog | 4 ++- tkcon.tcl | 73 +++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 50 insertions(+), 27 deletions(-) diff --git a/ChangeLog b/ChangeLog index 8269fce..06b24de 100644 --- a/ChangeLog +++ b/ChangeLog @@ -2,7 +2,9 @@ * tkcon.tcl (::tkcon::InitUI): check existence of tcl_platform(os) as it doesn't exist in the Tcl plugin. - + Show Attach info in tab text, maintain namespace attachment + between console switches. + 2004-02-05 Jeff Hobbs * tkcon.tcl: brought code back to 8.0 compatability. diff --git a/tkcon.tcl b/tkcon.tcl index c76e7d4..a252894 100755 --- a/tkcon.tcl +++ b/tkcon.tcl @@ -139,7 +139,7 @@ proc ::tkcon::Init {args} { lightbrace 1 lightcmd 1 maineval {} - maxmenu 15 + maxmenu 18 nontcl 0 prompt1 {ignore this, it's set below} rows 20 @@ -553,7 +553,6 @@ proc ::tkcon::InitUI {title} { variable OPT variable PRIV variable COLOR - variable ATTACH set root $PRIV(root) if {[string match . $root]} { set w {} } else { set w [toplevel $root] } @@ -567,17 +566,13 @@ proc ::tkcon::InitUI {title} { set PRIV(statusbar) [set sbar [frame $w.fstatus]] set PRIV(tabframe) [frame $sbar.tabs] - label $sbar.attach -relief sunken -bd 1 -anchor w \ - -textvariable ::tkcon::PRIV(StatusAttach) - label $sbar.cursor -relief sunken -bd 1 -anchor w -width 6 \ + label $sbar.cursor -relief sunken -bd 1 -anchor e -width 6 \ -textvariable ::tkcon::PRIV(StatusCursor) set padx [expr {![info exists ::tcl_platform(os)] || ![string match "Windows CE" $::tcl_platform(os)]}] - grid $sbar.tabs $sbar.attach $sbar.cursor -sticky news -padx $padx + grid $sbar.tabs $sbar.cursor -sticky ew -padx $padx grid configure $sbar.tabs -sticky nsw grid columnconfigure $sbar 0 -weight 1 - grid columnconfigure $sbar 1 -weight 0 - grid columnconfigure $sbar 2 -weight 0 ## Create console tab set con [InitTab $w] @@ -631,6 +626,7 @@ proc ::tkcon::InitTab {w} { variable OPT variable PRIV variable COLOR + variable ATTACH # text console set con $w.tab[incr PRIV(uid)] @@ -693,8 +689,9 @@ proc ::tkcon::InitTab {w} { $con tag configure blink -background $COLOR(blink) $con tag configure find -background $COLOR(blink) + set ATTACH($con) [Attach] set rb [radiobutton $PRIV(tabframe).cb[winfo name $con] \ - -text [string totitle [winfo name $con]] \ + -textvariable ::tkcon::ATTACH($con) \ -selectcolor white -relief sunken \ -indicatoron 0 -padx 0 -pady 0 -bd 1 \ -variable ::tkcon::PRIV(curtab) -value $con \ @@ -779,13 +776,17 @@ proc ::tkcon::DeleteTab {{con {}} {slave {}}} { if {$con == ""} { set con $PRIV(console) } + catch {unset ATTACH($con)} set curtab [lsearch -exact $PRIV(tabs) $con] set nexttab [expr {$curtab + 1}] if {$nexttab >= $numtabs} { set nexttab 0 } + set nexttab [lindex $PRIV(tabs) $nexttab] + # splice out current tab + set PRIV(tabs) [lreplace $PRIV(tabs) $curtab $curtab] - GotoTab [lindex $PRIV(tabs) $nexttab] + GotoTab $nexttab if {$slave != ""} { interp delete $slave @@ -1947,17 +1948,14 @@ proc ::tkcon::Find {w str args} { # Results: ::tkcon::EvalAttached is recreated to evaluate in the # appropriate interpreter ## -proc ::tkcon::Attach {{name } {type slave}} { +proc ::tkcon::Attach {{name } {type slave} {ns {}}} { variable PRIV variable OPT + variable ATTACH if {[llength [info level 0]] == 1} { # no args were specified, return the attach info instead - if {[string match {} $PRIV(appname)]} { - return [list [concat $PRIV(name) $OPT(exec)] $PRIV(apptype)] - } else { - return [list $PRIV(appname) $PRIV(apptype)] - } + return [AttachId] } set path [concat $PRIV(name) $OPT(exec)] @@ -2023,6 +2021,8 @@ proc ::tkcon::Attach {{name } {type slave}} { ## ensure evaluation occurs in the right interp. # ARGS: args - the command and args to evaluate ## + set PRIV(namesp) :: + set namespOK 0 switch -glob -- $type { slave { if {[string match {} $name]} { @@ -2036,6 +2036,7 @@ proc ::tkcon::Attach {{name } {type slave}} { interp alias {} ::tkcon::EvalAttached {} \ ::tkcon::Slave $::tkcon::PRIV(app) } + set namespOK 1 } sock* { interp alias {} ::tkcon::EvalAttached {} \ @@ -2049,9 +2050,9 @@ proc ::tkcon::Attach {{name } {type slave}} { interp { if {$OPT(nontcl)} { interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSlave - set PRIV(namesp) :: } else { interp alias {} ::tkcon::EvalAttached {} ::tkcon::EvalSend + set namespOK 1 } } default { @@ -2059,12 +2060,31 @@ proc ::tkcon::Attach {{name } {type slave}} { a valid type: must be slave or interp" } } - if {[string match slave $type] || \ - (!$OPT(nontcl) && [regexp {^(interp|dpy)} $type])} { - set PRIV(namesp) :: + if {![string match {} $ns] && $namespOK} { + AttachNamespace $ns } - set PRIV(StatusAttach) "$PRIV(app) ($PRIV(apptype))" - return + return [AttachId] +} + +proc ::tkcon::AttachId {} { + # return Attach info in a form that Attach accepts again + variable PRIV + + if {[string match {} $PRIV(appname)]} { + variable OPT + set appname [concat $PRIV(name) $OPT(exec)] + } else { + set appname $PRIV(appname) + } + set id [list $appname $PRIV(apptype)] + # only display ns info if it isn't "::" as that is what is also + # used to indicate no eval in namespace + if {![string match :: $PRIV(namesp)]} { lappend id $PRIV(namesp) } + if {[info exists PRIV(console)]} { + variable ATTACH + set ATTACH($PRIV(console)) $id + } + return $id } ## ::tkcon::AttachNamespace - called to attach tkcon to a namespace @@ -2098,7 +2118,7 @@ proc ::tkcon::AttachNamespace { name } { [interp alias {} ::tkcon::EvalAttached] [list $name] } set PRIV(namesp) $name - set PRIV(StatusAttach) "$PRIV(app) $PRIV(namesp) ($PRIV(apptype))" + return [AttachId] } ## ::tkcon::NewSocket - called to create a socket to connect to @@ -2114,10 +2134,11 @@ proc ::tkcon::NewSocket {} { wm withdraw $t wm title $t "tkcon Create Socket" label $t.lhost -text "Host: " - entry $t.host -width 16 + entry $t.host -width 16 -takefocus 1 label $t.lport -text "Port: " - entry $t.port -width 4 - button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} -width 4 + entry $t.port -width 4 -takefocus 1 + button $t.ok -text "OK" -command {set ::tkcon::PRIV(grab) 1} -width 4 \ + -takefocus 1 bind $t.host [list focus $t.port] bind $t.port [list focus $t.ok] bind $t.ok [list $t.ok invoke] -- 2.23.0