From 788529f7e66fc1305fca0a9b841e090c4457bd49 Mon Sep 17 00:00:00 2001 From: Jeff Hobbs Date: Tue, 4 Jun 2002 02:25:59 +0000 Subject: [PATCH] * 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. --- ChangeLog | 12 +++++ tkcon.tcl | 155 ++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 109 insertions(+), 58 deletions(-) diff --git a/ChangeLog b/ChangeLog index 0906396..690f6ad 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2002-06-03 Jeff Hobbs + + * 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 * tkcon.tcl (AddSlaveHistory): changed history to not add the diff --git a/tkcon.tcl b/tkcon.tcl index 5b1d564..dd07393 100755 --- a/tkcon.tcl +++ b/tkcon.tcl @@ -13,7 +13,7 @@ exec wish "$0" ${1+"$@"} ## Steven Wahl , Jan Nijtmans ## Crimmins , Wart ## -## 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 <>] bind TkConsole <> { 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 <>] bind TkConsole <> { 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 -- 2.23.0