Check for updates menu item

svn: r3187

collects/string-constants/danish-string-constants.ss

@@ -640,7 +640,6 @@ please adhere to these guidelines:
  (help-menu-label "&Hjælp")
  (about-info "Akkrediteringer og detaljer om dette program")
  (about-menu-item "Om...")
- (help-menu-check-for-updates "Undersøg, om der er opdateringer...")
 
  ;; open here's new menu item
  (create-new-window-or-clear-current
@@ -993,6 +992,8 @@ please adhere to these guidelines:
  (kill? "Ihjel?")
 
  ;;; version checker
+ (version:update-menu-item "Undersøg, om der er opdateringer...")
+ (version:update-check "Opdateringstjek")
 
  ;; special menu
  (special-menu "Speciel")

collects/string-constants/dutch-string-constants.ss

@@ -444,7 +444,6 @@
  (help-menu-label "&Hulp")
  (about-info "Credits and details for this application") ; <**>
  (about-menu-item "Info...")
- (help-menu-check-for-updates "Recentere versies...")
  
  ;;; help-desk-specific menus
  (new-help-desk "Nieuwe Hulpbron")
@@ -700,6 +699,8 @@
  (kill? "Beëindigen?")
 
  ;;; version checker
+ (version:update-menu-item "Recentere versies...")
+ (version:update-check "Versie bijwerken")
 
  ;; special menu
  (special-menu "Invoegen")

collects/string-constants/english-string-constants.ss

@@ -648,7 +648,6 @@ please adhere to these guidelines:
  (help-menu-label "&Help")
  (about-info "Credits and details for this application")
  (about-menu-item "About...")
- (help-menu-check-for-updates "Check for Updates...")
  
  ;; open here's new menu item
  (create-new-window-or-clear-current
@@ -1015,9 +1014,17 @@ please adhere to these guidelines:
  (kill? "Kill?")
 
  ;;; version checker
- ;; the next two are used in the initial wizard dialog.
+ (version:update-menu-item   "Check for Updates...")
- ;; Note that vc-wizard-check-prompt can (should) have newlines so
+ (version:update-check       "Update check") ; dialog title, with the next line
- ;; it will not make the dialog too wide.
+ (version:connecting-server  "Connecting to PLT version server")
+ (version:results-title      "PLT Version Check")
+ (version:do-periodic-checks "Periodically check for newer PLT Scheme versions")
+ (version:take-me-there      "Take Me There") ; ...to the download website
+ ;; the next one can appear alone, or followed by a comma and the one after that
+ (version:plt-up-to-date     "Your PLT version is up-to-date")
+ (version:but-newer-alpha    "but note that there is a newer alpha-release")
+ ;; This is used in this context: "PLT Scheme vNNN <<<*>>> http://download..."
+ (version:now-available-at   "is now available at")
 
  ;; special menu
  (special-menu "S&pecial")

collects/string-constants/french-string-constants.ss

@@ -648,7 +648,6 @@
   (help-menu-label "&Aide")
   (about-info "Auteurs et détails concernant ce logiciel.")
   (about-menu-item "A propos de ...")
-  (help-menu-check-for-updates "Regarder les mises à jour...")
   
   ;; open here's new menu item
   (create-new-window-or-clear-current
@@ -1004,9 +1003,8 @@
   (kill? "Tuer ?")
   
   ;;; version checker
-  ;; the next two are used in the initial wizard dialog.
+  (version:update-menu-item "Regarder les mises à jour...")
-  ;; Note that vc-wizard-check-prompt can (should) have newlines so
+  (version:update-check "Vérification des mises à jour")
-  ;; it will not make the dialog too wide.
   
   ;; special menu
   (special-menu "Spécial")

collects/string-constants/german-string-constants.ss

@@ -543,7 +543,6 @@
  (help-menu-label "&Hilfe")
  (about-info "Mehr über dieses Programm und seine Entstehung")
  (about-menu-item "Über...")
- (help-menu-check-for-updates "Nach Updates schauen...")
  
  ;; open here's new menu item
  (create-new-window-or-clear-current
@@ -896,9 +895,8 @@
  (kill? "Abbrechen?")
 
  ;;; version checker
- ;; the next two are used in the initial wizard dialog.
+ (version:update-menu-item "Nach Updates schauen...")
- ;; Note that vc-wizard-check-prompt can (should) have newlines so
+ (version:update-check "Update-Prüfung")
- ;; it will not make the dialog too wide.
 
  ;; special menu
  (special-menu "S&pezial")

collects/string-constants/japanese-string-constants.ss

@@ -639,7 +639,6 @@ please adhere to these guidelines:
  (help-menu-label "ヘルプ(&H)")
  (about-info "このアプリケーションの著作権と詳細情報を表示します")
  (about-menu-item "バージョン情報...")
- (help-menu-check-for-updates "アップデートの確認...")
 
  ;; open here's new menu item
  (create-new-window-or-clear-current
@@ -989,9 +988,7 @@ please adhere to these guidelines:
  (kill? "強制終了？")
 
  ;;; version checker
- ;; the next two are used in the initial wizard dialog.
+ (version:update-menu-item "アップデートの確認...")
- ;; Note that vc-wizard-check-prompt can (should) have newlines so
- ;; it will not make the dialog too wide.
 
  ;; special menu
  (special-menu "特殊(&P)")

collects/string-constants/portuguese-string-constants.ss

@@ -633,7 +633,6 @@ please adhere to these guidelines:
  (help-menu-label "&Ajuda")
  (about-info "Credits and details for this application")
  (about-menu-item "Sobre...")
- (help-menu-check-for-updates "Check for Updates...")
  
  ;; open here's new menu item
  (create-new-window-or-clear-current
@@ -961,9 +960,6 @@ please adhere to these guidelines:
  (kill? "Kill?")
 
  ;;; version checker
- ;; the next two are used in the initial wizard dialog.
- ;; Note that vc-wizard-check-prompt can (should) have newlines so
- ;; it will not make the dialog too wide.
 
  ;; special menu
  (special-menu "S&pecial")

collects/string-constants/simplified-chinese-string-constants.ss

@@ -563,7 +563,6 @@
   (help-menu-label "帮助(&H)")
   (about-info "本程序的详细信息以及致谢名单")
   (about-menu-item "关于...")
-  (help-menu-check-for-updates "检查更新...")
   
   ;; open here's new menu item
   (create-new-window-or-clear-current
@@ -853,9 +852,7 @@
   (kill? "终止？")
   
   ;;; version checker
-  ;; the next two are used in the initial wizard dialog.
+  (version:update-menu-item "检查更新...")
-  ;; Note that vc-wizard-check-prompt can (should) have newlines so
-  ;; it will not make the dialog too wide.
   
   ;; special menu
   (special-menu "特殊符号(&P)")

collects/string-constants/spanish-string-constants.ss

@@ -547,7 +547,6 @@
  (help-menu-label "&Ayuda")
  (about-info "Créditos y detalles de esta apliación")
  (about-menu-item "Acerca ...")
- (help-menu-check-for-updates "Buscando Actualizaciones...")
 
   ;;; help-desk-specific menus
  ;; open here's new menu item
@@ -898,11 +897,9 @@
  (kill "Terminar")
  (kill? "¿Terminar?")
  
- ;; version checker
+ ;;; version checker
- ;; vc-check-prompt is gone, I'm leaving this comment to make it easier to generate
+ (version:update-menu-item "Buscando Actualizaciones...")
- ;; vc-wizard-check-note which is similar, only it is used as part of the initial
+ (version:update-check "Revisar Actualización")
- ;; wizard dialog.  Note that vc-wizard-check-prompt can (should) have newlines so
- ;; it will not make the dialog too wide.
 
  ;; special menu
  (special-menu "Especial")

collects/string-constants/traditional-chinese-string-constants.ss

@@ -560,7 +560,6 @@
   (help-menu-label "幫助(&H)")
   (about-info "本程式的詳細信息以及致謝名單")
   (about-menu-item "關於...")
-  (help-menu-check-for-updates "檢查更新...")
   
   ;; open here's new menu item
   (create-new-window-or-clear-current
@@ -850,9 +849,7 @@
   (kill? "終止？")
   
   ;;; version checker
-  ;; the next two are used in the initial wizard dialog.
+  (version:update-menu-item "檢查更新...")
-  ;; Note that vc-wizard-check-prompt can (should) have newlines so
-  ;; it will not make the dialog too wide.
   
   ;; special menu
   (special-menu "特殊符號(&P)")

collects/version/check.ss

@@ -48,6 +48,7 @@
            (with-handlers ([void (lambda (e) (err error-message e))]) expr)]))
       ;; Get server information, carefully
       (define version-info
+        '((stable "310") (recent "310")) #;
         (parameterize ([current-input-port
                         (try (url->port (format "~a?~a" version-url (version)))
                              "could not connect to website")])

collects/version/tool.ss

@@ -4,9 +4,12 @@
            (lib "framework.ss" "framework")
            (lib "mred.ss" "mred")
            (lib "class.ss")
-           (lib "list.ss")
+           "patchlevel.ss"
-           "patchlevel.ss" "check.ss"
+           "check.ss"
-           (lib "external.ss" "browser"))
+           (lib "external.ss" "browser")
+           (lib "string-constant.ss" "string-constants"))
+
+  (define download-url "http://download.plt-scheme.org/")
 
   ;; either 'yes, 'no, or something else, see `enabled?' below for a reason
   (preferences:set-default 'updates:enabled? 'unset symbol?)
@@ -22,19 +25,24 @@
   ;; have the default be #f, but without making it always #f for all users, and
   ;; in the future it is possible to change it to default to a different
   ;; default.
-  (define (enabled? v)
+  (define (is-enabled? v)
     (case v [(yes) #t] [(no) #f] [else #f])) ; default to #f
 
-  (define (check-for-updates)
+  (define (check-for-updates . top?)
+    (define enabled?  (is-enabled? (preferences:get 'updates:enabled?)))
+    (define explicit? (pair? top?)) ; top => explicit check for updates
+    (define top       (and (pair? top?) (car top?)))
     ;; wait until the definitions are instantiated, return top-level window
     (define (wait-for-definitions)
       (let ([ws (get-top-level-windows)])
         (if (null? ws)
           (begin (sleep 1) (wait-for-definitions))
           (car ws))))
+    #| ;; Cute code, but may resize the window if too much space, and people
+       ;; didn't like this way of asking if you want update checks.
     ;; show a message and a disable button
     (define hide-message void) ; set by show-message
-    (define (show-message top first-time?)
+    (define (show-message first-time?)
       ;; No info display if we got some non-drscheme window by accident
       (cond
        [(with-handlers ([void (lambda _ #f)]) (send top get-info-panel)) =>
@@ -59,57 +67,98 @@
                     (set! hide-message void))))
           #t)] ; return #t so that the check starts
        [else #f])) ; no standard window -- return #f to skip the whole thing
-    ;; disable handler
+    |#
-    (define abort void) ; used to abort an active check
+    ;; show results in a dialog in a non-modal dialog (if it was not an
-    (define (disable . _)
+    ;; explicit call) , so the window can be left around as a reminder.
-      (abort) (preferences:set 'updates:enabled? 'no))
+    (define (message style fmt . args)
-    ;; ask the question in a non-modal dialog
+      (define (run)
-    (define (question top ver)
+        (let-values ([(result new-enabled?)
-      (parameterize ([current-eventspace (make-eventspace)])
+                      (message+check-box/custom
-        (message-box/custom
+                       (string-constant version:results-title)
-         "Outdated PLT Version"
+                       (apply format fmt args)
-         (string-append "PLT Scheme v"ver" is now available")
+                       (string-constant version:do-periodic-checks)
-         "Quit && &Take Me There" "Remind Me &Later" "&Disable Checking"
+                       (string-constant ok)
-         ;; don't use `top' for the parent -- some wants a non-modal dialog
+                       (and (eq? 'newer style)
-         ;; that can be pushed back as a reminder instead of dismissed
+                            (string-constant version:take-me-there))
-         #f '(default=2) #f)))
+                       #f
+                       (and explicit? top)
+                       `(,@(case style
+                             [(#f) '()] [(newer) '(stop)] [else (list style)])
+                         ,@(if enabled? '(checked) '())
+                         default=1))])
+          (unless (eq? enabled? new-enabled?)
+            (preferences:set 'updates:enabled? (if new-enabled? 'yes 'no))
+            (set! enabled? new-enabled?))
+          result))
+      (if explicit?
+        (run)
+        ;; non-modal
+        (parameterize ([current-eventspace (make-eventspace)]) (run))))
     ;; main checker
-    (define (check top)
+    (define (check)
-      (let ([r #f])
+      (let ([result #f])
         ;; run the check in a thread, with a chance to abort it
-        (let ([t (thread (lambda () (set! r (check-version))))])
+        (let* ([d #f]
-          (set! abort (lambda () (kill-thread t)))
+               [t (thread (lambda ()
-          (thread-wait t)
+                            (set! result (check-version))
-          (set! abort void))
+                            (when d (send d show #f))))])
-        ;; do nothing if we have a good version, if there was an error, or if
+          (unless (sync/timeout .4 t) ; still checking, pop message
-        ;; there is a suggested alpha -- only show a message if there is a
+            (when explicit?           ; unless it's an automatic check
-        ;; newer version
+              (queue-callback
-        (when (and (pair? r) (eq? 'newer (car r)))
+               (lambda ()
-          (hide-message 'now)
+                 (set! d (new (class dialog%
-          (case (question top (cadr r))
+                                (super-new
-            ;; go there
+                                 [label (string-constant version:update-check)]
-            [(1) (send-url "http://download.plt-scheme.org/")
+                                 [parent #f])
-                 (sleep 1)
+                                (make-object message%
-                 ((application-quit-handler))]
+                                  (string-constant version:connecting-server)
-            ;; later
+                                  this)
-            [(2) (preferences:set 'updates:last
+                                (make-object button% (string-constant abort) this
-                                  (- (+ (current-seconds) later-delay)
+                                  (lambda (b e)
-                                     (preferences:get 'updates:frequency)))]
+                                    (kill-thread t)
-            ;; disable
+                                    (send this show #f))
-            [(3) (preferences:set 'updates:enabled? 'no)]
+                                  '(border))
-            ;; only other option is escape -- check again in the normal time
+                                (send this center))))
-            ))))
+                 (send d show #t)))
+              (sleep/yield .5))
+            (thread-wait t)))
+        (cond
+         [(and (pair? result) (eq? 'newer (car result)))
+          (when (equal? 2 (message 'newer "PLT Scheme v~a ~a ~a"
+                                   (cadr result)
+                                   (string-constant version:now-available-at)
+                                   download-url))
+            ;; 2 = go there
+            (send-url download-url)
+            ;; (sleep 1) ((application-quit-handler))
+            )]
+         ;; implicit auto-check => show a message only if there is a newer
+         ;; version => the rest are only for explicit calls
+         [(not explicit?) (void)]
+         [(eq? result 'ok)
+          (message #f (string-constant version:plt-up-to-date))]
+         [(not (pair? result)) (void)] ; either #f (canceled) or ok
+         [else (case (car result)
+                 [(error)
+                  (message 'stop "~a: ~a~a"
+                           (string-constant error) (cadr result)
+                           (if (pair? (cddr result))
+                             (string-append "\n" (caddr result)) ""))]
+                 [(ok-but)
+                  (message 'caution "~a,\n~a (v~a)"
+                           (string-constant version:plt-up-to-date)
+                           (string-constant version:but-newer-alpha)
+                           (cadr result))]
+                 [else (error 'check-for-updates "internal error")])])))
     ;; start the check if enabled and enough time passed
-    (when (enabled? (preferences:get 'updates:enabled?))
+    (when (or explicit? enabled?)
-      (let ([top  (wait-for-definitions)]
+      (unless top (set! top (wait-for-definitions)))
-            [cur  (current-seconds)]
+      (let ([cur  (current-seconds)]
             [last (preferences:get 'updates:last)]
             [freq (preferences:get 'updates:frequency)])
-        (when (and (> (- cur last) freq)
+        (when (or explicit? (> (- cur last) freq))
-                   (show-message top (zero? last))) ; last=0 => first-time
           (preferences:set 'updates:last cur)
-          (check top)
+          (check)))))
-          (hide-message)))))
 
   (provide tool@)
   (define tool@
@@ -120,15 +169,24 @@
         (preferences:add-to-warnings-checkbox-panel
          (lambda (panel)
            (let ([b (make-object check-box%
-                      "Periodically check for newer PLT Scheme versions"
+                      (string-constant version:do-periodic-checks)
                       panel
                       (lambda (b e)
                         (preferences:set 'updates:enabled?
                                          (if (send b get-value) 'yes 'no))))])
              (preferences:add-callback
               'updates:enabled?
-              (lambda (p v) (send b set-value (enabled? v))))
+              (lambda (p v) (send b set-value (is-enabled? v))))
              (send b set-value
-                   (enabled? (preferences:get 'updates:enabled?))))))
+                   (is-enabled? (preferences:get 'updates:enabled?))))))
+        (drscheme:get/extend:extend-unit-frame
+	 (lambda (f%)
+	   (class f%
+             (define/override (help-menu:after-about m)
+               (make-object menu-item%
+                 (string-constant version:update-menu-item) m
+                 (lambda (b e) (check-for-updates this)))
+               (super help-menu:after-about m))
+             (super-new))))
         (thread check-for-updates))
       (when (> patchlevel 0) (version:add-spec 'p patchlevel)))))