Make SAVE-RESOURCE on file folders gracefully handle failure to write

the file.  Previously killing an IMAIL file folder buffer for a
read-only file would create an *error* buffer and fail to kill the
IMAIL buffer!

(Perhaps it would be better to add a new value to FOLDER-SYNC-STATUS,
to indicate that the persistant storage is immutable.  But putting an
error handler here is useful anyway, because the state of the world
may change between the call to FOLDER-SYNC-STATUS and the actual write
to the disk.)

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 3a4976c0c6af89da0ac4912c56c698b9bccd3a45..d11f5b773ba3fd898cb52c30e4a4de59277ce5ea 100644 (file)
--- a/v7/src/imail/imail-file.scm
+++ b/v7/src/imail/imail-file.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: imail-file.scm,v 1.93 2008/01/30 20:02:09 cph Exp $
+$Id: imail-file.scm,v 1.94 2008/02/09 10:29:03 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -404,9 +404,21 @@ USA.
             (and (eq? status 'BOTH-MODIFIED)
                  (imail-ui:prompt-for-yes-or-no?
                   "Disk file has changed since last read.  Save anyway"))))
-       (begin
-        (synchronize-file-folder-write folder write-file-folder)
-        #t)))
+       (call-with-current-continuation
+        (lambda (k)
+          (bind-condition-handler (list condition-type:error)
+              (lambda (condition)
+                ;; Can this be done in a pop-up buffer?  It doesn't
+                ;; work just to use IMAIL-UI:PRESENT-USER-ALERT
+                ;; because that futzes with the kill-buffer hooks.
+                (imail-ui:message
+                 (call-with-output-string
+                   (lambda (output-port)
+                     (write-condition-report condition output-port))))
+                (k #f))
+            (lambda ()
+              (synchronize-file-folder-write folder write-file-folder)
+              #t))))))
 
 (define-generic write-file-folder (folder pathname))