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

use a status-bar notification

Browse Source 
svn: r2816
This commit is contained in:
Eli Barzilay 2006-04-27 16:08:45 +00:00
parent 8d8ed10e3e
commit b8b78d4349
2 changed files with 41 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/version/check.ss
View File

@ -64,7 +64,7 @@
version-info)) version-info))
(err "bad response from server" version-info)) (err "bad response from server" version-info))
;; Make a decision ;; Make a decision
(let ([current (version)] (let ([current "300"#;(version)]
[stable (get 'stable)] [stable (get 'stable)]
[recent (get 'recent)]) [recent (get 'recent)])
(cond (cond

50
collects/version/tool.ss
View File

@ -4,6 +4,7 @@
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "list.ss")
"patchlevel.ss" "check.ss" "patchlevel.ss" "check.ss"
(lib "external.ss" "browser")) (lib "external.ss" "browser"))
@ -31,20 +32,47 @@
(if (null? ws) (if (null? ws)
(begin (sleep 1) (wait-for-definitions)) (begin (sleep 1) (wait-for-definitions))
(car ws)))) (car ws))))
;; show a message and a disable button
(define hide-message void) ; set by show-message
(define (show-message top)
(sleep 3) ; wait to make this appearance visible
(let* ([info (send top get-info-panel)]
[panel (make-object horizontal-panel% info)]
[message (make-object message% "Checking for updates..." panel)]
[button (make-object button% "Disable" panel disable)])
(send info change-children (lambda (l) (cons panel (remq panel l))))
(sleep 1) ; 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 panel l)))
(set! hide-message void)))))
;; disable handler
(define abort void) ; used to abort an active check
(define (disable . _)
(abort) (preferences:set 'updates:enabled? 'no))
;; main checker
(define (check top) (define (check top)
;; some wants a non-modal dialog that can be pushed back as a reminder (show-message top)
;; instead of dismiss (let ([r #f])
(set! top #f) ;; run the check in a thread, with a chance to abort it
(let ([r (check-version)]) (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 ;; 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 ;; there is a suggested alpha -- only show a message if there is a
;; newer version ;; newer version
(when (and (pair? r) (eq? 'newer (car r))) (when (and (pair? r) (eq? 'newer (car r)))
(hide-message 'now)
(case (message-box/custom (case (message-box/custom
"Outdated PLT Version" "Outdated PLT Version"
(string-append "PLT Scheme v"(cadr r)" is now available") (string-append "PLT Scheme v"(cadr r)" is now available")
"Quit && &Take Me There" "Remind Me &Later" "&Stop Checking" "Quit && &Take Me There" "Remind Me &Later" "&Disable Checking"
top '(default=2) #f) ;; 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)
;; go there ;; go there
[(1) (send-url "http://download.plt-scheme.org/") [(1) (send-url "http://download.plt-scheme.org/")
(sleep 1) (sleep 1)
@ -56,13 +84,15 @@
;; disable ;; disable
[(3) (preferences:set 'updates:enabled? 'no)] [(3) (preferences:set 'updates:enabled? 'no)]
;; only other option is escape -- check again in the normal time ;; only other option is escape -- check again in the normal time
)))) )))
(hide-message))
;; start the check if enabled and enough time passed
(when (enabled? (preferences:get 'updates:enabled?)) (when (enabled? (preferences:get 'updates:enabled?))
(let ([cur (current-seconds)] (let ([cur (current-seconds)]
[last (preferences:get 'updates:last)] [last (preferences:get 'updates:last)]
[freq (preferences:get 'updates:frequency)]) [freq (preferences:get 'updates:frequency)])
(when (> (- cur last) freq) (when '(> (- cur last) freq)
(preferences:set 'updates:last cur) '(preferences:set 'updates:last cur)
(check (wait-for-definitions)))))) (check (wait-for-definitions))))))
(provide tool@) (provide tool@)
@ -74,7 +104,7 @@
(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%
"Check for newer PLT Scheme versions" "Periodically check for newer PLT Scheme versions"
panel panel
(lambda (b e) (lambda (b e)
(preferences:set 'updates:enabled? (preferences:set 'updates:enabled?