Implement MESSAGE-INTERNAL-TIME.

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index dffe99b180224a89de531fb64745474f2fe04650..aa15d75ae927cef9cd1bdd3b858ee33af8569bdc 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.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)))))
-\f
 (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)))))))
 \f
 ;;;; 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)))))
 \f
 (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 5fd4b38d4154c2e7426b795e59f595b9951c30a1..412eead162d772cb092dcba75395336694114804 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.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))
 \f
 ;;; 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 c14ed4c25e50226f35b1bc442a9177c19f8ea6e9..3cfb93dc924bfb211e6021c941509a6949ff6ef4 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.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)))
 \f
 ;;;; Read unix mail file