adjust drracket to be more accomodating in the presence of hostile filesystems

collects/drracket/private/main.rkt

@@ -521,8 +521,6 @@
                   lang
                   (or settings (send lang default-settings)))))))))
 
-  ;; preferences initialization
-
   (preferences:set-default 'drracket:online-compilation #t boolean?)
 
   (drr:set-default 'drracket:multi-file-search:recur? #t boolean?)

collects/drracket/private/unit.rkt

@@ -1689,9 +1689,7 @@ module browser threading seems wrong.
                      #t)])))))
       
       (define/override (make-root-area-container cls parent)
-        (let* ([saved-p (preferences:get 'drracket:module-browser-size-percentage)]
+        (let* ([_module-browser-parent-panel
-               [saved-p2 (preferences:get 'drracket:logging-size-percentage)]
-               [_module-browser-parent-panel
                 (super make-root-area-container 
                        (make-two-way-prefs-dragable-panel% panel:horizontal-dragable%
                                                            'drracket:module-browser-size-percentage)
@@ -1732,8 +1730,8 @@ module browser threading seems wrong.
           (send planet-status-parent-panel change-children (λ (l) (remq planet-status-panel l)))
           (unless (toolbar-shown?)
             (send transcript-parent-panel change-children (λ (l) '())))
-          (preferences:set 'drracket:module-browser-size-percentage saved-p)
+          (send logger-outer-panel enable-two-way-prefs)
-          (preferences:set 'drracket:logging-size-percentage saved-p2)
+          (send _module-browser-parent-panel enable-two-way-prefs)
           
           root))
       
@@ -4651,15 +4649,21 @@ module browser threading seems wrong.
                     (frame:basic-mixin
                      frame%))))))))))))))))))
   
+  (define-local-member-name enable-two-way-prefs)
   (define (make-two-way-prefs-dragable-panel% % pref-key)
     (class %
       (inherit get-percentages)
+
+      (define save-prefs? #f)
+      (define/public (enable-two-way-prefs) (set! save-prefs? #t))
+      
       (define/augment (after-percentage-change)
+        (when save-prefs?
           (let ([percentages (get-percentages)])
             (when (and (pair? percentages)
                        (pair? (cdr percentages))
                        (null? (cddr percentages)))
-            (preferences:set pref-key (car percentages))))
+              (preferences:set pref-key (car percentages)))))
         (inner (void) after-percentage-change))
       (super-new)))
   

collects/framework/main.rkt

@@ -200,14 +200,19 @@
       any)
   (name-list val-list)
   @{Like @racket[put-preferences], but has more sophisticated error handling.
-    In particular, it
+    In particular, when it fails to grab a lock, it
     @itemize[
       @item{waits for three consecutive failures before informing the user}
       @item{gives the user the opportunity to ``steal'' the lockfile after the
             third failure, and}
-      @item{when failures occur, it remembers what its arguments were and if
+      @item{when lock failures occur, it remembers what its arguments were and if
             any preference save eventually succeeds, all of the past failures
-            are also written at that point.}]})
+            are also written at that point.}]
+    
+    In addition when an error is raised trying to save a preference to the preference
+    file, @racket[preferences:put-preferences/gui] logs the error using @racket[log-warning],
+    instead of raising an exception.
+    })
 
  (proc-doc/names
   preferences:get-preference/gui

collects/framework/preferences.rkt

@@ -89,7 +89,7 @@ the state transitions / contracts are:
     ;; first time reading this, check the file & unmarshall value, if
     ;; it's not there, use the default
     [(pref-default-set? p)
-     (let* (;; try to read the preferece from the preferences file
+     (let* (;; try to read the preference from the preferences file
             [v (read-pref-from-file p)]
             [v (if (eq? v none)
                  ;; no value read, take the default value
@@ -196,15 +196,15 @@ the state transitions / contracts are:
       (hash-set! callbacks
                  p 
                  (append 
-                  (hash-ref callbacks p (λ () null))
+                  (hash-ref callbacks p '())
                   (list new-cb)))
       (λ ()
         (hash-set!
          callbacks
          p
-         (let loop ([callbacks (hash-ref callbacks p (λ () null))])
+         (let loop ([callbacks (hash-ref callbacks p '())])
            (cond
-             [(null? callbacks) null]
+             [(null? callbacks) '()]
              [else 
               (let ([callback (car callbacks)])
                 (cond
@@ -216,7 +216,7 @@ the state transitions / contracts are:
 ;; check-callbacks : sym val -> void
 (define (check-callbacks p value)
   (let ([new-callbacks
-         (let loop ([callbacks (hash-ref callbacks p (λ () null))])
+         (let loop ([callbacks (hash-ref callbacks p '())])
            (cond
              [(null? callbacks) null]
              [else 
@@ -506,14 +506,21 @@ the state transitions / contracts are:
   (parameter/c ((listof symbol?) (listof any/c) . -> . any))
   put-preferences
   @{This parameter's value is called to save preference the preferences file.
-    Its interface should be just like mzlib's @racket[put-preferences].})
+    Its interface should be just like mzlib's @racket[put-preferences].
+    
+    The default value calls @racket[put-preferences] and, if there is an error,
+    then starts using a hash-table to save the preferences instead.
+    See also @racket[]})
  
  (parameter-doc
   preferences:low-level-get-preference
   (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 @racket[get-preference].})
+    file. Its interface should be just like @racket[get-preference].
+    
+    The default value calls @racket[get-preferences] and, if there is an error,
+    then starts using a hash-table to save the preferences instead.})
   
  (proc-doc/names
   preferences:snapshot? 

collects/framework/private/preferences.rkt

@@ -85,7 +85,6 @@ the state transitions / contracts are:
   (define put-pref-retry-result #f)
   
   (define (put-preferences/gui new-ps new-vs)
-    
     ;; NOTE: old ones must come first in the list, 
     ;; or else multiple sets to the same preference
     ;; will save old values, instead of new ones.
@@ -96,6 +95,7 @@ the state transitions / contracts are:
     
     (define failed #f)
     (define (record-actual-failure)
+      (printf "recording a failure\n")
       (set! number-of-consecutive-failures (+ number-of-consecutive-failures 1))
       (set! past-failure-ps ps)
       (set! past-failure-vs vs)
@@ -155,12 +155,11 @@ the state transitions / contracts are:
        #f
        '(stop ok)))
     
-    (with-handlers ((exn? 
+    (with-handlers ((exn:fail? 
-                     (λ (x)
+                     (λ (exn)
-                       (message-box
+                       (log-warning (format "preferences: failed to save ~a prefs:\n   ~a" 
-                        (string-constant drscheme)
+                                            ps
-                        (format (string-constant error-saving-preferences)
+                                            (exn-message exn))))))
-                                (exn-message x))))))
       (begin0
         (put-preferences ps vs fail-func)
         (unless failed

collects/framework/splash.rkt

@@ -308,7 +308,10 @@
    (λ () default)
    #:timeout-lock-there (λ (path) default)))
 (define (splash-set-preference name value)
-  (put-preferences (list name) (list value) void))
+  (with-handlers ((exn:fail?
+                   (λ (exn)
+                     (log-warning (format "splash pref save: ~a" (exn-message exn))))))
+    (put-preferences (list name) (list value) void)))
 
 ;; only modified (or read) on the splash eventspace handler thread
 (define quit-on-close? #t)