From 9a816b89443e86b736a040d00be67e8c22473fa9 Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@racket-lang.org>
Date: Fri, 2 Dec 2005 08:46:05 +0000
Subject: [PATCH] Added auto-check functionality, off by default.

svn: r1484
---
 collects/version/doc.txt | 14 +++++--
 collects/version/tool.ss | 82 +++++++++++++++++++++++++++++++++++++---
 2 files changed, 87 insertions(+), 9 deletions(-)

diff --git a/collects/version/doc.txt b/collects/version/doc.txt
index d041a593c6..05be4be570 100644
--- a/collects/version/doc.txt
+++ b/collects/version/doc.txt
@@ -22,7 +22,7 @@ your current state -- one of these:
     You have an old-but-stable version, please upgrade to `version';
     you may consider also the newer alpha version
   * `(error ,message [,additional-info])
-    An error occured, the message is a string that indicates the
+    An error occurred, the message is a string that indicates the
     error.
     The third (optional) value is a string that can be shown as the
     system error that happened.  This string will always be
@@ -36,6 +36,12 @@ _patchlevel_ module.  This module provides a single value:
 
 which is an integer that indicates the current patch level.  This is
 normally zero, but may be updated by patches to DrScheme.
-Furthermore, the "tool.ss" module makes this patchlevel appear in
-DrScheme (but the binary version as reported by `(version)' is not
-changed).
+
+
+Finally, the "tool.ss" makes DrScheme use both features:
+
+* the patchlevel appears as a version `pN' suffix in DrScheme (but the
+  binary version as reported by `(version)' is not changed);
+
+* it is possible to periodically check whether a new PLT Scheme
+  distribution is available for download.
diff --git a/collects/version/tool.ss b/collects/version/tool.ss
index 016a29183a..cf5b76e589 100644
--- a/collects/version/tool.ss
+++ b/collects/version/tool.ss
@@ -1,13 +1,85 @@
 (module tool mzscheme
   (require (lib "tool.ss" "drscheme")
            (lib "unitsig.ss")
-           (lib "framework.ss" "framework"))
-  (require "patchlevel.ss")
+           (lib "framework.ss" "framework")
+           (lib "mred.ss" "mred")
+           (lib "class.ss")
+           "patchlevel.ss" "check.ss"
+           (lib "external.ss" "browser"))
+
+  ;; either 'yes, 'no, or something else, see `enabled?' below for a reason
+  (preferences:set-default 'updates:enabled? 'unset symbol?)
+  (preferences:set-default 'updates:last 0 integer?)
+  ;; how often do we check; default: check every three days
+  (preferences:set-default 'updates:frequency (* 60 60 24 3) integer?)
+  ;; time to wait if user chooses "later"; default: in a week
+  (define later-delay (* 60 60 24 3))
+
+  ;; This is used to check if updates:enabled? is true or false.  The problem
+  ;; is that we don't want to set a default of #t or #f, so make it 'unset and
+  ;; change it only when users explicitly set it.  This makes it possible to
+  ;; 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)
+    (case v [(yes) #t] [(no) #f] [else #f])) ; default to #f
+
+  (define (check-for-updates)
+    ;; 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))))
+    (define (check top)
+      (let ([r (check-version)])
+        ;; do nothing if we have a good version, if there was an error, or if
+        ;; there is a suggested alpha -- only show a message if there is a
+        ;; newer version
+        (when (and (pair? r) (eq? 'newer (car r)))
+          (case (message-box/custom
+                 "Outdated PLT Version"
+                 (string-append "PLT Scheme v"(cadr r)"is now available")
+                 "Quit && &Take Me There" "Remind Me &Later" "&Stop Checking"
+                 top '(default=2) #f)
+            ;; go there
+            [(1) (send-url "http://download.plt-scheme.org/")
+                 (sleep 1)
+                 ((application-quit-handler))]
+            ;; later
+            [(2) (preferences:set 'updates:last
+                                  (- (+ (current-seconds) later-delay)
+                                     (preferences:get 'updates:frequency)))]
+            ;; disable
+            [(3) (preferences:set 'updates:enabled? 'no)]
+            ;; only other option is escape -- check again in the normal time
+            ))))
+    (when (enabled? (preferences:get 'updates:enabled?))
+      (let ([cur  (current-seconds)]
+            [last (preferences:get 'updates:last)]
+            [freq (preferences:get 'updates:frequency)])
+        (when (> (- cur last) freq)
+          (preferences:set 'updates:last cur)
+          (check (wait-for-definitions))))))
+
   (provide tool@)
   (define tool@
     (unit/sig drscheme:tool-exports^
       (import drscheme:tool^)
       (define (phase1) (void))
-      (define (phase2) (void))
-      (when (> patchlevel 0)
-        (version:add-spec 'p patchlevel)))))
+      (define (phase2)
+        (preferences:add-to-warnings-checkbox-panel
+         (lambda (panel)
+           (let ([b (make-object check-box%
+                      "Check for newer PLT Scheme versions"
+                      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))))
+             (send b set-value
+                   (enabled? (preferences:get 'updates:enabled?))))))
+        (thread check-for-updates))
+      (when (> patchlevel 0) (version:add-spec 'p patchlevel)))))