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

adjusted the framework preferences system to work better with failures under windows

Browse Source
This commit is contained in:
Robby Findler 2011-01-18 15:53:03 -06:00
parent 939f41670d
commit cde613218e
11 changed files with 162 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/browser/external.rkt
View File

@ -1,15 +1,15 @@
(module external mzscheme
#lang racket/base
(require string-constants
mred
mzlib/class
mzlib/file
mzlib/list
mzlib/match
(prefix raw: net/sendurl)
racket/class
racket/file
racket/list
racket/match
(prefix-in raw: net/sendurl)
net/url
(prefix fw: framework))
(prefix-in fw: framework))
(provide send-url
(rename raw:browser-preference? browser-preference?)
(rename-out [raw:browser-preference? browser-preference?])
update-browser-preference
install-help-browser-preference-panel
add-to-browser-prefs-panel)
@ -20,7 +20,9 @@
(fw:preferences:set-default
'external-browser
(let ([pref (get-preference 'external-browser (lambda () #f))])
(let ([pref (get-preference 'external-browser
(lambda () #f)
#:timeout-lock-there (lambda (path) #f))])
(and (raw:browser-preference? pref) pref))
raw:browser-preference?)
@ -49,7 +51,7 @@
(fw:preferences:set-default http-proxy-preference #f proxy-pref?)
(sync-current-proxy-servers (fw:preferences:get http-proxy-preference))
(fw:preferences:add-callback http-proxy-preference (lambda (p v) (sync-current-proxy-servers v)))
(void (fw:preferences:add-callback http-proxy-preference (lambda (p v) (sync-current-proxy-servers v))))
(define send-url
(if (unix-browser?)
@ -299,4 +301,4 @@
(send bad-host show #f)))
(set! synchronized? #t)
(values pref-panel callbacks))))))
(values pref-panel callbacks)))))

4
collects/drracket/private/main.rkt
View File

@ -461,7 +461,7 @@
(let ([len (length exprs)])
(when (> len max-len)
(save (drop exprs (- len max-len)))))))])
(let ([framework-prefs (get-preference 'plt:framework-prefs)])
(let ([framework-prefs (get-preference 'plt:framework-prefs #:timeout-lock-there (λ (x) #f))])
(when (and (list? framework-prefs)
(andmap pair? framework-prefs))
(let ([exprs-pref (assq 'drscheme:console-previous-exprs framework-prefs)])
@ -471,7 +471,7 @@
(put-preferences (list 'plt:framework-prefs)
(list (dict-set framework-prefs 'drscheme:console-previous-exprs (list trimmed)))
void)))))))
(trim (get-preference 'plt:framework-pref:drscheme:console-previous-exprs)
(trim (get-preference 'plt:framework-pref:drscheme:console-previous-exprs #:timeout-lock-there (λ (x) #f))
(λ (trimmed)
(put-preferences (list 'plt:framework-pref:drscheme:console-previous-exprs)
(list trimmed)

60
collects/framework/framework-unit.rkt
View File

@ -1,35 +1,36 @@
#lang scheme/base
(require mzlib/unit
(require racket/unit
mred/mred-sig)
(require "private/sig.ss"
"private/number-snip.ss"
"private/comment-box.ss"
"private/application.ss"
"private/version.ss"
"private/color-model.ss"
"private/exit.ss"
"private/menu.ss"
"private/preferences.ss"
"private/autosave.ss"
"private/color.ss"
"private/color-prefs.ss"
"private/handler.ss"
"private/keymap.ss"
"private/path-utils.ss"
"private/icon.ss"
"private/editor.ss"
"private/pasteboard.ss"
"private/text.ss"
"private/finder.ss"
"private/group.ss"
"private/canvas.ss"
"private/panel.ss"
"private/frame.ss"
"private/scheme.ss"
"private/main.ss"
"private/mode.ss")
(require "private/sig.rkt"
"private/number-snip.rkt"
"private/comment-box.rkt"
"private/application.rkt"
"private/version.rkt"
"private/color-model.rkt"
"private/exit.rkt"
"private/menu.rkt"
"private/preferences.rkt"
"private/autosave.rkt"
"private/color.rkt"
"private/color-prefs.rkt"
"private/handler.rkt"
"private/keymap.rkt"
"private/path-utils.rkt"
"private/icon.rkt"
"private/editor.rkt"
"private/pasteboard.rkt"
"private/text.rkt"
"private/finder.rkt"
"private/group.rkt"
"private/canvas.rkt"
"private/panel.rkt"
"private/frame.rkt"
"private/scheme.rkt"
"private/main.rkt"
"private/mode.rkt"
"private/early-init.rkt")
(provide framework-separate@ framework@)
@ -62,8 +63,9 @@
framework:scheme^
framework:main^)
(link
preferences@ early-init@
application@ version@ color-model@ mode@ exit@ menu@
preferences@ number-snip@ autosave@ path-utils@ icon@ keymap@
number-snip@ autosave@ path-utils@ icon@ keymap@
editor@ pasteboard@ text@ color@ color-prefs@ comment-box@
finder@ group@ canvas@ panel@ frame@ handler@ scheme@ main@))

4
collects/framework/preferences.rkt
View File

@ -505,10 +505,10 @@ the state transitions / contracts are:
(parameter-doc
preferences:low-level-get-preference
(parameter/c (->* [symbol?] [(-> any)] any))
(parameter/c (->* (symbol?) [(-> any)] any))
get-preference
@{This parameter's value is called to get a preference from the preferences
file. Its interface should be just like mzlib's @racket[get-preference].})
file. Its interface should be just like @racket[get-preference].})
(proc-doc/names
preferences:snapshot?

9
collects/framework/private/early-init.rkt Normal file
View File

@ -0,0 +1,9 @@
#lang racket/unit
(require "sig.rkt"
"../preferences.ss")
(import [prefix preferences: framework:preferences^])
(export framework:early-init^)
(init-depend framework:preferences^)
(preferences:low-level-get-preference preferences:get-preference/gui)
(preferences:low-level-put-preferences preferences:put-preferences/gui)

10
collects/framework/private/main.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/unit
(require mzlib/class
#lang racket/unit
(require racket/class
"sig.ss"
"../preferences.ss"
mred/mred-sig)
@ -11,11 +11,13 @@
[prefix handler: framework:handler^]
[prefix editor: framework:editor^]
[prefix color-prefs: framework:color-prefs^]
[prefix scheme: framework:scheme^])
[prefix scheme: framework:scheme^]
[prefix early-init: framework:early-init^])
(export framework:main^)
(init-depend framework:preferences^ framework:exit^ framework:editor^
framework:color-prefs^ framework:scheme^)
framework:color-prefs^ framework:scheme^ framework:early-init^)
(preferences:low-level-get-preference preferences:get-preference/gui)
(preferences:low-level-put-preferences preferences:put-preferences/gui)
(application-preferences-handler (λ () (preferences:show-dialog)))

108
collects/framework/private/preferences.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/unit
#lang racket/unit
#|
@ -30,7 +30,7 @@ the state transitions / contracts are:
(require string-constants
mzlib/class
scheme/file
racket/file
"sig.ss"
"../gui-utils.ss"
"../preferences.ss"
@ -46,7 +46,44 @@ the state transitions / contracts are:
(define past-failure-ps '())
(define past-failure-vs '())
(define number-of-consecutive-failures 0)
(define stop-warning? #f)
(define get-pref-retry-result #f)
(define (get-preference/gui sym [def (λ () (error 'get-preference/gui "unknown pref ~s" sym))])
(define (try)
(get-preference sym
def
#:timeout-lock-there
(λ (filename)
(define what-to-do
(cond
[get-pref-retry-result
get-pref-retry-result]
[else
(define-values (res dont-ask-again?)
(message+check-box/custom
(string-constant error-reading-preferences)
(format (string-constant error-reading-preferences-explanation)
sym)
(string-constant dont-ask-again-until-drracket-restarted) ;; check label
(string-constant try-again)
(string-constant give-up-and-use-the-default)
#f
#f
'(caution default=1)
1)) ;; cannot return #f here or get-pref-retry-result may get set wrong
(when dont-ask-again?
(set! get-pref-retry-result res))
res]))
(case what-to-do
[(1) (try)]
[(2) (def)]))))
(try))
(define put-pref-retry-result #f)
(define (put-preferences/gui new-ps new-vs)
;; NOTE: old ones must come first in the list,
@ -67,30 +104,46 @@ the state transitions / contracts are:
(cond
[(= number-of-consecutive-failures 3)
(set! number-of-consecutive-failures 0)
(let ([mb-ans
(message-box/custom
(string-constant error-saving-preferences-title)
(format (string-constant prefs-file-locked)
(path->string path))
(string-constant steal-the-lock-and-retry)
(string-constant cancel)
#f
#f ;;parent
'(default=2 caution))])
(case mb-ans
[(2 #f) (record-actual-failure)]
[(1)
(let ([delete-failed #f])
(with-handlers ((exn:fail:filesystem? (λ (x) (set! delete-failed x))))
(delete-file path))
(cond
[delete-failed
(record-actual-failure)
(message-box
(string-constant error-saving-preferences-title)
(exn-message delete-failed))]
[else
(put-preferences ps vs second-fail-func)]))]))]
(define the-mode (preferences-lock-file-mode))
(define mb-ans
(case the-mode
[(file-lock)
(define-values (checked? res)
(if put-pref-retry-result
(values #t 'ok)
(message+check-box
(string-constant error-saving-preferences-title)
(format (string-constant prefs-file-locked-nothing-doing)
path)
(string-constant dont-notify-again-until-drracket-restarted))))
(when checked?
(set! put-pref-retry-result #t))
2]
[(exists)
(message-box/custom
(string-constant error-saving-preferences-title)
(format (string-constant prefs-file-locked)
(path->string path))
(string-constant steal-the-lock-and-retry)
(string-constant cancel)
#f
#f ;;parent
'(default=2 caution))]
[else (error 'preferences.rkt "preferences-lock-file-mode returned unknown mode ~s\n" the-mode)]))
(case mb-ans
[(2 #f) (record-actual-failure)]
[(1)
(let ([delete-failed #f])
(with-handlers ((exn:fail:filesystem? (λ (x) (set! delete-failed x))))
(delete-file path))
(cond
[delete-failed
(record-actual-failure)
(message-box
(string-constant error-saving-preferences-title)
(exn-message delete-failed))]
[else
(put-preferences ps vs second-fail-func)]))])]
[else
(record-actual-failure)]))
(define (second-fail-func path)
@ -101,6 +154,7 @@ the state transitions / contracts are:
(path->string path))
#f
'(stop ok)))
(with-handlers ((exn?
(λ (x)
(message-box

3
collects/framework/private/sig.rkt
View File

@ -71,6 +71,7 @@
())
(define-signature preferences^ extends preferences-class^
(put-preferences/gui
get-preference/gui
add-panel
add-font-panel
@ -452,6 +453,8 @@
rgb->xyz
xyz->rgb))
(define-signature early-init^ ())
(define-signature framework^
((open (prefix application: application^))
(open (prefix version: version^))

7
collects/framework/splash.rkt
View File

@ -203,6 +203,7 @@
(define splash-max-width 1)
(define (close-splash)
(printf "splash-current-width ~s\n" splash-current-width)
(unless (= splash-max-width splash-current-width)
(splash-set-preference (get-splash-width-preference-name) (max 1 splash-current-width)))
(on-splash-eventspace/ret (set! quit-on-close? #f))
@ -312,10 +313,10 @@
(define (splash-get-preference name default)
(get-preference
name
(λ ()
default)))
(λ () default)
#:timeout-lock-there (λ (path) default)))
(define (splash-set-preference name value)
(put-preferences (list name) (list value)))
(put-preferences (list name) (list value) void))
;; only modified (or read) on the splash eventspace handler thread
(define quit-on-close? #t)

4
collects/net/sendurl.rkt
View File

@ -13,7 +13,9 @@
(define separate-by-default?
;; internal configuration, 'browser-default lets some browsers decide
(get-preference 'new-browser-for-urls (lambda () 'browser-default)))
(get-preference 'new-browser-for-urls
(lambda () 'browser-default)
#:timeout-lock-there (lambda (path) 'browser-default)))
;; all possible unix browsers, filtered later to just existing executables
;; order matters: the default will be the first of these that is found

8
collects/string-constants/english-string-constants.rkt
View File

@ -420,10 +420,18 @@ please adhere to these guidelines:
(error-saving-preferences "Error saving preferences: ~a")
(error-saving-preferences-title "Error saving preferences")
(steal-the-lock-and-retry "Steal the lock && retry") ;; in the preferences error dialog; this happens when the lockfile exists (after 3 pref writes).
(error-reading-preferences "Error reading preferences")
(error-reading-preferences-explanation "The preferences file is locked and thus the ~a preference cannot be read") ;; ~a is filled with the name of the preference (a symbol)
(dont-ask-again-until-drracket-restarted "Don't ask again (until DrRacket is restarted)")
; difference between the above and below is one comes with a question (steal the lock or not) and the other with just a notation saying "the file is locked"
(dont-notify-again-until-drracket-restarted "Don't notify again (until DrRacket is restarted)")
(prefs-file-locked "The preferences file is locked (because the file ~a exists), so your preference change could not be saved. Cancel preference change?")
(try-again "Try again") ;; button label
(give-up-and-use-the-default "Give up and use the default") ;; button label
(prefs-file-still-locked "The preferences file is still locked (because the file ~a exists), so your preference change will not be saved.")
(prefs-file-locked-nothing-doing "The preferences file is locked (via ~s) so changes to the preferences not be saved.") ;; the ~s is filled with the lockfile; this string is (currently) used only on windows where lockfiles are less friendly (and there is no steal fallback)
(scheme-prefs-panel-label "Racket")
(warnings-prefs-panel-label "Warnings")
(editor-prefs-panel-label "Editing")