From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 2 May 2000 22:13:03 +0000 (+0000)
Subject: Eliminate troublesome WRITE-FOLDER operation.  Change DELETE-FOLDER
X-Git-Tag: 20090517-FFI~3944
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2cd6c5d9aaa5e0a388ca90e1714c4ccd92b033c6;p=mit-scheme.git

Eliminate troublesome WRITE-FOLDER operation.  Change DELETE-FOLDER
and MOVE-FOLDER to close the old folders.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 361038b5a..c557cbf99 100644
--- a/v7/src/imail/imail-core.scm
+++ b/v7/src/imail/imail-core.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-core.scm,v 1.35 2000/05/02 21:42:06 cph Exp $
+;;; $Id: imail-core.scm,v 1.36 2000/05/02 22:12:39 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -120,6 +120,9 @@
 
 (define (delete-folder url)
   (let ((url (->url url)))
+    (let ((folder (get-memoized-folder url)))
+      (if folder
+	  (close-folder folder)))
     (unmemoize-folder url)
     (%delete-folder url)))
 
@@ -135,8 +138,11 @@
 (define (move-folder url new-url)
   (let ((url (->url url))
 	(new-url (->url new-url)))
-    (unmemoize-folder url)
-    (%move-folder url new-url)))
+    (%move-folder url new-url)
+    (let ((folder (get-memoized-folder url)))
+      (if folder
+	  (close-folder folder)))
+    (unmemoize-folder url)))
 
 (define-generic %move-folder (url new-url))
 
@@ -155,7 +161,13 @@
 (define-generic %copy-folder (url new-url))
 
 (define-method %copy-folder ((url <url>) (new-url <url>))
-  (%write-folder (open-folder url) new-url))
+  (let ((from (open-folder url))
+	(to (new-folder new-url)))
+    (let ((n (folder-length from)))
+      (do ((i 0 (+ i 1)))
+	  ((= i n))
+	(append-message to (get-message from i))))
+    (save-folder to)))
 
 ;; -------------------------------------------------------------------
 ;; Return a list of URLs for folders that match URL-PATTERN.
@@ -362,14 +374,6 @@
 
 (define-generic %maybe-revert-folder (folder resolve-conflict))
 (define-generic %revert-folder (folder))
-
-;; -------------------------------------------------------------------
-;; Write the contents of FOLDER to URL.
-
-(define (write-folder folder url)
-  (%write-folder folder (->url url)))
-
-(define-generic %write-folder (folder url))
 
 ;;;; Message type
 
diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index fac6cf89b..7de1581bd 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.13 2000/05/02 22:02:33 cph Exp $
+;;; $Id: imail-file.scm,v 1.14 2000/05/02 22:12:59 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -159,9 +159,6 @@
   folder
   unspecific)
 
-(define-method %save-folder ((folder <file-folder>))
-  (%write-folder folder (folder-url folder)))
-
 (define-method %maybe-revert-folder ((folder <file-folder>) resolve-conflict)
   (if (if (eqv? (file-folder-modification-time folder)
 		(file-modification-time (file-folder-pathname folder)))
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index f2ad6e23c..609e950f3 100644
--- a/v7/src/imail/imail-imap.scm
+++ b/v7/src/imail/imail-imap.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-imap.scm,v 1.10 2000/05/02 21:42:08 cph Exp $
+;;; $Id: imail-imap.scm,v 1.11 2000/05/02 22:13:00 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -392,9 +392,6 @@
 
 (define-method %revert-folder ((folder <imap-folder>))
   ???)
-
-(define-method %write-folder ((folder <folder>) (url <imap-url>))
-  ???)
 
 ;;;; IMAP command invocation
 
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 78fcbd980..e581915af 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.20 2000/05/02 22:02:49 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.21 2000/05/02 22:13:01 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -61,10 +61,9 @@
 (define-method rmail-folder-header-fields ((folder <folder>))
   (compute-rmail-folder-header-fields folder))
 
-(define-method %write-folder ((folder <folder>) (url <rmail-url>))
-  (write-rmail-file folder (file-url-pathname url))
-  (if (eq? url (folder-url folder))
-      (update-file-folder-modification-time! folder)))
+(define-method %save-folder ((folder <rmail-folder>))
+  (write-rmail-file folder (file-folder-pathname folder))
+  (update-file-folder-modification-time! folder))
 
 (define-method poll-folder ((folder <rmail-folder>))
   (rmail-get-new-mail folder))
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 4aacbde9e..5a1dc62f8 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.14 2000/05/02 22:02:54 cph Exp $
+;;; $Id: imail-umail.scm,v 1.15 2000/05/02 22:13:03 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -57,10 +57,9 @@
 
 (define-class (<umail-folder> (constructor (url))) (<file-folder>))
 
-(define-method %write-folder ((folder <folder>) (url <umail-url>))
-  (write-umail-file folder (file-url-pathname url))
-  (if (eq? url (folder-url folder))
-      (update-file-folder-modification-time! folder)))
+(define-method %save-folder ((folder <umail-folder>))
+  (write-umail-file folder (file-folder-pathname folder))
+  (update-file-folder-modification-time! folder))
 
 (define-method poll-folder ((folder <umail-folder>))
   folder