Change APPEND-MESSAGE to accept arguments (MESSAGE URL) rather than

(FOLDER MESSAGE) as currently.  There's no need to have the folder
open to append a message to it, and this requirement causes problems
for the IMAP back end.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 549e8ab37092d38836da03ee3f38ca0c3fb74a83..3956e0a199832c609073c8c7a91a24b869dd1910 100644 (file)
--- 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.53 2000/05/12 17:56:18 cph Exp $
+;;; $Id: imail-core.scm,v 1.54 2000/05/12 18:22:46 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -151,13 +151,20 @@
 (define-generic %copy-folder (url new-url))
 
 (define-method %copy-folder ((url <url>) (new-url <url>))
-  (let ((from (open-folder url))
-       (to (new-folder new-url)))
-    (let ((n (folder-length from)))
+  (let ((folder (open-folder url)))
+    (let ((n (folder-length folder)))
       (do ((i 0 (+ i 1)))
          ((= i n))
-       (append-message to (get-message from i))))
-    (save-folder to)))
+       (%append-message (get-message folder i) new-url)))))
+
+;; -------------------------------------------------------------------
+;; Insert a copy of MESSAGE in FOLDER at the end of the existing
+;; messages.  Unspecified result.
+
+(define (append-message message url)
+  (%append-message message (->url url)))
+
+(define-generic %append-message (message url))
 \f
 ;; -------------------------------------------------------------------
 ;; Return a list of URLs for folders that match URL-PATTERN.
@@ -292,12 +299,6 @@
   (%get-message folder index))
 
 (define-generic %get-message (folder index))
-\f
-;; -------------------------------------------------------------------
-;; Insert a copy of MESSAGE in FOLDER at the end of the existing
-;; messages.  Unspecified result.
-
-(define-generic append-message (folder message))
 
 ;; -------------------------------------------------------------------
 ;; Remove all messages in FOLDER that are marked for deletion.

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 493f042571a7023f20f09576c2d33435ba54c1aa..abcc2bed930c9e55e93828c4a7d7f80d71b8513f 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.21 2000/05/12 17:56:22 cph Exp $
+;;; $Id: imail-file.scm,v 1.22 2000/05/12 18:22:50 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -97,25 +97,33 @@
 (define-method %get-message ((folder <file-folder>) index)
   (list-ref (file-folder-messages folder) index))
 
-(define-method append-message ((folder <file-folder>) (message <message>))
-  (let ((message (copy-message message)))
-    (without-interrupts
-     (lambda ()
-       (set-file-folder-messages!
-       folder
-       (let ((messages (file-folder-messages folder)))
-         (if (pair? messages)
-             (begin
-               (let loop ((prev messages) (this (cdr messages)) (index 1))
-                 (if (pair? this)
-                     (loop this (cdr this) (fix:+ index 1))
-                     (begin
-                       (attach-message! message folder index)
-                       (set-cdr! prev (list message)))))
-               messages)
-             (begin
-               (attach-message! message folder 0)
-               (list message)))))))))
+(define-method %append-message ((message <message>) (url <file-url>))
+  (let ((folder (get-memoized-folder url)))
+    (if folder
+       (let ((message (copy-message message)))
+         (without-interrupts
+          (lambda ()
+            (set-file-folder-messages!
+             folder
+             (let ((messages (file-folder-messages folder)))
+               (if (pair? messages)
+                   (begin
+                     (let loop
+                         ((prev messages)
+                          (this (cdr messages))
+                          (index 1))
+                       (if (pair? this)
+                           (loop this (cdr this) (fix:+ index 1))
+                           (begin
+                             (attach-message! message folder index)
+                             (set-cdr! prev (list message)))))
+                     messages)
+                   (begin
+                     (attach-message! message folder 0)
+                     (list message))))))))
+       (append-message-to-file message url))))
+
+(define-generic append-message-to-file (message url))
 \f
 (define-method expunge-deleted-messages ((folder <file-folder>))
   (without-interrupts

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index aa2feafcc0f19a8d68c6be14a36a1170e05e20a1..adca138d25820d63549639dc31d93a4ccdc666ef 100644 (file)
--- 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.32 2000/05/12 18:00:52 cph Exp $
+;;; $Id: imail-imap.scm,v 1.33 2000/05/12 18:22:52 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -520,6 +520,9 @@
 (define-method %copy-folder ((url <imap-url>) (new-url <imap-url>))
   ???)
 
+(define-method %append-message ((message <message>) (url <imap-url>))
+  ???)
+
 (define-method available-folder-names ((url <imap-url>))
   ???)
 \f
@@ -566,10 +569,6 @@
   (or (imap-folder-unseen folder) 0))
 |#
 
-(define-method append-message ((folder <imap-folder>) (message <message>))
-  (guarantee-imap-folder-open folder)
-  ???)
-
 (define-method expunge-deleted-messages ((folder <imap-folder>))
   (guarantee-imap-folder-open folder)
   (imap:command:expunge (imap-folder-connection folder)))

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index d06ad6ba0b58955e5dc6905c6006408af63e8df6..ba71ea9d993d352390d301cd7cb84dcc6565a0c2 100644 (file)
--- 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.24 2000/05/10 17:03:27 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.25 2000/05/12 18:22:56 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -68,11 +68,14 @@
   (synchronize-file-folder-write folder write-rmail-file))
 
 (define (compute-rmail-folder-header-fields folder)
+  (make-rmail-folder-header-fields (folder-flags folder)))
+
+(define (make-rmail-folder-header-fields flags)
   (list (make-header-field "Version" " 5")
        (make-header-field "Labels"
                           (decorated-string-append
                            "" "," ""
-                           (flags->rmail-labels (folder-flags folder))))
+                           (flags->rmail-labels flags)))
        (make-header-field "Note" "   This is the header of an rmail file.")
        (make-header-field "Note" "   If you are seeing it in rmail,")
        (make-header-field "Note"
@@ -96,7 +99,7 @@
            (let ((message (read-rmail-message port)))
              (if message
                  (begin
-                   (append-message folder message)
+                   (append-message message (folder-url folder))
                    (loop))))))))))
 
 (define (read-rmail-prolog port)
@@ -176,13 +179,27 @@
   ;; **** Do backup of file here.
   (call-with-binary-output-file pathname
     (lambda (port)
-      (write-string "BABYL OPTIONS: -*- rmail -*-" port)
-      (newline port)
-      (write-header-fields (rmail-folder-header-fields folder) port)
-      (write-char rmail-message:end-char port)
+      (write-rmail-file-header (rmail-folder-header-fields folder))
       (for-each (lambda (message) (write-rmail-message message port))
                (file-folder-messages folder)))))
 
+(define-method append-message-to-file ((message <message>) (url <rmail-url>))
+  (let ((pathname (file-url-pathname url)))
+    (if (file-exists? pathname)
+       (let ((port (open-binary-output-file pathname #t)))
+         (write-rmail-message message port)
+         (close-port port))
+       (call-with-binary-output-file pathname
+         (lambda (port)
+           (write-rmail-file-header (make-rmail-folder-header-fields '()))
+           (write-rmail-message message port))))))
+
+(define (write-rmail-file-header header-fields)
+  (write-string "BABYL OPTIONS: -*- rmail -*-" port)
+  (newline port)
+  (write-header-fields header-fields port)
+  (write-char rmail-message:end-char port))
+
 (define (write-rmail-message message port)
   (write-char rmail-message:start-char port)
   (newline port)
@@ -248,8 +265,8 @@
                          (let ((n (folder-length inbox)))
                            (do ((index 0 (+ index 1)))
                                ((= index n))
-                             (append-message folder
-                                             (get-message inbox index))))
+                             (append-message (get-message inbox index)
+                                             (folder-url folder))))
                          inbox))
                      pathnames)))
            (save-folder folder)

diff --git a/v7/src/imail/imail-top.scm b/v7/src/imail/imail-top.scm
index 559ba8ea228782062ac7470965d4fdbec6b5532e..999d01ee3dffac201189f10a2dc7acf05ad840d5 100644 (file)
--- a/v7/src/imail/imail-top.scm
+++ b/v7/src/imail/imail-top.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: imail-top.scm,v 1.42 2000/05/12 18:00:56 cph Exp $
+;;; $Id: imail-top.scm,v 1.43 2000/05/12 18:22:59 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -660,13 +660,13 @@ Completion is performed over known flags when reading."
   "Append messages to this folder from a specified folder."
   "sInput from folder"
   (lambda (url-string)
-    (let ((folder (selected-folder))
-         (message (selected-message))
-         (folder* (open-folder url-string)))
-      (let ((n (folder-length folder*)))
+    (let ((message (selected-message))
+         (folder (open-folder url-string))
+         (url (folder-url (selected-folder))))
+      (let ((n (folder-length folder)))
        (do ((index 0 (+ index 1)))
            ((= index n))
-         (append-message folder (get-message folder* index))))
+         (append-message (get-message folder index) url)))
       (if (not message)
          (select-message folder (first-unseen-message folder))))))
 
@@ -674,9 +674,8 @@ Completion is performed over known flags when reading."
   "Append this message to a specified folder."
   "sOutput to folder"
   (lambda (url-string)
-    (let ((folder (open-folder url-string))
-         (message (selected-message)))
-      (append-message folder message)
+    (let ((message (selected-message)))
+      (append-message message url-string)
       (message-filed message)
       (if (ref-variable imail-delete-after-output)
          ((ref-command imail-delete-forward) #f))

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 991705c21dc3f1911370599f0c04a02503cbab88..d1abc5f0e65968ab2b58d866f42c93dd81270c54 100644 (file)
--- 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.18 2000/05/10 17:03:30 cph Exp $
+;;; $Id: imail-umail.scm,v 1.19 2000/05/12 18:23:03 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -138,6 +138,11 @@
       (for-each (lambda (message) (write-umail-message message port))
                (file-folder-messages folder)))))
 
+(define-method append-message-to-file ((message <message>) (url <umail-url>))
+  (let ((port (open-binary-output-file (file-url-pathname url) #t)))
+    (write-umail-message message port)
+    (close-port port)))
+
 (define (write-umail-message message port)
   (let ((from-line (get-message-property message "umail-from-line" #f)))
     (if from-line

diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index 1d8b2130b4a854ac0b43855cfc9a2658307ff72f..09eb4f0a5f30a92e87d3d8a9a38e0309cececa40 100644 (file)
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,5 +1,5 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.5 2000/05/12 17:56:46 cph Exp $
+$Id: todo.txt,v 1.6 2000/05/12 18:23:05 cph Exp $
 
 Bug fixes
 ---------
@@ -34,11 +34,6 @@ Design changes
   Binary search can be used which should produce excellent results on
   large folders.  UID FETCH command should be useful for this.
 
-* Change APPEND-MESSAGE to accept arguments (MESSAGE URL) rather than
-  (FOLDER MESSAGE) as currently.  There's no need to have the folder
-  open to append a message to it, and this requirement causes problems
-  for the IMAP back end.
-
 * Try to leverage IMAP MIME parser by building compatible
   interface for file-based folders.