New generic procedure MESSAGE-PERMANENT-FLAGS returns the flags that

remain permanently and are therefore useful to retain when appending
messages to other folders.  All %APPEND-MESSAGE methods now use this
rather than MESSAGE-FLAGS.  This will keep `recent' flags from being
stored in file folders as an artefact of the IMAP.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index b9d0cde716189391d1962d7de43b581904adc4bd..9efeb97ab14bfc2593be92ad2daedb07fe5364bd 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.173 2008/08/29 20:14:50 riastradh Exp $
+$Id: imail-core.scm,v 1.174 2008/08/31 23:02:17 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -659,7 +659,7 @@ USA.
     (if folder
        (unmap-folder-index folder index)
        index)))
-
+\f
 (define %set-message-flags!
   (let ((modifier (slot-modifier <message> 'FLAGS)))
     (lambda (message flags)
@@ -668,6 +668,11 @@ USA.
        (if folder
            (object-modified! folder 'FLAGS message))))))
 
+(define-generic message-permanent-flags (message))
+
+(define-method message-permanent-flags ((message <message>))
+  (message-flags message))
+
 (define (message-attached? message #!optional folder)
   (let ((folder (if (default-object? folder) #f folder)))
     (if folder

diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index a2f1cd81c72ec6f9ed9d0fd9b95c7b3e807c55a4..1657be5b5c8d6891c5de25ee2d2b12e8a9aab74e 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.228 2008/08/29 20:14:50 riastradh Exp $
+$Id: imail-imap.scm,v 1.229 2008/08/31 23:02:17 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -1074,6 +1074,13 @@ USA.
                      (lambda (flag)
                        (flags-member? flag allowed-flags)))))))))))
 
+(define-method message-permanent-flags ((message <imap-message>))
+  ;; Perhaps this should intersect the flags with the folder's list of
+  ;; permanent flags, if the folder does not allow permanent
+  ;; user-defined flags, in order to preserve only those flags that
+  ;; the IMAP folder would consider permanent.
+  (flags-delete "recent" (message-flags message)))
+
 (define (imap-flag->imail-flag flag)
   (let ((entry (assq flag standard-imap-flags)))
     (if entry
@@ -2041,9 +2048,7 @@ USA.
                (imap:command:append connection
                                     (imap-url-server-mailbox url)
                                     (map imail-flag->imap-flag
-                                         (flags-delete
-                                          "recent"
-                                          (message-flags message)))
+                                         (message-permanent-flags message))
                                     (message-internal-time message)
                                     (message->string message)))))))))
 

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index c4ce2258711409f0b5ff99db9b8131bd086a6afc..83b201a9d37ad67be84749adc38ebb7f13100432 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.78 2008/07/03 20:08:12 cph Exp $
+$Id: imail-rmail.scm,v 1.79 2008/08/31 23:02:17 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -98,7 +98,7 @@ USA.
   folder
   (make-rmail-message (message-header-fields message)
                      (file-message-body message)
-                     (list-copy (message-flags message))
+                     (list-copy (message-permanent-flags message))
                      (rmail-message-displayed-header-fields message)
                      (message-internal-time message)))
 \f

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 6c6f7ff003db835df1b666e4c51413f0bad3bd89..b7894faf7db9f8b1ac1b528e34219ea27636ab79 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.58 2008/07/03 20:08:15 cph Exp $
+$Id: imail-umail.scm,v 1.59 2008/08/31 23:02:17 riastradh Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -74,7 +74,7 @@ USA.
   folder
   (make-umail-message (message-header-fields message)
                      (file-message-body message)
-                     (list-copy (message-flags message))
+                     (list-copy (message-permanent-flags message))
                      (umail-message-from-line message)))
 
 (define-method message-internal-time ((message <umail-message>))
@@ -160,12 +160,15 @@ USA.
 (define (write-umail-message message output-flags? port)
   (write-string (umail-message-from-line message) port)
   (newline port)
-  (write-header-fields (if output-flags?
-                          (append (message-header-fields message)
-                                  (list (message-flags->header-field
-                                         (message-flags message))))
-                          (message-header-fields message))
-                      port)
+  (write-header-fields
+   (if output-flags?
+       (append (message-header-fields message)
+              (let ((flags (message-permanent-flags message)))
+                (if (pair? flags)
+                    (list (message-flags->header-field flags))
+                    '())))
+       (message-header-fields message))
+   port)
   (for-each (lambda (line)
              (if (string-prefix-ci? "From " line)
                  (write-string ">" port))