189 lines
8.3 KiB
Racket
189 lines
8.3 KiB
Racket
#lang scheme/gui
|
|
|
|
(require scheme/unit scheme/class framework drscheme/tool
|
|
browser/external string-constants
|
|
"patchlevel.ss"
|
|
"check.ss")
|
|
|
|
(define download-url "http://download.racket-lang.org/")
|
|
|
|
;; 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 week
|
|
(preferences:set-default 'updates:frequency (* 60 60 24 7) integer?)
|
|
;; time to wait if user chooses "later"; default: in two weeks
|
|
(define later-delay (* 60 60 24 14))
|
|
|
|
;; 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 #t.
|
|
(define (is-enabled? v)
|
|
(case v [(yes) #t] [(no) #f] [else #f])) ; default to #f
|
|
|
|
(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 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)) =>
|
|
(lambda (info)
|
|
(sleep 3) ; wait to make this appearance visible
|
|
(let* ([-check "Checking for updates..."]
|
|
[-about "About to auto-check for updates, you can"]
|
|
[p (make-object horizontal-panel% info)]
|
|
[m (make-object message% (if first-time? -about -check) p)]
|
|
[b (make-object button% "Disable" p disable)])
|
|
(send info change-children (lambda (l) (cons p (remq p l))))
|
|
(when first-time?
|
|
(let ([m1 (make-object message% "these checks" p)])
|
|
(sleep 20)
|
|
(send p change-children (lambda (l) (remq m1 l))))
|
|
(send m set-label -check))
|
|
(sleep 2) ; wait before and after check to make it visible
|
|
(set! hide-message
|
|
(lambda now?
|
|
(unless (and (pair? now?) (car now?)) (sleep 1))
|
|
(send info change-children (lambda (l) (remq p l)))
|
|
(set! hide-message void))))
|
|
#t)] ; return #t so that the check starts
|
|
[else #f])) ; no standard window -- return #f to skip the whole thing
|
|
|#
|
|
;; 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)
|
|
(let ([result #f])
|
|
;; run the check in a thread, with a chance to abort it
|
|
(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 (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 (or explicit? (> (- cur last) freq))
|
|
(preferences:set 'updates:last cur)
|
|
(check)))))
|
|
|
|
(provide tool@)
|
|
(define tool@
|
|
(unit (import drscheme:tool^) (export drscheme:tool-exports^)
|
|
|
|
(define (phase1) (void))
|
|
(define (phase2)
|
|
(preferences:add-to-warnings-checkbox-panel
|
|
(lambda (panel)
|
|
(let ([b (make-object check-box%
|
|
(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 (is-enabled? v))))
|
|
(send b set-value
|
|
(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))))
|