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

original commit: cde613218e8b9a64e8495b050f1c9a474ab71afa

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"
+(require "private/sig.rkt"
-         "private/number-snip.ss"
+         "private/number-snip.rkt"
-         "private/comment-box.ss"
+         "private/comment-box.rkt"
-         "private/application.ss"
+         "private/application.rkt"
-         "private/version.ss"
+         "private/version.rkt"
-         "private/color-model.ss"
+         "private/color-model.rkt"
-         "private/exit.ss"
+         "private/exit.rkt"
-         "private/menu.ss"
+         "private/menu.rkt"
-         "private/preferences.ss"
+         "private/preferences.rkt"
-         "private/autosave.ss"
+         "private/autosave.rkt"
-         "private/color.ss"
+         "private/color.rkt"
-         "private/color-prefs.ss"
+         "private/color-prefs.rkt"
-         "private/handler.ss" 
+         "private/handler.rkt" 
-         "private/keymap.ss"
+         "private/keymap.rkt"
-         "private/path-utils.ss"
+         "private/path-utils.rkt"
-         "private/icon.ss"
+         "private/icon.rkt"
-         "private/editor.ss"
+         "private/editor.rkt"
-         "private/pasteboard.ss"
+         "private/pasteboard.rkt"
-         "private/text.ss"
+         "private/text.rkt"
-         "private/finder.ss"
+         "private/finder.rkt"
-         "private/group.ss"
+         "private/group.rkt"
-         "private/canvas.ss"
+         "private/canvas.rkt"
-         "private/panel.ss"
+         "private/panel.rkt"
-         "private/frame.ss"
+         "private/frame.rkt"
-         "private/scheme.ss"
+         "private/scheme.rkt"
-         "private/main.ss"
+         "private/main.rkt"
-         "private/mode.ss")
+         "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@))
 

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? 

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)

collects/framework/private/main.rkt

@@ -1,5 +1,5 @@
-#lang scheme/unit
+#lang racket/unit
-(require mzlib/class
+(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)))

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
+         (define the-mode (preferences-lock-file-mode)) 
-                (message-box/custom
+         (define mb-ans
-                 (string-constant error-saving-preferences-title)
+           (case the-mode
-                 (format (string-constant prefs-file-locked)
+             [(file-lock) 
-                         (path->string path))
+              (define-values (checked? res)
-                 (string-constant steal-the-lock-and-retry)
+                (if put-pref-retry-result
-                 (string-constant cancel)
+                    (values #t 'ok)
-                 #f
+                    (message+check-box
-                 #f ;;parent
+                     (string-constant error-saving-preferences-title)
-                 '(default=2 caution))])
+                     (format (string-constant prefs-file-locked-nothing-doing)
-           (case mb-ans
+                             path)
-             [(2 #f) (record-actual-failure)]
+                     (string-constant dont-notify-again-until-drracket-restarted))))
-             [(1) 
+              (when checked?
-              (let ([delete-failed #f])
+                (set! put-pref-retry-result #t))
-                (with-handlers ((exn:fail:filesystem? (λ (x) (set! delete-failed x))))
+               2]
-                  (delete-file path))
+             [(exists) 
-                (cond
+              (message-box/custom
-                  [delete-failed
+               (string-constant error-saving-preferences-title)
-                   (record-actual-failure)
+               (format (string-constant prefs-file-locked)
-                   (message-box 
+                       (path->string path))
-                    (string-constant error-saving-preferences-title)
+               (string-constant steal-the-lock-and-retry)
-                    (exn-message delete-failed))]
+               (string-constant cancel)
-                  [else
+               #f
-                   (put-preferences ps vs second-fail-func)]))]))]
+               #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

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^))

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)