From: Jeff Hobbs <hobbs@users.sourceforge.net>
Date: Wed, 28 Jan 2004 21:39:40 +0000 (+0000)
Subject: 	(::tkcon::Retrieve): correct retrieve URL and add intelligence to
X-Git-Tag: tkcon-2-4~13
X-Git-Url: https://privyetmir.co.uk/gitweb.cgi?a=commitdiff_plain;h=2e1bdee27f43ef493e8d26c234aae8622b6f4043;p=tkcon

	(::tkcon::Retrieve): correct retrieve URL and add intelligence to
	sense whether what we retrieved is correct before overwriting file.
---

diff --git a/ChangeLog b/ChangeLog
index 360c39a..8b89f22 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -8,6 +8,8 @@
 	tightened up Create Socket dialog, added <Escape> dismiss binding.
 	Moved source time initialization into ::tkcon::AtSource to guard
 	against leftover vars and just better encapsulate it.
+	(::tkcon::Retrieve): correct retrieve URL and add intelligence to
+	sense whether what we retrieved is correct before overwriting file.
 
 2003-11-18  Jeff Hobbs  <jeffh@ActiveState.com>
 
diff --git a/tkcon.tcl b/tkcon.tcl
index ffd0c84..d7edff6 100755
--- a/tkcon.tcl
+++ b/tkcon.tcl
@@ -190,7 +190,8 @@ proc ::tkcon::Init {args} {
 	    tkcon_puts tkcon_gets observe observe_var unalias which what
 	}
 	RCS		{RCS: @(#) $Id$}
-	HEADURL		{http://cvs.sourceforge.net/cgi-bin/viewcvs.cgi/tkcon/tkcon/tkcon.tcl?rev=HEAD}
+	HEADURL		{http://cvs.sourceforge.net/viewcvs.py/*checkout*/tkcon/tkcon/tkcon.tcl?rev=HEAD}
+
 	docs		"http://tkcon.sourceforge.net/"
 	email		{jeff(a)hobbs(.)org}
 	root		.
@@ -5353,19 +5354,39 @@ proc ::tkcon::Retrieve {} {
 	set token [::http::geturl $PRIV(HEADURL) -timeout 30000]
 	::http::wait $token
 	set code [catch {
-	    if {[::http::status $token] == "ok"} {
+	    set ncode [::http::ncode $token]
+	    if {$ncode != 200} {
+		return "expected http return code 200, received $ncode"
+	    }
+	    set status [::http::status $token]
+	    if {$status == "ok"} {
+		set data [::http::data $token]
+		regexp {Id: tkcon.tcl,v (\d+\.\d+)} $data -> rcsVersion
+		regexp {VERSION\s+"(\d+\.\d+[^\"]*)"} $data -> tkconVersion
+		if {(![info exists rcsVersion] || ![info exists tkconVersion])
+		    && [tk_messageBox -type yesno -icon warning \
+			    -parent $PRIV(root) \
+			    -title "Invalid tkcon source code" \
+			    -message "Source code retrieved does not appear\
+			to be correct.\nContinue with save to \"$file\"?"] \
+			== "no"} {
+		    return "invalid tkcon source code retrieved"
+		}
 		set fid [open $file w]
 		# We don't want newline mode to change
 		fconfigure $fid -translation binary
-		set data [::http::data $token]
 		puts -nonewline $fid $data
 		close $fid
-		regexp {Id: tkcon.tcl,v (\d+\.\d+)} $data -> rcsVersion
-		regexp {VERSION\s+"(\d+\.\d+[^\"]*)"} $data -> tkconVersion
+	    } else {
+		return "expected http status ok, received $status"
 	    }
 	} err]
 	::http::cleanup $token
-	if {$code} {
+	if {$code == 2} {
+	    tk_messageBox -type ok -icon info -parent $PRIV(root) \
+		    -title "Failed to retrieve source" \
+		    -message "Failed to retrieve latest tkcon source:\n$err"
+	} elseif {$code} {
 	    return -code error $err
 	} else {
 	    if {![info exists rcsVersion]}   { set rcsVersion   "UNKNOWN" }