Eliminate problem where RMAIL and IMAIL are both trying to insert

internal headers at the beginning of the message, and then assuming
their own headers are first.  IMAIL now strips out all of its internal
headers when a message is read, regardless of their position, and
appends new ones to the end of the headers block when the message is
written.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index 89b4dba90139cbb4bc9986c1dbab3967b809d295..bb679ad09b9b0351c659c9992e83d45898edd08a 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.170 2008/05/19 00:00:12 riastradh Exp $
+$Id: imail-core.scm,v 1.171 2008/07/03 20:08:07 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -940,33 +940,17 @@ USA.
   '("answered" "deleted" "filed" "forwarded" "resent" "seen"))
 
 (define (message-flags->header-field flags)
-  (make-header-field message-flags:name
-                    (decorated-string-append "" " " "" flags)))
-
-(define (header-field->message-flags header)
-  (and (string-ci=? message-flags:name (header-field-name header))
-       ;; Extra pair needed to distinguish #F from ().
-       (cons #f
-            (burst-string (header-field-value header)
-                          char-set:whitespace
-                          #t))))
-
-(define message-flags:name "X-IMAIL-FLAGS")
-
-(define (parse-imail-header-fields headers)
-  (let loop ((headers headers) (headers* '()) (flags '()))
-    (cond ((not (pair? headers))
-          (values (reverse! headers*)
-                  (remove-duplicates! (reverse! flags) string-ci=?)))
-         ((header-field->message-flags (car headers))
-          => (lambda (flags*)
-               (loop (cdr headers)
-                     headers*
-                     (append! (reverse! (cdr flags*)) flags))))
-         (else
-          (loop (cdr headers)
-                (cons (car headers) headers*)
-                flags)))))
+  (make-internal-header-field "FLAGS"
+                             (decorated-string-append "" " " "" flags)))
+
+(define (header-fields->message-flags headers)
+  (delete-duplicates! (map (lambda (header)
+                            (burst-string (header-field-value header)
+                                          char-set:whitespace
+                                          #t))
+                          (filter (internal-header-field-predicate "FLAGS")
+                                  headers))
+                     string-ci=?))
 \f
 (define (message-deleted? msg) (message-flagged? msg "deleted"))
 (define (message-undeleted? msg) (not (message-flagged? msg "deleted")))
@@ -1189,6 +1173,28 @@ USA.
   (let ((colon (string-find-next-char line #\:)))
     (and colon
         (rfc822:header-field-name? line 0 colon))))
+
+(define (internal-header-field? header)
+  (string-prefix-ci? internal-header-field-prefix (header-field-name header)))
+
+(define (make-internal-header-field name value)
+  (make-header-field (string-append internal-header-field-prefix name)
+                    value))
+
+(define (internal-header-field-name header)
+  (string-tail (header-field-name header)
+              internal-header-field-prefix-length))
+
+(define (internal-header-field-predicate name)
+  (lambda (header)
+    (and (internal-header-field? header)
+        (string-ci=? (internal-header-field-name header) name))))
+
+(define internal-header-field-prefix
+  "X-IMAIL-")
+
+(define internal-header-field-prefix-length
+  (string-length internal-header-field-prefix))
 \f
 ;;;; MIME structure
 

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index d11f5b773ba3fd898cb52c30e4a4de59277ce5ea..d021ca3f463f1110c5059e2255d6958493f5ee59 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.94 2008/02/09 10:29:03 riastradh Exp $
+$Id: imail-file.scm,v 1.95 2008/07/03 20:08:09 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -530,7 +530,8 @@ USA.
 (define-file-external-message-method message-header-fields
   <file-message>
   'HEADER-FIELDS
-  string->header-fields)
+  (lambda (s)
+    (remove! internal-header-field? (string->header-fields s))))
 
 (define-generic file-message-body (message))
 
@@ -599,22 +600,9 @@ USA.
             (file-time->universal-time t)))
       (get-universal-time)))
 
-(define (file-folder-strip-internal-headers folder ref)
-  (call-with-input-xstring (file-folder-xstring folder)
-                          (file-external-ref/start ref)
-    (lambda (port)
-      (let loop ((header-lines '()))
-       (let ((line (read-line port))
-             (finish
-              (lambda (offset)
-                (values (make-file-external-ref
-                         (- (xstring-port/position port)
-                            offset)
-                         (file-external-ref/end ref))
-                        (lines->header-fields (reverse! header-lines))))))
-         (cond ((eof-object? line)
-                (finish 0))
-               ((re-string-match "X-IMAIL-[^:]+:\\|[ \t]" line)
-                (loop (cons line header-lines)))
-               (else
-                (finish (+ (string-length line) 1)))))))))
\ No newline at end of file
+(define (file-folder-internal-headers folder ref)
+  (filter! internal-header-field?
+          (string->header-fields
+           (xsubstring (file-folder-xstring folder)
+                       (file-external-ref/start ref)
+                       (file-external-ref/end ref)))))
\ No newline at end of file

diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 56c9eababdf5f779cbbe84a34f201680c67f17cb..c4ce2258711409f0b5ff99db9b8131bd086a6afc 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.77 2008/01/30 20:02:09 cph Exp $
+$Id: imail-rmail.scm,v 1.78 2008/07/03 20:08:12 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -143,25 +143,20 @@ USA.
           (error "Malformed RMAIL file:" port)))))
 
 (define (read-rmail-message-1 folder port)
-  (call-with-values (lambda () (read-rmail-attributes-line port))
-    (lambda (formatted? flags)
-      (let* ((headers (read-rmail-alternate-headers port))
-            (displayed-headers (read-rmail-displayed-headers port))
-            (body (read-rmail-body port))
-            (finish
-             (lambda (headers displayed-headers)
-               (call-with-values
-                   (lambda ()
-                     (parse-rmail-internal-time-header folder headers))
-                 (lambda (headers time)
-                   (make-rmail-message headers
-                                       body
-                                       flags
-                                       displayed-headers
-                                       time))))))
-       (if formatted?
-           (finish headers displayed-headers)
-           (finish displayed-headers 'UNDEFINED))))))
+  (receive (formatted? flags) (read-rmail-attributes-line port)
+    (let* ((headers (read-rmail-alternate-headers port))
+          (displayed-headers (read-rmail-displayed-headers port))
+          (body (read-rmail-body port))
+          (finish
+           (lambda (headers displayed-headers)
+             (make-rmail-message headers
+                                 body
+                                 flags
+                                 displayed-headers
+                                 (rmail-internal-time folder headers)))))
+      (if formatted?
+         (finish headers displayed-headers)
+         (finish displayed-headers 'UNDEFINED)))))
 \f
 (define (read-rmail-attributes-line port)
   (let ((line (read-required-line port)))
@@ -229,17 +224,12 @@ USA.
     (input-port/discard-char port)
     (make-file-external-ref start (- (xstring-port/position port) 1))))
 
-(define (parse-rmail-internal-time-header folder headers)
-  (call-with-values
-      (lambda () (file-folder-strip-internal-headers folder headers))
-    (lambda (headers internal-headers)
-      (values headers
-             (let ((v
-                    (get-first-header-field internal-headers
-                                            "X-IMAIL-INTERNAL-TIME"
-                                            #f)))
-               (and v
-                    (parse-header-field-date v)))))))
+(define (rmail-internal-time folder ref)
+  (let ((v
+        (find (internal-header-field-predicate "INTERNAL-TIME")
+              (file-folder-internal-headers folder ref))))
+    (and v
+        (parse-header-field-date v))))
 \f
 ;;;; Write RMAIL file
 
@@ -270,9 +260,11 @@ USA.
         (let ((headers (message-header-fields message))
               (time (message-internal-time message)))
           (if time
-              (cons (make-header-field "X-IMAIL-INTERNAL-TIME"
-                                       (universal-time->string time))
-                    headers)
+              (append headers
+                      (list
+                       (make-internal-header-field
+                        "INTERNAL-TIME"
+                        (universal-time->string time))))
               headers)))
        (displayed-headers (rmail-message-displayed-header-fields message)))
     (let ((formatted? (not (eq? 'UNDEFINED displayed-headers))))

diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index 79683ffaf378758102b49405166932aea52b8bda..6c6f7ff003db835df1b666e4c51413f0bad3bd89 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.57 2008/01/30 20:02:10 cph Exp $
+$Id: imail-umail.scm,v 1.58 2008/07/03 20:08:15 cph Exp $
 
 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
     1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
@@ -133,15 +133,11 @@ USA.
                   (loop)))))))))
 
 (define (read-umail-message-1 folder from-line headers body)
-  (call-with-values
-      (lambda () (file-folder-strip-internal-headers folder headers))
-    (lambda (headers internal-headers)
-      (call-with-values
-         (lambda ()
-           (parse-imail-header-fields internal-headers))
-       (lambda (internal-headers flags)
-         internal-headers
-         (make-umail-message headers body flags from-line))))))
+  (make-umail-message headers
+                     body
+                     (header-fields->message-flags
+                      (file-folder-internal-headers folder headers))
+                     from-line))
 
 (define (umail-delimiter? line)
   (re-string-match unix-mail-delimiter line))
@@ -164,10 +160,12 @@ USA.
 (define (write-umail-message message output-flags? port)
   (write-string (umail-message-from-line message) port)
   (newline port)
-  (if output-flags?
-      (write-header-field (message-flags->header-field (message-flags message))
-                         port))
-  (write-header-fields (message-header-fields message) 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)
   (for-each (lambda (line)
              (if (string-prefix-ci? "From " line)
                  (write-string ">" port))