From: Chris Hanson <org/chris-hanson/cph>
Date: Wed, 17 May 2000 20:52:21 +0000 (+0000)
Subject: Implement MESSAGE-TIME.
X-Git-Tag: 20090517-FFI~3831
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=641a5229bd9a5e61f8816fac44faa09c9bba1a57;p=mit-scheme.git

Implement MESSAGE-TIME.
---

diff --git a/v7/src/imail/imail-core.scm b/v7/src/imail/imail-core.scm
index b3143dcf0..06780da57 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.67 2000/05/17 19:11:11 cph Exp $
+;;; $Id: imail-core.scm,v 1.68 2000/05/17 20:52:21 cph Exp $
 ;;;
 ;;; Copyright (c) 1999-2000 Massachusetts Institute of Technology
 ;;;
@@ -370,7 +370,7 @@
 (define (detach-message! message)
   (set-message-folder! message #f)
   (message-modified! message))
-
+
 (define-generic message-internal-time (message))
 (define-method message-internal-time ((message <message>))
   (let loop ((headers (get-all-header-fields message "received")) (winner #f))
@@ -384,9 +384,19 @@
 	    (loop (cdr headers)
 		  (if (or (not winner) (< time winner)) time winner))))
 	(or winner
-	    (let ((date (get-first-header-field-value message "date" #f)))
-	      (and date
-		   (string->universal-time date)))))))
+	    (message-time message)))))
+
+(define (message-time message)
+  (let ((date (get-first-header-field-value message "date" #f)))
+    (and date
+	 (let ((t
+		(ignore-errors
+		 (lambda ()
+		   (string->universal-time
+		    (rfc822:tokens->string
+		     (rfc822:strip-comments (rfc822:string->tokens date))))))))
+	   (and (not (condition? t))
+		t)))))
 
 ;;;; Message Navigation