diff --git a/collects/string-constants/danish-string-constants.ss b/collects/string-constants/danish-string-constants.ss index f96e019687..e9b9bf5793 100644 --- a/collects/string-constants/danish-string-constants.ss +++ b/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") diff --git a/collects/string-constants/dutch-string-constants.ss b/collects/string-constants/dutch-string-constants.ss index cd07c8bcae..95d6523a6f 100644 --- a/collects/string-constants/dutch-string-constants.ss +++ b/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") diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index 6e55fb6cc8..c540485478 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/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. - ;; Note that vc-wizard-check-prompt can (should) have newlines so - ;; it will not make the dialog too wide. + (version:update-menu-item "Check for Updates...") + (version:update-check "Update check") ; dialog title, with the next line + (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") diff --git a/collects/string-constants/french-string-constants.ss b/collects/string-constants/french-string-constants.ss index 574e7597fe..87d75213d2 100644 --- a/collects/string-constants/french-string-constants.ss +++ b/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. - ;; Note that vc-wizard-check-prompt can (should) have newlines so - ;; it will not make the dialog too wide. + (version:update-menu-item "Regarder les mises à jour...") + (version:update-check "Vérification des mises à jour") ;; special menu (special-menu "Spécial") diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index fe34a26ae8..ce6b2ae66d 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/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. - ;; Note that vc-wizard-check-prompt can (should) have newlines so - ;; it will not make the dialog too wide. + (version:update-menu-item "Nach Updates schauen...") + (version:update-check "Update-Prüfung") ;; special menu (special-menu "S&pezial") diff --git a/collects/string-constants/japanese-string-constants.ss b/collects/string-constants/japanese-string-constants.ss index 6b54d9be17..aae45286a3 100644 --- a/collects/string-constants/japanese-string-constants.ss +++ b/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. - ;; Note that vc-wizard-check-prompt can (should) have newlines so - ;; it will not make the dialog too wide. + (version:update-menu-item "アップデートの確認...") ;; special menu (special-menu "特殊(&P)") diff --git a/collects/string-constants/portuguese-string-constants.ss b/collects/string-constants/portuguese-string-constants.ss index 02cfc51bbf..c0330b91a8 100644 --- a/collects/string-constants/portuguese-string-constants.ss +++ b/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") diff --git a/collects/string-constants/simplified-chinese-string-constants.ss b/collects/string-constants/simplified-chinese-string-constants.ss index 64d6664d38..11f9e3f816 100644 --- a/collects/string-constants/simplified-chinese-string-constants.ss +++ b/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. - ;; Note that vc-wizard-check-prompt can (should) have newlines so - ;; it will not make the dialog too wide. + (version:update-menu-item "检查更新...") ;; special menu (special-menu "特殊符号(&P)") diff --git a/collects/string-constants/spanish-string-constants.ss b/collects/string-constants/spanish-string-constants.ss index a1dd2bd53e..f8bd352d6e 100644 --- a/collects/string-constants/spanish-string-constants.ss +++ b/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 - ;; vc-check-prompt is gone, I'm leaving this comment to make it easier to generate - ;; vc-wizard-check-note which is similar, only it is used as part of the initial - ;; wizard dialog. Note that vc-wizard-check-prompt can (should) have newlines so - ;; it will not make the dialog too wide. + ;;; version checker + (version:update-menu-item "Buscando Actualizaciones...") + (version:update-check "Revisar Actualización") ;; special menu (special-menu "Especial") diff --git a/collects/string-constants/traditional-chinese-string-constants.ss b/collects/string-constants/traditional-chinese-string-constants.ss index 009fb2d203..72e3dabd83 100644 --- a/collects/string-constants/traditional-chinese-string-constants.ss +++ b/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. - ;; Note that vc-wizard-check-prompt can (should) have newlines so - ;; it will not make the dialog too wide. + (version:update-menu-item "檢查更新...") ;; special menu (special-menu "特殊符號(&P)") diff --git a/collects/version/check.ss b/collects/version/check.ss index 55d089e76e..fbf4ffe62d 100644 --- a/collects/version/check.ss +++ b/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")]) diff --git a/collects/version/tool.ss b/collects/version/tool.ss index 01153dbc17..e42dff7d17 100644 --- a/collects/version/tool.ss +++ b/collects/version/tool.ss @@ -4,9 +4,12 @@ (lib "framework.ss" "framework") (lib "mred.ss" "mred") (lib "class.ss") - (lib "list.ss") - "patchlevel.ss" "check.ss" - (lib "external.ss" "browser")) + "patchlevel.ss" + "check.ss" + (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 - (define (disable . _) - (abort) (preferences:set 'updates:enabled? 'no)) - ;; ask the question in a non-modal dialog - (define (question top ver) - (parameterize ([current-eventspace (make-eventspace)]) - (message-box/custom - "Outdated PLT Version" - (string-append "PLT Scheme v"ver" is now available") - "Quit && &Take Me There" "Remind Me &Later" "&Disable Checking" - ;; don't use `top' for the parent -- some wants a non-modal dialog - ;; that can be pushed back as a reminder instead of dismissed - #f '(default=2) #f))) + |# + ;; show results in a dialog in a non-modal dialog (if it was not an + ;; explicit call) , so the window can be left around as a reminder. + (define (message style fmt . args) + (define (run) + (let-values ([(result new-enabled?) + (message+check-box/custom + (string-constant version:results-title) + (apply format fmt args) + (string-constant version:do-periodic-checks) + (string-constant ok) + (and (eq? 'newer style) + (string-constant version:take-me-there)) + #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) - (let ([r #f]) + (define (check) + (let ([result #f]) ;; run the check in a thread, with a chance to abort it - (let ([t (thread (lambda () (set! r (check-version))))]) - (set! abort (lambda () (kill-thread t))) - (thread-wait t) - (set! abort void)) - ;; 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))) - (hide-message 'now) - (case (question top (cadr r)) - ;; 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 - )))) + (let* ([d #f] + [t (thread (lambda () + (set! result (check-version)) + (when d (send d show #f))))]) + (unless (sync/timeout .4 t) ; still checking, pop message + (when explicit? ; unless it's an automatic check + (queue-callback + (lambda () + (set! d (new (class dialog% + (super-new + [label (string-constant version:update-check)] + [parent #f]) + (make-object message% + (string-constant version:connecting-server) + this) + (make-object button% (string-constant abort) this + (lambda (b e) + (kill-thread t) + (send this show #f)) + '(border)) + (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?)) - (let ([top (wait-for-definitions)] - [cur (current-seconds)] + (when (or explicit? enabled?) + (unless top (set! top (wait-for-definitions))) + (let ([cur (current-seconds)] [last (preferences:get 'updates:last)] [freq (preferences:get 'updates:frequency)]) - (when (and (> (- cur last) freq) - (show-message top (zero? last))) ; last=0 => first-time + (when (or explicit? (> (- cur last) freq)) (preferences:set 'updates:last cur) - (check top) - (hide-message))))) + (check))))) (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)))))