From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 16 May 2000 04:14:42 +0000 (+0000)
Subject: Implement MESSAGE-INTERNAL-TIME.
X-Git-Tag: 20090517-FFI~3862
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4e60d0b42202bb789b5834808c1e447d36e102e7;p=mit-scheme.git

Implement MESSAGE-INTERNAL-TIME.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index dffe99b18..aa15d75ae 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.59 2000/05/15 19:20:40 cph Exp $
+;;; $Id: imail-core.scm,v 1.60 2000/05/16 04:14:33 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -331,26 +331,6 @@
   (if (not (message? message))
       (error:wrong-type-argument message "IMAIL message" procedure)))
 
-(define (make-detached-message headers body)
-  (call-with-values (lambda () (parse-imail-header-fields headers))
-    (lambda (headers flags)
-      (make-message headers body 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)))))
-
 (define (copy-message message)
   (make-message (map copy-header-field (message-header-fields message))
 		(message-body message)
@@ -376,6 +356,24 @@
      (let ((folder (message-folder message)))
        (if folder
 	   (folder-modified! folder))))))
+
+(define-generic message-internal-time (message))
+
+(define-method message-internal-time ((message <message>))
+  (let loop ((headers (get-all-header-fields headers "received")) (winner #f))
+    (if (pair? headers)
+	(call-with-values
+	    (lambda ()
+	      (rfc822:received-header-components
+	       (header-field-value (car headers))))
+	  (lambda (from by via with id for time)
+	    from by via with id for	;ignored
+	    (loop (cdr headers)
+		  (if (or (not winner) (< time winner)) time winner))))
+	(or winner
+	    (let ((date (get-first-header-field-value headers "date" #f)))
+	      (and date
+		   (string->universal-time date)))))))
 
 ;;;; Message Navigation
 
@@ -490,6 +488,21 @@
        (cons #f (burst-string (header-field-value header) char-set:lwsp #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)))))
 
 (define (message-deleted? msg) (message-flagged? msg "deleted"))
 (define (message-undeleted? msg) (not (message-flagged? msg "deleted")))
diff --git a/v7/src/imail/imail-imap.scm b/v7/src/imail/imail-imap.scm
index 5fd4b38d4..412eead16 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.42 2000/05/16 03:36:17 cph Exp $
+;;; $Id: imail-imap.scm,v 1.43 2000/05/16 04:14:37 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -454,6 +454,13 @@
 	((string-ci=? flag "deleted") '\DELETED)
 	((string-ci=? flag "seen") '\SEEN)
 	(else (intern flag))))
+
+(define-method message-internal-time ((message <imap-message>))
+  (imap:response:fetch-attribute
+   (imap:command:fetch (imap-message-connection message)
+		       (message-index message)
+		       '(INTERNALDATE))
+   'INTERNALDATE))
 
 ;;; These reflectors are needed to guarantee that we read the
 ;;; appropriate information from the server.  Normally most message
diff --git a/v7/src/imail/imail-umail.scm b/v7/src/imail/imail-umail.scm
index c14ed4c25..3cfb93dc9 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.23 2000/05/15 19:20:58 cph Exp $
+;;; $Id: imail-umail.scm,v 1.24 2000/05/16 04:14:42 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -76,6 +76,10 @@
 		     "unknown")
 		 " "
 		 (universal-time->local-ctime-string (get-universal-time))))
+
+(define-method message-internal-time ((message <umail-message>))
+  (or (extract-umail-from-time (umail-message-from-line message))
+      (call-next-method message)))
 
 ;;;; Read unix mail file