From cde613218e8b9a64e8495b050f1c9a474ab71afa Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 18 Jan 2011 15:53:03 -0600 Subject: [PATCH] adjusted the framework preferences system to work better with failures under windows --- collects/browser/external.rkt | 24 ++-- collects/drracket/private/main.rkt | 4 +- collects/framework/framework-unit.rkt | 60 +++++----- collects/framework/preferences.rkt | 4 +- collects/framework/private/early-init.rkt | 9 ++ collects/framework/private/main.rkt | 10 +- collects/framework/private/preferences.rkt | 108 +++++++++++++----- collects/framework/private/sig.rkt | 3 + collects/framework/splash.rkt | 7 +- collects/net/sendurl.rkt | 4 +- .../english-string-constants.rkt | 8 ++ 11 files changed, 162 insertions(+), 79 deletions(-) create mode 100644 collects/framework/private/early-init.rkt diff --git a/collects/browser/external.rkt b/collects/browser/external.rkt index ca88a0118a..112b66efa2 100644 --- a/collects/browser/external.rkt +++ b/collects/browser/external.rkt @@ -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))))) diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 3e3f659d4e..16bbb007b7 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -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) diff --git a/collects/framework/framework-unit.rkt b/collects/framework/framework-unit.rkt index d9433fefaa..c1bea36f2c 100644 --- a/collects/framework/framework-unit.rkt +++ b/collects/framework/framework-unit.rkt @@ -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@)) diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index 0182f28765..6e2ec99014 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -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? diff --git a/collects/framework/private/early-init.rkt b/collects/framework/private/early-init.rkt new file mode 100644 index 0000000000..2dd7e459d8 --- /dev/null +++ b/collects/framework/private/early-init.rkt @@ -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) diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index d07514c1fc..0077510eef 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -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))) diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index 2d18ffba34..671e3ba339 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -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 diff --git a/collects/framework/private/sig.rkt b/collects/framework/private/sig.rkt index 6c11e6b4c1..d37a6dd040 100644 --- a/collects/framework/private/sig.rkt +++ b/collects/framework/private/sig.rkt @@ -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^)) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 979c0c3b1b..a4854ed430 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -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) diff --git a/collects/net/sendurl.rkt b/collects/net/sendurl.rkt index cd53702f2e..440fb3e3a3 100644 --- a/collects/net/sendurl.rkt +++ b/collects/net/sendurl.rkt @@ -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 diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index fb0da785a5..e8c369b702 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -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")