From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 2 May 2000 22:02:54 +0000 (+0000)
Subject: Implement CLOSE-FOLDER method for file folders, by discarding the
X-Git-Tag: 20090517-FFI~3945
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=f3173f4bd94c327c6f8feaa192e52d7972976b0c;p=mit-scheme.git

Implement CLOSE-FOLDER method for file folders, by discarding the
messages in the folder.  The messages are automatically reloaded when
needed.
---

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index ba81d03d6..fac6cf89b 100644
--- 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.12 2000/05/02 21:42:07 cph Exp $
+;;; $Id: imail-file.scm,v 1.13 2000/05/02 22:02:33 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -58,9 +58,16 @@
 ;;;; Folder
 
 (define-class <file-folder> (<folder>)
-  (messages define standard initial-value '())
+  (messages define standard
+	    accessor %file-folder-messages
+	    initial-value 'UNKNOWN)
   (modification-time define standard initial-value #f))
 
+(define (file-folder-messages folder)
+  (if (eq? 'UNKNOWN (%file-folder-messages folder))
+      (%revert-folder folder))
+  (%file-folder-messages folder))
+
 (define (file-folder-pathname folder)
   (file-url-pathname (folder-url folder)))
 
@@ -71,8 +78,13 @@
   (folder-not-modified! folder))
 
 (define-method %close-folder ((folder <file-folder>))
-  folder
-  unspecific)
+  (without-interrupts
+   (lambda ()
+     (let ((messages (%file-folder-messages folder)))
+       (if (not (eq? 'UNKNOWN messages))
+	   (begin
+	     (set-file-folder-messages! folder 'UNKNOWN)
+	     (for-each detach-message messages)))))))
 
 (define-method %folder-valid? ((folder <file-folder>))
   (file-exists? (file-folder-pathname folder)))
@@ -103,7 +115,7 @@
 		(set-message-index! message 0)
 		(list message)))))
        (message-modified! message)))))
-
+
 (define-method expunge-deleted-messages ((folder <file-folder>))
   (without-interrupts
    (lambda ()
@@ -125,7 +137,7 @@
 	      (loop (cdr messages)
 		    (fix:+ index 1)
 		    (cons (car messages) messages*))))))))
-
+
 (define-method search-folder ((folder <file-folder>) criteria)
   (cond ((string? criteria)
 	 (let ((n (folder-length folder)))
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 6fb28bad8..78fcbd980 100644
--- a/v7/src/imail/imail-rmail.scm
+++ b/v7/src/imail/imail-rmail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-rmail.scm,v 1.19 2000/04/27 02:16:41 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.20 2000/05/02 22:02:49 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -38,10 +38,15 @@
 ;;;; Server operations
 
 (define-method %open-folder ((url <rmail-url>))
-  (read-rmail-file (file-url-pathname url)))
+  (if (not (file-readable? (file-url-pathname url)))
+      (error:bad-range-argument url 'OPEN-FOLDER))
+  (make-rmail-folder url))
 
 (define-method %new-folder ((url <rmail-url>))
+  (if (file-exists? (file-url-pathname url))
+      (error:bad-range-argument url 'NEW-FOLDER))
   (let ((folder (make-rmail-folder url)))
+    (set-file-folder-messages! folder '())
     (set-rmail-folder-header-fields!
      folder
      (compute-rmail-folder-header-fields folder))
@@ -77,11 +82,6 @@
 
 ;;;; Read RMAIL file
 
-(define (read-rmail-file pathname)
-  (let ((folder (make-rmail-folder (make-rmail-url pathname))))
-    (%revert-folder folder)
-    folder))
-
 (define-method %revert-folder ((folder <rmail-folder>))
   (call-with-binary-input-file (file-folder-pathname folder)
     (lambda (port)
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index c16bb6beb..4aacbde9e 100644
--- a/v7/src/imail/imail-umail.scm
+++ b/v7/src/imail/imail-umail.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-umail.scm,v 1.13 2000/05/02 21:09:08 cph Exp $
+;;; $Id: imail-umail.scm,v 1.14 2000/05/02 22:02:54 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -38,13 +38,21 @@
 ;;;; Server operations
 
 (define-method %open-folder ((url <umail-url>))
-  (read-umail-file (file-url-pathname url)))
+  (if (not (file-readable? (file-url-pathname url)))
+      (error:bad-range-argument url 'OPEN-FOLDER))
+  (make-umail-folder url))
 
 (define-method %new-folder ((url <umail-url>))
+  (if (file-exists? (file-url-pathname url))
+      (error:bad-range-argument url 'NEW-FOLDER))
   (let ((folder (make-umail-folder url)))
+    (set-file-folder-messages! folder '())
     (save-folder folder)
     folder))
 
+(define (read-umail-file pathname)
+  (make-umail-folder (make-umail-url pathname)))
+
 ;;;; Folder
 
 (define-class (<umail-folder> (constructor (url))) (<file-folder>))
@@ -60,11 +68,6 @@
 
 ;;;; Read unix mail file
 
-(define (read-umail-file pathname)
-  (let ((folder (make-umail-folder (make-umail-url pathname))))
-    (%revert-folder folder)
-    folder))
-
 (define-method %revert-folder ((folder <umail-folder>))
   (set-file-folder-messages!
    folder