* tkcon.tcl: fixed Retrieve to use the proxy info (Thoyts).

	Added code so that tkcon.tcl can be sourced in and used like a
	quasi-package.  Once sourced, you can do a 'package require tkcon'
	(there is no pkgIndex.tcl for it), and the first 'tkcon show' will
	initialize anything that is needed.
	(observe): corrected variables tracing to not allow duplicates.
	(dump): improved check for empty named arrays as well as locally
	aliased vars in var dumps.
	Use the 'fixed' font on unix by default.

diff --git a/ChangeLog b/ChangeLog
index 0906396199a7dc7d5fa83c8173dc7f3cbff8a324..690f6ad0bbaed94ac961733d25b447db25d22f8d 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2002-06-03  Jeff Hobbs  <jeffh@ActiveState.com>
+
+       * tkcon.tcl: fixed Retrieve to use the proxy info (Thoyts).
+       Added code so that tkcon.tcl can be sourced in and used like a
+       quasi-package.  Once sourced, you can do a 'package require tkcon'
+       (there is no pkgIndex.tcl for it), and the first 'tkcon show' will
+       initialize anything that is needed.
+       (observe): corrected variables tracing to not allow duplicates.
+       (dump): improved check for empty named arrays as well as locally
+       aliased vars in var dumps.
+       Use the 'fixed' font on unix by default.
+
 2002-02-22  Jeff Hobbs  <jeffh@ActiveState.com>
 
        * tkcon.tcl (AddSlaveHistory): changed history to not add the

diff --git a/tkcon.tcl b/tkcon.tcl
index 5b1d564cc1f85d0131ba053c3439f56867ba33d3..dd07393ad41efc9e561a2fcb80ee1162b32c3c33 100755 (executable)
--- a/tkcon.tcl
+++ b/tkcon.tcl
@@ -13,7 +13,7 @@ exec wish "$0" ${1+"$@"}
 ## Steven Wahl <steven@indra.com>, Jan Nijtmans <nijtmans@nici.kun.nl>
 ## Crimmins <markcrim@umich.edu>, Wart <wart@ugcs.caltech.edu>
 ##
-## Copyright 1995-2001 Jeffrey Hobbs
+## Copyright (c) 1995-2002 Jeffrey Hobbs
 ## Initiated: Thu Aug 17 15:36:47 PDT 1995
 ##
 ## jeff.hobbs@acm.org, jeff@hobbs.org
@@ -74,6 +74,7 @@ foreach cmd {SetCursor UpDownLine Transpose ScrollPages} {
 # Initialize the ::tkcon namespace
 #
 namespace eval ::tkcon {
+    variable VERSION "2.4"
     # The OPT variable is an array containing most of the optional
     # info to configure.  COLOR has the color data.
     variable OPT
@@ -89,18 +90,15 @@ namespace eval ::tkcon {
 # Calls:       ::tkcon::InitUI
 # Outputs:     errors found in tkcon's resource file
 ##
-proc ::tkcon::Init {} {
+proc ::tkcon::Init {args} {
+    variable VERSION
     variable OPT
     variable COLOR
     variable PRIV
-    global tcl_platform env argc argv tcl_interactive errorInfo
-
-    if {![info exists argv]} {
-       set argv {}
-       set argc 0
-    }
+    global tcl_platform env tcl_interactive errorInfo
 
     set tcl_interactive 1
+    set argc [llength $args]
 
     if {[info exists PRIV(name)]} {
        set title $PRIV(name)
@@ -195,7 +193,6 @@ proc ::tkcon::Init {} {
            alias clear dir dump echo idebug lremove
            tkcon_puts tkcon_gets observe observe_var unalias which what
        }
-       version         2.3
        RCS             {RCS: @(#) $Id$}
        HEADURL         {http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tkcon/tkcon/tkcon.tcl?rev=HEAD}
        docs            "http://tkcon.sourceforge.net/"
@@ -204,6 +201,7 @@ proc ::tkcon::Init {} {
     } {
        if {![info exists PRIV($key)]} { set PRIV($key) $default }
     }
+    set PRIV(version) $VERSION
 
     ## NOTES FOR STAYING IN PRIMARY INTERPRETER:
     ##
@@ -263,8 +261,8 @@ proc ::tkcon::Init {} {
 
     ## Handle command line arguments before sourcing resource file to
     ## find if resource file is being specified (let other args pass).
-    if {[set i [lsearch -exact $argv -rcfile]] != -1} {
-       set PRIV(rcfile) [lindex $argv [incr i]]
+    if {[set i [lsearch -exact $args -rcfile]] != -1} {
+       set PRIV(rcfile) [lindex $args [incr i]]
     }
 
     if {!$PRIV(WWW) && [file exists $PRIV(rcfile)]} {
@@ -292,12 +290,12 @@ proc ::tkcon::Init {} {
     set slavefiles {}
     set truth {^(1|yes|true|on)$}
     for {set i 0} {$i < $argc} {incr i} {
-       set arg [lindex $argv $i]
+       set arg [lindex $args $i]
        if {[string match {-*} $arg]} {
-           set val [lindex $argv [incr i]]
+           set val [lindex $args [incr i]]
            ## Handle arg based options
            switch -glob -- $arg {
-               -- - -argv      {
+               -- - -argv - -args {
                    set argv [concat -- [lrange $argv $i end]]
                    set argc [llength $argv]
                    break
@@ -325,7 +323,7 @@ proc ::tkcon::Init {} {
        uplevel \#0 ::tkcon::InitSlave $OPT(exec) $slaveargs
     } else {
        set argc [llength $slaveargs]
-       set argv $slaveargs
+       set args $slaveargs
        uplevel \#0 $slaveargs
     }
 
@@ -559,13 +557,15 @@ proc ::tkcon::InitUI {title} {
     if {[string compare {} $OPT(font)]} {
        ## Set user-requested font, if any
        $con configure -font $OPT(font)
-    } else {
+    } elseif {[string compare unix $::tcl_platform(platform)]} {
        ## otherwise make sure the font is monospace
        set font [$con cget -font]
        if {![font metrics $font -fixed]} {
            font create tkconfixed -family Courier -size 12
            $con configure -font tkconfixed
        }
+    } else {
+       $con configure -font fixed
     }
     set OPT(font) [$con cget -font]
     if {!$PRIV(WWW)} {
@@ -1093,7 +1093,7 @@ proc ::tkcon::About {} {
        # strip down the RCS info displayed in the about box
        regexp {,v ([0-9\./: ]*)} $PRIV(RCS) -> RCS
        $w.text insert 1.0 "About tkcon v$PRIV(version)" title \
-               "\n\nCopyright 1995-2001 Jeffrey Hobbs, $PRIV(email)\
+               "\n\nCopyright 1995-2002 Jeffrey Hobbs, $PRIV(email)\
                \nRelease Info: v$PRIV(version), CVS v$RCS\
                \nDocumentation available at:\n$PRIV(docs)\
                \nUsing: Tcl v$tcl_patchLevel / Tk v$tk_patchLevel" center
@@ -1403,7 +1403,7 @@ proc ::tkcon::PkgMenu {m app type} {
     set npkg 0
     foreach pkg [lsort -dictionary [array names loadable]] {
        foreach v [EvalAttached [list package version $pkg]] {
-           set brkcol [expr {([incr npkg]%16)==0}]
+           set brkcol [expr {([incr npkg]%23)==0}]
            $m add command -label "Load $pkg ($v)" -command \
                    "::tkcon::EvalOther [list $app] $type $loadable($pkg) $v" \
                    -columnbreak $brkcol
@@ -1413,7 +1413,9 @@ proc ::tkcon::PkgMenu {m app type} {
        $m add separator
     }
     foreach pkg [lsort -dictionary [array names loaded]] {
-       $m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled
+       set brkcol [expr {([incr npkg]%23)==0}]
+       $m add command -label "${pkg}$loaded($pkg) Loaded" -state disabled \
+                   -columnbreak $brkcol
     }
 }
 
@@ -2530,6 +2532,8 @@ proc ::tkcon::ErrorHighlight w {
 # ARGS:        totally variable, see internal comments
 ## 
 proc tkcon {cmd args} {
+    variable ::tkcon::PRIV
+    variable ::tkcon::OPT
     global errorInfo
 
     switch -glob -- $cmd {
@@ -2537,15 +2541,15 @@ proc tkcon {cmd args} {
            ## 'buffer' Sets/Query the buffer size
            if {[llength $args]} {
                if {[regexp {^[1-9][0-9]*$} $args]} {
-                   set ::tkcon::OPT(buffer) $args
+                   set OPT(buffer) $args
                    # catch in case the console doesn't exist yet
-                   catch {::tkcon::ConstrainBuffer $::tkcon::PRIV(console) \
-                           $::tkcon::OPT(buffer)}
+                   catch {::tkcon::ConstrainBuffer $PRIV(console) \
+                           $OPT(buffer)}
                } else {
                    return -code error "buffer must be a valid integer"
                }
            }
-           return $::tkcon::OPT(buffer)
+           return $OPT(buffer)
        }
        bg* {
            ## 'bgerror' Brings up an error dialog
@@ -2558,9 +2562,9 @@ proc tkcon {cmd args} {
        }
        cons* {
            ## 'console' - passes the args to the text widget of the console.
-           set result [uplevel 1 $::tkcon::PRIV(console) $args]
-           ::tkcon::ConstrainBuffer $::tkcon::PRIV(console) \
-                   $::tkcon::OPT(buffer)
+           set result [uplevel 1 $PRIV(console) $args]
+           ::tkcon::ConstrainBuffer $PRIV(console) \
+                   $OPT(buffer)
            return $result
        }
        congets {
@@ -2573,7 +2577,7 @@ proc tkcon {cmd args} {
            tkcon show
            set old [bind TkConsole <<TkCon_Eval>>]
            bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
-           set w $::tkcon::PRIV(console)
+           set w $PRIV(console)
            # Make sure to move the limit to get the right data
            $w mark set insert end
            $w mark set limit insert
@@ -2593,7 +2597,7 @@ proc tkcon {cmd args} {
            tkcon show
            set old [bind TkConsole <<TkCon_Eval>>]
            bind TkConsole <<TkCon_Eval>> { set ::tkcon::PRIV(wait) 0 }
-           set w $::tkcon::PRIV(console)
+           set w $PRIV(console)
            # Make sure to move the limit to get the right data
            $w mark set insert end
            $w mark set limit insert
@@ -2616,7 +2620,7 @@ proc tkcon {cmd args} {
            if {[llength $args]} {
                return -code error "wrong # args: should be \"tkcon gets\""
            }
-           set t $::tkcon::PRIV(base).gets
+           set t $PRIV(base).gets
            if {![winfo exists $t]} {
                toplevel $t
                wm withdraw $t
@@ -2637,7 +2641,7 @@ proc tkcon {cmd args} {
                grid $t.ok   -          -sticky ew
                grid columnconfig $t 0 -weight 1
                grid rowconfig    $t 1 -weight 1
-               wm transient $t $::tkcon::PRIV(root)
+               wm transient $t $PRIV(root)
                wm geometry $t +[expr {([winfo screenwidth $t]-[winfo \
                        reqwidth $t]) / 2}]+[expr {([winfo \
                        screenheight $t]-[winfo reqheight $t]) / 2}]
@@ -2662,7 +2666,7 @@ proc tkcon {cmd args} {
                    set info "error getting info from $type $app:\n$info"
                }
            } else {
-               set info $::tkcon::PRIV(errorInfo)
+               set info $PRIV(errorInfo)
            }
            if {[string match {} $info]} { set info "errorInfo empty" }
            ## If args is empty, the -attach switch just ignores it
@@ -2670,24 +2674,26 @@ proc tkcon {cmd args} {
        }
        fi* {
            ## 'find' string
-           ::tkcon::Find $::tkcon::PRIV(console) $args
+           ::tkcon::Find $PRIV(console) $args
        }
        fo* {
            ## 'font' ?fontname? - gets/sets the font of the console
            if {[llength $args]} {
-               if {[info exists ::tkcon::PRIV(console)] && \
-                       [winfo exists $::tkcon::PRIV(console)]} {
-                   $::tkcon::PRIV(console) config -font $args
-                   set ::tkcon::OPT(font) [$::tkcon::PRIV(console) cget -font]
+               if {[info exists PRIV(console)] && \
+                       [winfo exists $PRIV(console)]} {
+                   $PRIV(console) config -font $args
+                   set OPT(font) [$PRIV(console) cget -font]
                } else {
-                   set ::tkcon::OPT(font) $args
+                   set OPT(font) $args
                }
            }
-           return $::tkcon::OPT(font)
+           return $OPT(font)
        }
        hid* - with* {
            ## 'hide' 'withdraw' - hides the console.
-           wm withdraw $::tkcon::PRIV(root)
+           if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} {
+               wm withdraw $PRIV(root)
+           }
        }
        his* {
            ## 'history'
@@ -2699,7 +2705,9 @@ proc tkcon {cmd args} {
        }
        ico* {
            ## 'iconify' - iconifies the console with 'iconify'.
-           wm iconify $::tkcon::PRIV(root)
+           if {[info exists PRIV(root)] && [winfo exists $PRIV(root)]} {
+               wm iconify $PRIV(root)
+           }
        }
        mas* - eval {
            ## 'master' - evals contents in master interpreter
@@ -2749,16 +2757,24 @@ proc tkcon {cmd args} {
        }
        sh* - dei* {
            ## 'show|deiconify' - deiconifies the console.
-           wm deiconify $::tkcon::PRIV(root)
-           raise $::tkcon::PRIV(root)
-           focus -force $::tkcon::PRIV(console)
+           if {![info exists PRIV(root)]} {
+               set PRIV(showOnStartup) 0
+               set PRIV(root) .tkcon
+               set OPT(exec) ""
+           }
+           if {![winfo exists $PRIV(root)]} {
+               ::tkcon::Init
+           }
+           wm deiconify $PRIV(root)
+           raise $PRIV(root)
+           focus -force $PRIV(console)
        }
        ti* {
            ## 'title' ?title? - gets/sets the console's title
            if {[llength $args]} {
-               return [wm title $::tkcon::PRIV(root) [join $args]]
+               return [wm title $PRIV(root) [join $args]]
            } else {
-               return [wm title $::tkcon::PRIV(root)]
+               return [wm title $PRIV(root)]
            }
        }
        upv* {
@@ -2768,18 +2784,18 @@ proc tkcon {cmd args} {
            set masterVar [lindex $args 0]
            set slaveVar  [lindex $args 1]
            if {[info exists $masterVar]} {
-               interp eval $::tkcon::OPT(exec) \
+               interp eval $OPT(exec) \
                        [list set $slaveVar [set $masterVar]]
            } else {
-               catch {interp eval $::tkcon::OPT(exec) [list unset $slaveVar]}
+               catch {interp eval $OPT(exec) [list unset $slaveVar]}
            }
-           interp eval $::tkcon::OPT(exec) \
+           interp eval $OPT(exec) \
                    [list trace variable $slaveVar rwu \
-                   [list tkcon set $masterVar $::tkcon::OPT(exec)]]
+                   [list tkcon set $masterVar $OPT(exec)]]
            return
        }
        v* {
-           return $::tkcon::PRIV(version)
+           return $PRIV(version)
        }
        default {
            ## tries to determine if the command exists, otherwise throws error
@@ -3041,7 +3057,7 @@ interp alias {} ::less {} ::edit
 ## Relaxes the one string restriction of 'puts'
 # ARGS:        any number of strings to output to stdout
 ##
-proc echo args { puts [concat $args] }
+proc echo args { puts stdout [concat $args] }
 
 ## clear - clears the buffer of the console (not the history though)
 ## This is executed in the parent interpreter
@@ -3170,10 +3186,13 @@ proc dump {type args} {
                }
                foreach var [lsort $vars] {
                    if {[uplevel 1 [list info locals $var]] == ""} {
-                       # use the proper scope of the var, but
-                       # namespace which won't id locals correctly
-                       set var [uplevel 1 \
+                       # use the proper scope of the var, but namespace which
+                       # won't id locals or some upvar'ed vars correctly
+                       set new [uplevel 1 \
                                [list namespace which -variable $var]]
+                       if {$new != ""} {
+                           set var $new
+                       }
                    }
                    upvar 1 $var v
                    if {[array exists v] || [catch {string length $v}]} {
@@ -3193,7 +3212,11 @@ proc dump {type args} {
                        } else {
                            ## empty array
                            append res "    empty array\n"
-                           append nst "unset [list $var](empty)\n"
+                           if {$var == ""} {
+                               append nst "unset (empty)\n"
+                           } else {
+                               append nst "unset [list $var](empty)\n"
+                           }
                        }
                        append res "\}\n$nst"
                    } else {
@@ -3613,6 +3636,10 @@ proc observe {opt name args} {
                        \"$type\", must be: read, write or unset"
            }
            if {![llength $args]} { set args observe_var }
+           foreach c [uplevel 1 [list trace vinfo $name]] {
+               # don't double up on the traces
+               if {[string equal [list $type $args] $c]} { return }
+           }
            uplevel 1 [list trace $opt $name $type $args]
        }
        vi* {
@@ -5198,6 +5225,15 @@ proc ::tkcon::Retrieve {} {
            -filetypes {{"Tcl Files" {.tcl .tk}} {"All Files" {*.*}}}]
     if {[string compare $file ""]} {
        package require http 2
+       set headers {}
+       if {[info exists PRIV(proxy)]} {
+           ::http::config -proxyfilter [namespace origin RetrieveFilter]
+           if {[lindex $PRIV(proxy) 1] != {}} {
+               set headers [RetrieveAuthentication]
+           }
+       }
+       set token [::http::geturl $PRIV(HEADURL) \
+               -headers $headers -timeout 30000]
        set token [::http::geturl $PRIV(HEADURL) -timeout 30000]
        ::http::wait $token
        set code [catch {
@@ -5262,7 +5298,10 @@ proc ::tkcon::Resource {} {
 
 ## Initialize only if we haven't yet
 ##
-if {![info exists ::tkcon::PRIV(root)] || \
-       ![winfo exists $::tkcon::PRIV(root)]} {
-    ::tkcon::Init
+if {(![info exists ::tkcon::PRIV(root)] \
+       || ![winfo exists $::tkcon::PRIV(root)]) \
+       && (![info exists argv0] || [info script] == $argv0)} {
+    ::tkcon::Init $argv
 }
+
+package provide tkcon $::tkcon::VERSION