From: Taylor R Campbell <campbell@mumble.net>
Date: Thu, 7 Oct 2010 00:36:52 +0000 (+0000)
Subject: Cache parsed date, subject, author, and recipient in memory in IMAIL.
X-Git-Tag: 20101212-Gtk~53
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=405e4ed3b448a1ba2acf75e0f9e552f75b99ec39;p=mit-scheme.git

Cache parsed date, subject, author, and recipient in memory in IMAIL.

This is not really the right thing, but it substantially speeds up
sorting, and slightly speeds up summarization, without requiring the
memory overhead of keeping whole headers strongly in memory.

What IMAIL should really do is

(1) store headers (and bodies and body structures and so on) strongly
in memory, and use a secondary GC daemon to discard them when space is
short; and

(2) use a generic, compact, on-disk cache, for every folder, of the
important information for each message: date, subject, author,
recipient, message-id, thread-id.
---

diff --git a/src/imail/imail-core.scm b/src/imail/imail-core.scm
index 627563ff4..9dad4147d 100644
--- a/src/imail/imail-core.scm
+++ b/src/imail/imail-core.scm
@@ -629,11 +629,51 @@ USA.
    (lambda (port)
      (write-header-fields (message-header-fields message) port)
      (write-message-body message port))))
-
+
 (define (message-time message)
-  (let ((date (get-first-header-field-value message "date" #f)))
-    (and date
-	 (parse-header-field-date date))))
+  (intern-property! message '|#[(edwin imail)message-time]|
+    (lambda (message)
+      (let ((date (get-first-header-field-value message "date" #f)))
+	(and date
+	     (parse-header-field-date date))))))
+
+(define (message-subject message)
+  (intern-property! message '|#[(edwin imail)message-subject|
+    (lambda (message)
+      (cond ((get-first-header-field-value message "subject" #f)
+	     => strip-subject-re)
+	    (else "")))))
+
+(define (strip-subject-re subject)
+  (let ((end (string-length subject)))
+    (let loop ((start 0))
+      (if (and (fix:<= 3 (fix:- end start))
+	       (substring-prefix-ci? "Re:" 0 3 subject (fix:+ start 3) end))
+	  (loop
+	   (substring-find-next-char-in-set subject (fix:+ start 3) end
+					    char-set:subject-content))
+	  (string-tail subject start)))))
+
+(define char-set:subject-content (char-set-invert (char-set #\space #\tab)))
+
+(define (message-author message)
+  (intern-property! message '|#[(edwin imail)message-author|
+    (lambda (message)
+      (or (get-first-header-field-address message "from" #f)
+	  (get-first-header-field-address message "sender" #f)
+	  ""))))
+
+(define (message-recipient message)
+  (intern-property! message '|#[(edwin imail)message-recipient]|
+    (lambda ()
+      (or (get-first-header-field-address message "to" #f)
+	  (get-first-header-field-address message "apparently-to" #f)
+	  ""))))
+
+(define (get-first-header-field-address message name error?)
+  (let ((v (get-first-header-field-value message name error?)))
+    (and v
+	 (rfc822:first-address v))))
 
 ;;;; Message Navigation
 
diff --git a/src/imail/imail-summary.scm b/src/imail/imail-summary.scm
index ab8af0f4a..c7e732e76 100644
--- a/src/imail/imail-summary.scm
+++ b/src/imail/imail-summary.scm
@@ -591,16 +591,10 @@ SUBJECT is a string of regexps separated by commas."
 	  (else s))))
 
 (define (message-summary-subject-string message)
-  (let ((s
-	 (let ((s (or (get-first-header-field-value message "subject" #f) "")))
-	   (let ((regs (re-string-match "\\(re:[ \t]*\\)+" s #t)))
-	     (if regs
-		 (string-tail s (re-match-end-index 0 regs))
-		 s)))))
-    (let ((i (string-find-next-char s #\newline)))
-      (if i
-	  (string-head s i)
-	  s))))
+  (let ((subject (message-subject message)))
+    (cond ((string-find-next-char subject #\newline)
+	   => (lambda (line-end) (string-head subject line-end)))
+	  (else subject))))
 
 ;;;; Navigation
 
diff --git a/src/imail/imail-top.scm b/src/imail/imail-top.scm
index b54359eea..f8e0bfac9 100644
--- a/src/imail/imail-top.scm
+++ b/src/imail/imail-top.scm
@@ -1373,32 +1373,6 @@ ADDRESSES is a string consisting of several addresses separated by commas."
       (set-buffer-point! buffer point)
       (mark-temporary! point)
       value)))
-
-(define (message-subject message)
-  (let ((subject (get-first-header-field-value message "subject" #f)))
-    (if subject
-	(strip-subject-re subject)
-	"")))
-
-(define (strip-subject-re subject)
-  (if (string-prefix-ci? "re:" subject)
-      (strip-subject-re (string-trim-left (string-tail subject 3)))
-      subject))
-
-(define (message-author message)
-  (or (get-first-header-field-address message "from" #f)
-      (get-first-header-field-address message "sender" #f)
-      ""))
-
-(define (message-recipient message)
-  (or (get-first-header-field-address message "to" #f)
-      (get-first-header-field-address message "apparently-to" #f)
-      ""))
-
-(define (get-first-header-field-address message name error?)
-  (let ((v (get-first-header-field-value message name error?)))
-    (and v
-	 (rfc822:first-address v))))
 
 ;;;; Folder Operations
 
diff --git a/src/imail/imail-util.scm b/src/imail/imail-util.scm
index 7003c7117..c6ac48637 100644
--- a/src/imail/imail-util.scm
+++ b/src/imail/imail-util.scm
@@ -596,6 +596,15 @@ USA.
 (define (remove-property! object key)
   (set-object-properties! object (del-assq! key (object-properties object))))
 
+(define (intern-property! object key generator)
+  (let* ((default (cons 0 0))
+	 (datum (get-property object key default)))
+    (if (eq? datum default)
+	(let ((datum (generator object)))
+	  (store-property! object key datum)
+	  datum)
+	datum)))
+
 ;;;; Modification events
 
 (define-class <modification-event-mixin> ()