diff --git a/collects/framework/framework-unit.rkt b/collects/framework/framework-unit.rkt index d9433fef..c1bea36f 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 0182f287..6e2ec990 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 00000000..2dd7e459 --- /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 d07514c1..0077510e 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 2d18ffba..671e3ba3 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 6c11e6b4..d37a6dd0 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 979c0c3b..a4854ed4 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)