suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

svn: r8812

Browse Source
This commit is contained in:
Eli Barzilay 2008-02-27 13:56:10 +00:00
parent 655351676d
commit 36b05ee127
1 changed files with 187 additions and 188 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

375
collects/version/tool.ss
View File

@ -1,194 +1,193 @@
(module tool mzscheme #lang mzscheme
(require (lib "tool.ss" "drscheme")
mzlib/unit
framework
mred
mzlib/class
"patchlevel.ss"
"check.ss"
(lib "external.ss" "browser")
string-constants)
(define download-url "http://download.plt-scheme.org/") (require (lib "tool.ss" "drscheme")
mzlib/unit
framework
mred
mzlib/class
"patchlevel.ss"
"check.ss"
(lib "external.ss" "browser")
string-constants)
;; either 'yes, 'no, or something else, see `enabled?' below for a reason (define download-url "http://download.plt-scheme.org/")
(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 ;; either 'yes, 'no, or something else, see `enabled?' below for a reason
;; is that we don't want to set a default of #t or #f, so make it 'unset and (preferences:set-default 'updates:enabled? 'unset symbol?)
;; change it only when users explicitly set it. This makes it possible to (preferences:set-default 'updates:last 0 integer?)
;; have the default be #f, but without making it always #f for all users, and ;; how often do we check; default: check every week
;; in the future it is possible to change it to default to a different (preferences:set-default 'updates:frequency (* 60 60 24 7) integer?)
;; default. ;; time to wait if user chooses "later"; default: in two weeks
(define (is-enabled? v) (define later-delay (* 60 60 24 14))
(case v [(yes) #t] [(no) #f] [else #f])) ; default to #f
(define (check-for-updates . top?) ;; This is used to check if updates:enabled? is true or false. The problem is
(define enabled? (is-enabled? (preferences:get 'updates:enabled?))) ;; that we don't want to set a default of #t or #f, so make it 'unset and
(define explicit? (pair? top?)) ; top => explicit check for updates ;; change it only when users explicitly set it. This makes it possible to have
(define top (and (pair? top?) (car top?))) ;; the default be #f, but without making it always #f for all users, and in the
;; wait until the definitions are instantiated, return top-level window ;; future it is possible to change it to default to a different default.
(define (wait-for-definitions) (define (is-enabled? v)
(let ([ws (get-top-level-windows)]) (case v [(yes) #t] [(no) #f] [else #f])) ; default to #f
(if (null? ws)
(begin (sleep 1) (wait-for-definitions)) (define (check-for-updates . top?)
(car ws)))) (define enabled? (is-enabled? (preferences:get 'updates:enabled?)))
#| ;; Cute code, but may resize the window if too much space, and people (define explicit? (pair? top?)) ; top => explicit check for updates
;; didn't like this way of asking if you want update checks. (define top (and (pair? top?) (car top?)))
;; show a message and a disable button ;; wait until the definitions are instantiated, return top-level window
(define hide-message void) ; set by show-message (define (wait-for-definitions)
(define (show-message first-time?) (let ([ws (get-top-level-windows)])
;; No info display if we got some non-drscheme window by accident (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 (cond
[(with-handlers ([void (lambda _ #f)]) (send top get-info-panel)) => [(and (pair? result) (eq? 'newer (car result)))
(lambda (info) (when (equal? 2 (message 'newer "PLT Scheme v~a ~a ~a"
(sleep 3) ; wait to make this appearance visible (cadr result)
(let* ([-check "Checking for updates..."] (string-constant version:now-available-at)
[-about "About to auto-check for updates, you can"] download-url))
[p (make-object horizontal-panel% info)] ;; 2 = go there
[m (make-object message% (if first-time? -about -check) p)] (send-url download-url)
[b (make-object button% "Disable" p disable)]) ;; (sleep 1) ((application-quit-handler))
(send info change-children (lambda (l) (cons p (remq p l)))) )]
(when first-time? ;; implicit auto-check => show a message only if there is a newer
(let ([m1 (make-object message% "these checks" p)]) ;; version => the rest are only for explicit calls
(sleep 20) [(not explicit?) (void)]
(send p change-children (lambda (l) (remq m1 l)))) [(eq? result 'ok)
(send m set-label -check)) (message #f (string-constant version:plt-up-to-date))]
(sleep 2) ; wait before and after check to make it visible [(not (pair? result)) (void)] ; either #f (canceled) or ok
(set! hide-message [else (case (car result)
(lambda now? [(error)
(unless (and (pair? now?) (car now?)) (sleep 1)) (message 'stop "~a: ~a~a"
(send info change-children (lambda (l) (remq p l))) (string-constant error) (cadr result)
(set! hide-message void)))) (if (pair? (cddr result))
#t)] ; return #t so that the check starts (string-append "\n" (caddr result)) ""))]
[else #f])) ; no standard window -- return #f to skip the whole thing [(ok-but)
|# (message 'caution "~a,\n~a (v~a)"
;; show results in a dialog in a non-modal dialog (if it was not an (string-constant version:plt-up-to-date)
;; explicit call) , so the window can be left around as a reminder. (string-constant version:but-newer-alpha)
(define (message style fmt . args) (cadr result))]
(define (run) [else (error 'check-for-updates "internal error")])])))
(let-values ([(result new-enabled?) ;; start the check if enabled and enough time passed
(message+check-box/custom (when (or explicit? enabled?)
(string-constant version:results-title) (unless top (set! top (wait-for-definitions)))
(apply format fmt args) (let ([cur (current-seconds)]
(string-constant version:do-periodic-checks) [last (preferences:get 'updates:last)]
(string-constant ok) [freq (preferences:get 'updates:frequency)])
(and (eq? 'newer style) (when (or explicit? (> (- cur last) freq))
(string-constant version:take-me-there)) (preferences:set 'updates:last cur)
#f (check)))))
(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@) (provide tool@)
(define tool@ (define tool@
(unit (unit (import drscheme:tool^) (export drscheme:tool-exports^)
(import drscheme:tool^)
(export drscheme:tool-exports^) (define (phase1) (void))
(define (phase1) (void)) (define (phase2)
(define (phase2) (preferences:add-to-warnings-checkbox-panel
(preferences:add-to-warnings-checkbox-panel (lambda (panel)
(lambda (panel) (let ([b (make-object check-box%
(let ([b (make-object check-box% (string-constant version:do-periodic-checks)
(string-constant version:do-periodic-checks) panel
panel (lambda (b e)
(lambda (b e) (preferences:set 'updates:enabled?
(preferences:set 'updates:enabled? (if (send b get-value) 'yes 'no))))])
(if (send b get-value) 'yes 'no))))]) (preferences:add-callback
(preferences:add-callback 'updates:enabled?
'updates:enabled? (lambda (p v) (send b set-value (is-enabled? v))))
(lambda (p v) (send b set-value (is-enabled? v)))) (send b set-value
(send b set-value (is-enabled? (preferences:get 'updates:enabled?))))))
(is-enabled? (preferences:get 'updates:enabled?)))))) (drscheme:get/extend:extend-unit-frame
(drscheme:get/extend:extend-unit-frame (lambda (f%)
(lambda (f%) (class f%
(class f% (define/override (help-menu:after-about m)
(define/override (help-menu:after-about m) (make-object menu-item%
(make-object menu-item% (string-constant version:update-menu-item) m
(string-constant version:update-menu-item) m (lambda (b e) (check-for-updates this)))
(lambda (b e) (check-for-updates this))) (super help-menu:after-about m))
(super help-menu:after-about m)) (super-new))))
(super-new)))) (thread check-for-updates))
(thread check-for-updates)) (when (> patchlevel 0) (version:add-spec 'p patchlevel))))
(when (> patchlevel 0) (version:add-spec 'p patchlevel)))))