(::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 360c39ae021e6025b99b49b70ba84a9283b73df6..8b89f22fa70ef5b18efe4c9e05f11d7cfbfa960b 100644 (file)
--- 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 ffd0c84447e5276b20ab19652e37c2b72c8bd91f..d7edff63184af237db7d472a8b6b4a4f959a35f2 100755 (executable)
--- 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" }