* tkcon.tcl (::tkcon::Retrieve): support http code redirect for

	downloading latest version. [Bug 1755500]

diff --git a/ChangeLog b/ChangeLog
index 9b61e2c79b383bf3cd71345bb4aac6232a4c8bf8..6b89d6967669e66ea4a369cf027b86a14524e597 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
 2009-04-24  Jeff Hobbs  <jeffh@ActiveState.com>
 
+       * tkcon.tcl (::tkcon::Retrieve): support http code redirect for
+       downloading latest version. [Bug 1755500]
+
        * README.txt, docs/limits.html, docs/nontcl.html: bump to 2.6
        * pkgIndex.tcl, tkcon.tcl: Use Tcl 8.4 code style.
 

diff --git a/tkcon.tcl b/tkcon.tcl
index 919546476c7d0d1f8f3a5f3e9d10b18c07adf25f..671d34b0bf2e04e18dd99e94d90e474f8d9ece9b 100755 (executable)
--- a/tkcon.tcl
+++ b/tkcon.tcl
@@ -6131,6 +6131,22 @@ proc ::tkcon::Retrieve {} {
        ::http::wait $token
        set code [catch {
            set ncode [::http::ncode $token]
+           set i 0
+           while {(($ncode >= 301) && ($ncode <= 307)) && [incr i] < 5} {
+               # redirect to meta Location
+               array set meta [::http::meta $token]
+               ::http::cleanup $token
+               if {![info exists meta(Location)]} { break }
+               set url $meta(Location)
+               if {![string match "http*" $url]
+                   && [regexp {https?://[^/]+} $PRIV(HEADURL) srvr]} {
+                   # attach the same http server info
+                   set url $srvr/$url
+               }
+               set token [::http::geturl $url -headers $headers -timeout 30000]
+               ::http::wait $token
+               set ncode [::http::ncode $token]
+           }
            if {$ncode != 200} {
                return "expected http return code 200, received $ncode"
            }