proc autoproxy::filter {host} {
     variable user
     variable password
     variable proxy
     variable no_proxy

     if {$proxy(host) == {}} {
         return {}
     }

     foreach domain $no_proxy {
         if {[string match $domain $host]} {
             return {}
         }
     }

     # add proxy authorization header
     upvar state _state
     array set h $_state(-headers)
     set h(Proxy-Authorization) [concat Base [base64::encode $user:$password]]
     set _state(-headers) [array get h]

     return [list $proxy(host) $proxy(port)]
 }

 # autoproxy.tcl - Copyright (C) 2002 Pat Thoyts <[email protected]>
 #
 # On Unix an emerging standard for identifying the local HTTP proxy server
 # seems to be to use the environment variable http_proxy or ftp_proxy and
 # no_proxy to list those domains to be excluded from proxying.
 #
 # On Windows we can retrieve the Internet Settings values from the registry
 # to obtain pretty much the same information.
 #
 # With this information we can set up a suitable filter procedure for the
 # Tcl http package and arrange for automatic use of the proxy.
 #
 # Example:
 #   package require autoproxy
 #   autoproxy::init
 #   autoproxy::configure basic; # enter values in dialog
 #   set tok [http::geturl https://wiki.tcl-lang.org/]
 #   http::data $tok
 #
 # There is a skeleton for supporting Digest or NTLM authorisation but
 # this is not currently supported. I can't find a proxy to test Digest
 # on and we don't yet have a Tcl implementation for NTLM.
 #
 # @(#)$Id: 2879,v 1.19 2005-03-18 07:00:23 jcw Exp $

 namespace eval autoproxy {
     variable rcsid {$Id: 2879,v 1.19 2005-03-18 07:00:23 jcw Exp $}
     variable version 1.1
     variable options

     if {! [info exists options]} {
         array set options {
             proxy_host ""
             proxy_port 80
             no_proxy   {}
             basic      {}
             digest     {}
             ntlm       {}
         }
     }

     variable winregkey
     set winregkey [join {
         HKEY_CURRENT_USER
         Software Microsoft Windows
         CurrentVersion "Internet Settings"
     } \\]
 }

 # -------------------------------------------------------------------------
 # Description:
 #   Obtain configuration options for the server.
 #
 proc autoproxy::cget {option} {
     variable options
     switch -glob -- $option] {
         -ho* -
         -proxy_h* {set options(proxy_host)}
         -po* -
         -proxy_p* {set options(proxy_port)}
         -no* { set options(no_proxy) }
         -b*  { set options(basic) }
         -d*  { set options(digest) }
         -nt* { set options(ntlm) }
         default {
             set err [join [lsort [array names options]] ", -"]
             return -code error "bad option \"[lindex $args 0]\":\
                        must be one of -$options"
         }
     }
 }

 # -------------------------------------------------------------------------
 # Description:
 #  Configure the autoproxy package settings.
 #  You may only configure one type of authorisation at a time as once we hit
 #  -basic, -digest or -ntlm - all further args are passed to the protocol
 #  specific script.
 #
 #  Of course, most of the point of this package is to fill as many of these
 #  fields as possible automatically. You should call autoproxy::init to
 #  do automatic configuration and then call this method to refine the details.
 #
 proc autoproxy::configure {args} {
     variable options

     if {[llength $args] == 0} {
         foreach {opt value} [array get options] {
             lappend r -$opt $value
         }
         return $r
     }

     while {[string match "-*" [lindex $args 0]]} {
         switch -glob -- [lindex $args 0] {
             -ho* -
             -proxy_h* {set options(proxy_host) [Pop args 1]}
             -po* -
             -proxy_p* {set options(proxy_port) [Pop args 1]}
             -no* { set options(no_proxy) [Pop args 1] }
             -b*  { Pop args; configure:basic $args ; break }
             -d*  { Pop args; configure:digest $args ; break }
             -nt* { Pop args; configure:ntlm $args ; break }
             --   { Pop args; break }
             default {
                 set err [join [lsort [array names options]] ", -"]
                 return -code error "bad option \"[lindex $args 0]\":\
                        must be one of -$options"
             }
         }
         Pop args
     }
 }

 # -------------------------------------------------------------------------
 # Description:
 #  Initialize the http proxy information from the environment or the
 #  registry (Win32)
 #
 #  This procedure will load the http package and re-writes the
 #  http::geturl method to add in the authorization header.
 #
 #  A better solution will be to arrange for the http package to request the
 #  authorization key on receiving an authorization request.
 #
 proc autoproxy::init {} {
     package require uri
     global tcl_platform
     global env
     variable winregkey
     variable options
     set no_proxy {}
     set httpproxy {}

     # Look for environment variables.
     if {[info exists env(http_proxy)]} {
         set httpproxy $env(http_proxy)
         set no_proxy $env(no_proxy)
     } else {
         if {$tcl_platform(platform) == "windows"} {
             package require registry 1.0
             array set reg {ProxyEnable 0 ProxyServer "" ProxyOverride {}}
             catch {
                 set reg(ProxyEnable) [registry get $winregkey "ProxyEnable"]
                 set reg(ProxyServer) [registry get $winregkey "ProxyServer"]
                 set reg(ProxyOverride) [registry get $winregkey "ProxyOverride"]
             }
             if {![string is bool $reg(ProxyEnable)]} {
                 set reg(ProxyEnable) 0
             }
             if {$reg(ProxyEnable)} {
                 set httpproxy $reg(ProxyServer)
                 set no_proxy  $reg(ProxyOverride)
             }
         }
     }

     # If we found something ...
     if {$httpproxy != {}} {
         # The http_proxy is supposed to be a URL - let us make sure.
         if {![regexp {\w://.*} $httpproxy]} {
             set httpproxy "http://$httpproxy"
         }

         # decompose the string.
         array set proxy [uri::split $httpproxy]

         # turn the no_proxy value into a tcl list
         set no_proxy [string map {; " " , " "} $no_proxy]

         # configure ourselves
         configure -proxy_host $proxy(host) \
             -proxy_port $proxy(port) \
             -no_proxy $no_proxy

         # setup and configure the http package
         package require http 2.0
         http::config -proxyfilter [namespace origin filter]
     }
     return $httpproxy
 }

 # -------------------------------------------------------------------------
 # Description:
 #  Pop the nth element off a list. Used in options processing.
 proc autoproxy::Pop {varname {nth 0}} {
     upvar $varname args
     set r [lindex $args $nth]
     set args [lreplace $args $nth $nth]
     return $r
 }

 # -------------------------------------------------------------------------

 # Description:
 #  Implement support for the Basic authentication scheme (RFC 2617).
 # Options:
 #  -user userid  - pass in the user ID (May require Windows NT domain
 #                  as DOMAIN\\username)
 #  -password pwd - pass in the user's password.
 #
 proc autoproxy::configure:basic {arglist} {
     variable options
     array set opts {user {} passwd {}}
     foreach {opt value} $arglist {
         switch -glob -- $opt {
             -u* { set opts(user) $value }
             -p* { set opts(passwd) $value }
             default {
                 return -code error "invalid option \"$opt\": must be one of\
                      -username or -password"
             }
         }
     }

     # If nothing was provided, assume they want an interactive prompt.
     if {$opts(user) == {} || $opts(passwd) == {}} {
         package require BWidget
         set r [PasswdDlg .d -logintext $opts(user) -passwdtext $opts(passwd)]
         set opts(user) [lindex $r 0]
         set opts(passwd) [lindex $r 1]
     }

     # Note: we only store the 'encoded' password. Avoid keeping plaintext.
     package require base64
     set options(basic) [list "Proxy-Authorization" \
                             [concat "Basic" \
                                  [base64::encode $opts(user):$opts(passwd)]]]
 }

 # -------------------------------------------------------------------------

 # Description:
 #  Implement support for the Digest authentication scheme (RFC nnnn).
 # Options:
 #  -user userid  - pass in the user ID (May require Windows NT domain
 #                  as DOMAIN\\username)
 #  -password pwd - pass in the user's password.
 #  -realm domain - the authorization realm
 #
 proc autoproxy::configure:digest {arglist} {
     variable options
     array set opts {user {} passwd {} realm {}}
     foreach {opt value} $arglist {
         switch -glob -- $opt {
             -u* { set opts(user)   $value }
             -p* { set opts(passwd) $value }
             -r* { set opts(realm)  $value }
             default {
                 return -code error "invalid option \"$opt\": must be one of\
                      -username, -realm or -password"
             }
         }
     }

     # If nothing was provided, assume they want an interactive prompt.
     if {$opts(user) == {} || $opts(passwd) == {}} {
         package require BWidget
         set r [PasswdDlg .d -title "Realm $opts(realm)" \
                    -logintext $opts(user) \
                    -passwdtext $opts(passwd)]
         set opts(user) [lindex $r 0]
         set opts(passwd) [lindex $r 1]
     }

     # Note: we only store the MD5 checksum of the password.
     package require md5
     set A1 [md5::md5 "$opts(user):$opts(realm):$opts(passwd)"]
     set options(digest) [list $opts(user) $opts(realm) $A1]
     return
 }

 # -------------------------------------------------------------------------
 # Description:
 #  Suport Microsoft's NTLM scheme
 #  Not done as yet.
 #
 proc autoproxy::configure:ntlm {arglist} {
     variable options
     return -code error "NTLM authorization is not available"
 }

 # -------------------------------------------------------------------------
 # Description:
 #  An http package proxy filter. This attempts to work out is a request
 #  should go via the configured proxy using a glob comparison against the
 #  no_proxy list items. A typical no_proxy list might be
 #   [list localhost *.my.domain.com 127.0.0.1]
 #
 # If we are going to use the proxy - then insert the proxy authorization
 # header.
 #
 proc autoproxy::filter {host} {
     variable options

     if {$options(proxy_host) == {}} {
         return {}
     }

     foreach domain $options(no_proxy) {
         if {[string match $domain $host]} {
             return {}
         }
     }

     # Add authorization header to the request (by Anders Ramdahl)
     upvar state State
     if {$options(basic) != {}} {
         set State(-headers) [concat $options(basic) $State(-headers)]
     } elseif {$options(digest) != {}} {
         # FIX ME there is more to Digest than this
         #set State(-headers) [linsert $State(-headers) 0 $options(digest)]
     }

     return [list $options(proxy_host) $options(proxy_port)]
 }

 # -------------------------------------------------------------------------

 package provide autoproxy $autoproxy::version

 # -------------------------------------------------------------------------
 #
 # Local variables:
 #   mode: tcl
 #   indent-tabs-mode: nil
 # End:

                    if { [string first ";" $reg(ProxyServer)] == -1 } {
                        set httpproxy $reg(ProxyServer)
                    } else {
                        foreach tmp [split $reg(ProxyServer) ";"] {
                            if { [string match "http=*" $tmp] } {
                                set httpproxy [string range $tmp 5 end]
                                break
                            }
                        }
                        unset tmp
                    }