From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 23 Jun 2000 19:29:41 +0000 (+0000)
Subject: Preserve internal time when copying to rmail folder from any other
X-Git-Tag: 20090517-FFI~3452
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2787955a18f09c9f32bf19dbbc350966f3ff2d71;p=mit-scheme.git

Preserve internal time when copying to rmail folder from any other
type of folder, by writing a distinguished header field into the rmail
file.
---

diff --git a/v7/src/imail/imail-file.scm b/v7/src/imail/imail-file.scm
index 58f620c27..2bab9b1a0 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.48 2000/06/23 19:29:04 cph Exp $
+;;; $Id: imail-file.scm,v 1.49 2000/06/23 19:29:41 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -289,7 +289,7 @@
      (string-length (file-message-body message))))
 
 (define-method message-internal-time ((message <file-message>))
-  (header-fields->internal-time headers))
+  (header-fields->internal-time message))
 
 (define (header-fields->internal-time headers)
   (let loop ((headers (get-all-header-fields headers "received")) (winner #f))
diff --git a/v7/src/imail/imail-rmail.scm b/v7/src/imail/imail-rmail.scm
index 4b9b69143..7920a9c57 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.43 2000/06/20 19:49:16 cph Exp $
+;;; $Id: imail-rmail.scm,v 1.44 2000/06/23 19:29:05 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -84,9 +84,11 @@
 
 (define-class (<rmail-message>
 	       (constructor (header-fields body flags
-					   displayed-header-fields)))
+					   displayed-header-fields
+					   internal-time)))
     (<file-message>)
-  (displayed-header-fields define accessor))
+  (displayed-header-fields define accessor)
+  (internal-time accessor message-internal-time))
 
 (define-method rmail-message-displayed-header-fields ((message <message>))
   message
@@ -97,7 +99,8 @@
   (make-rmail-message (message-header-fields message)
 		      (file-message-body message)
 		      (list-copy (message-flags message))
-		      (rmail-message-displayed-header-fields message)))
+		      (rmail-message-displayed-header-fields message)
+		      (message-internal-time message)))
 
 ;;;; Read RMAIL file
 
@@ -145,7 +148,14 @@
 	     (body (read-to-eom port))
 	     (finish
 	      (lambda (headers displayed-headers)
-		(make-rmail-message headers body flags displayed-headers))))
+		(call-with-values
+		    (lambda () (rmail-internal-time-header headers))
+		  (lambda (headers time)
+		    (make-rmail-message headers body flags
+					displayed-headers
+					(or time
+					    (header-fields->internal-time
+					     headers))))))))
 	(if formatted?
 	    (finish headers displayed-headers)
 	    (finish displayed-headers 'UNDEFINED))))))
@@ -180,6 +190,22 @@
 	      ((string=? rmail-message:headers-separator line)
 	       (make-eof-object port))
 	      (else line)))))))
+
+(define (rmail-internal-time-header headers)
+  (let ((header (get-first-header-field headers "X-IMAIL-INTERNAL-TIME" #f)))
+    (if header
+	(values (delq! header headers)
+		(let ((t
+		       (ignore-errors
+			(lambda ()
+			  (string->universal-time
+			   (rfc822:tokens->string
+			    (rfc822:strip-comments
+			     (rfc822:string->tokens
+			      (header-field-value header)))))))))
+		  (and (not (condition? t))
+		       t)))
+	(values headers #f))))
 
 ;;;; Write RMAIL file
 
@@ -211,7 +237,16 @@
 (define (write-rmail-message message port)
   (write-char rmail-message:start-char port)
   (newline port)
-  (let ((headers (message-header-fields message))
+  (let ((headers
+	 (let ((headers (message-header-fields message))
+	       (time (message-internal-time message)))
+	   (if time
+	       (cons (make-header-field "X-IMAIL-INTERNAL-TIME"
+					(string-append
+					 " "
+					 (universal-time->string time)))
+		     headers)
+	       headers)))
 	(displayed-headers (rmail-message-displayed-header-fields message)))
     (let ((formatted? (not (eq? 'UNDEFINED displayed-headers))))
       (write-rmail-attributes-line message formatted? port)
diff --git a/v7/src/imail/todo.txt b/v7/src/imail/todo.txt
index c0f3ecfc3..dc2e651d4 100644
--- a/v7/src/imail/todo.txt
+++ b/v7/src/imail/todo.txt
@@ -1,13 +1,9 @@
 IMAIL To-Do List
-$Id: todo.txt,v 1.95 2000/06/23 19:05:40 cph Exp $
+$Id: todo.txt,v 1.96 2000/06/23 19:29:07 cph Exp $
 
 Bug fixes
 ---------
 
-* Preserve internal-date when copying to rmail folder from any other
-  type of folder, by writing a distinguished header field into the
-  rmail file.
-
 * Must be able to handle malformed headers in incoming mail.
   Generating a low-level error in this situation is unacceptable.