From: Jeff Hobbs <hobbs@users.sourceforge.net>
Date: Fri, 24 Apr 2009 19:09:47 +0000 (+0000)
Subject: 	* tkcon.tcl (::tkcon::Retrieve): support http code redirect for
X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=d24a6b331f77833c68937a8da32493718ee4cd9d;p=tkcon

	* tkcon.tcl (::tkcon::Retrieve): support http code redirect for
	downloading latest version. [Bug 1755500]
---

diff --git a/ChangeLog b/ChangeLog
index 9b61e2c..6b89d69 100644
--- 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 9195464..671d34b 100755
--- 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"
 	    }