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

more behavior improvement to make it more explicit and easier to disable

Browse Source 
svn: r2821
This commit is contained in:
Eli Barzilay 2006-04-27 20:10:21 +00:00
parent 81e201a96e
commit ea9aeec4f0
1 changed files with 44 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

72
collects/version/tool.ss
View File

@ -34,26 +34,47 @@
(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)))))
(define (show-message top 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
;; 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)))
;; main checker
(define (check top)
(show-message top)
(let ([r #f])
;; run the check in a thread, with a chance to abort it
(let ([t (thread (lambda () (set! r (check-version))))])
@ -65,14 +86,7 @@
;; newer version
(when (and (pair? r) (eq? 'newer (car r)))
(hide-message 'now)
(case (message-box/custom
"Outdated PLT Version"
(string-append "PLT Scheme v"(cadr r)" 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)
(case (question top (cadr r))
;; go there
[(1) (send-url "http://download.plt-scheme.org/")
(sleep 1)
@ -84,16 +98,18 @@
;; disable
[(3) (preferences:set 'updates:enabled? 'no)]
;; 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?))
(let ([cur (current-seconds)]
[last (preferences:get 'updates:last)]
(let ([top (wait-for-definitions)]
[cur (current-seconds)]
[last 0 #;(preferences:get 'updates:last)]
[freq (preferences:get 'updates:frequency)])
(when (> (- cur last) freq)
(when (and (> (- cur last) freq)
(show-message top (zero? last))) ; last=0 => first-time
(preferences:set 'updates:last cur)
(check (wait-for-definitions))))))
(check top)
(hide-message))))))
(provide tool@)
(define tool@