[PATCH] Add command rmail-summary-by-thread (was: Summary by thread in rmail)

[Andrea Monaco <andrea.monaco@autistici.org>]

This patch adds a new command rmail-summary-by-thread.  It shows a
summary of all messages that are in the same thread as a given message,
defaulting to current message.

Admittedly it's a bit complex but it works like a charm (in my tests).

First it fills rmail-summary-message-ids-hash-table, that is a hash
table linking Message-Ids with rmail message indices.

Then it fills rmail-summary-subjects-hash-table, that links simplified
Subject fields with the index of the first message having that subject.
(Yeah, I'm totally in love with hash tables!)

Then it uses those to fill rmail-summary-message-parents-vector, a
vector holding the "parents" of each message, that is the messages
referenced in the References and In-reply-to fields of that message,
plus the first message with the same subject.

With all this information, building the thread is just a matter of
walking the graph recursively, traversing parents and descendants of
each message and ticking their index in a local vector.


Andrea Monaco



diff --git a/lisp/mail/rmailsum.el b/lisp/mail/rmailsum.el
index 0144a34e5e..3e3207e974 100644
--- a/lisp/mail/rmailsum.el
+++ b/lisp/mail/rmailsum.el
@@ -67,6 +67,18 @@ rmail-summary-currently-displayed-msgs
 by `rmail-summary-fill-displayed-messages'.")
 (put 'rmail-summary-currently-displayed-msgs 'permanent-local t)
 
+(defvar rmail-summary-message-ids-hash-table nil
+  "Hash table linking Message IDs of messages with their indices.")
+
+(defvar rmail-summary-subjects-hash-table nil
+  "Hash table linking subjects with the index of the first message with that subject.")
+
+(defvar rmail-summary-message-parents-vector nil
+  "Vector that holds a list of indices of parents for each message.
+Message A is parent to message B if the id of A appear in the
+References or In-reply-to fields of B, or if A is the first
+message with the same subject as B.  First element is ignored.")
+
 (defvar rmail-summary-font-lock-keywords
   '(("^ *[0-9]+D.*" . font-lock-string-face)			; Deleted.
     ("^ *[0-9]+-.*" . font-lock-type-face)			; Unread.
@@ -297,6 +309,47 @@ rmail-summary-fill-displayed-messages
 	      ?y)
 	(forward-line 1)))))
 
+(defun rmail-summary-fill-message-ids-hash-table ()
+  "Fill `rmail-summary-message-ids-hash-table'."
+  (with-current-buffer rmail-buffer
+    (setq rmail-summary-message-ids-hash-table (make-hash-table :test 'equal :size 1024))
+    (let ((msgnum 1))
+      (while (<= msgnum rmail-total-messages)
+	(let ((id (rmail-get-header "Message-ID" msgnum)))
+	  (puthash id (cons (cons id msgnum) (gethash id rmail-summary-message-ids-hash-table))
+		   rmail-summary-message-ids-hash-table))
+	(setq msgnum (1+ msgnum))))))
+
+(defun rmail-summary--split-header-field (name &optional msgnum)
+  (let ((header (rmail-get-header name msgnum)))
+    (if header
+	(split-string header "[ \f\t\n\r\v,;]+"))))
+
+(defun rmail-summary-fill-message-parents-vector ()
+  "Fill `rmail-summary-message-parents-vector'."
+  (with-current-buffer rmail-buffer
+    (rmail-summary-fill-message-ids-hash-table)
+    (setq rmail-summary-subjects-hash-table (make-hash-table :test 'equal :size 1024))
+    (setq rmail-summary-message-parents-vector (make-vector (1+ rmail-total-messages) nil))
+    (let ((msgnum 1))
+      (while (<= msgnum rmail-total-messages)
+	(let* ((parents nil)
+	       (subject (rmail-simplified-subject msgnum))
+	       (subj-cell (gethash subject rmail-summary-subjects-hash-table))
+	       (subj-par (assoc subject subj-cell))
+	       (refs (rmail-summary--split-header-field "References" msgnum))
+	       (reply-to (rmail-summary--split-header-field "In-reply-to" msgnum)))
+	  (if subj-par
+	      (setq parents (cons (cdr subj-par) parents))
+	    (puthash subject (cons (cons subject msgnum) subj-cell)
+		     rmail-summary-subjects-hash-table))
+	  (dolist (id (append refs reply-to))
+	    (let ((ent (assoc id (gethash id rmail-summary-message-ids-hash-table))))
+	      (if ent
+		  (setq parents (cons (cdr ent) parents)))))
+	  (aset rmail-summary-message-parents-vector msgnum parents)
+	  (setq msgnum (1+ msgnum)))))))
+
 (defun rmail-summary-negate ()
   "Toggle display of messages that match the summary and those which do not."
   (interactive)
@@ -318,6 +371,57 @@ rmail-summary
   (interactive)
   (rmail-new-summary "All" '(rmail-summary) nil))
 
+(defun rmail-summary-direct-descendants (msgnum encountered-msgs)
+  "Find all direct descendants of MSGNUM.
+Assumes `rmail-summary-message-parents-vector' is filled.  Ignores messages
+already ticked in ENCOUNTERED-MSGS."
+  (let (desc
+	(msg 1))
+    (while (<= msg rmail-total-messages)
+      (when (and
+	     (eq nil (aref encountered-msgs msg))
+	     (memq msgnum (aref rmail-summary-message-parents-vector msg)))
+	(setq desc (cons msg desc)))
+      (setq msg (1+ msg)))
+    desc))
+
+(defun rmail-summary--walk-thread-message-recursively (msgnum encountered-msgs)
+  "Walk message MSGNUM by ticking parents and descendants in ENCOUNTERED-MSGS recursively."
+  (unless (eq (aref encountered-msgs msgnum) t)
+    (aset encountered-msgs msgnum t)
+    (let ((walk-thread-msg (lambda (msg) (rmail-summary--walk-thread-message-recursively msg encountered-msgs))))
+      (mapcar walk-thread-msg (aref rmail-summary-message-parents-vector msgnum))
+      (mapcar walk-thread-msg (rmail-summary-direct-descendants msgnum encountered-msgs)))))
+
+;;;###autoload
+(defun rmail-summary-by-thread (&optional msgnum)
+  "Display a summary of messages in the same thread as MSGNUM, or current message.
+Threads are based on the Subject, References and In-reply-to
+fields."
+  (interactive
+   (let* ((msg rmail-current-message)
+	  (prompt (concat "Show thread containing message number")))
+     (list (read-number prompt msg))))
+  (with-current-buffer rmail-buffer
+    (unless msgnum
+      (setq msgnum rmail-current-message))
+    (unless (and rmail-summary-message-parents-vector
+		 (= (length rmail-summary-message-parents-vector)
+		    (1+ rmail-total-messages)))
+      (rmail-summary-fill-message-parents-vector))
+    (let ((enc-msgs (make-bool-vector (1+ rmail-total-messages) nil)))
+      (rmail-summary--walk-thread-message-recursively msgnum enc-msgs)
+      (rmail-new-summary (format "thread containing message %d" msgnum)
+			 (list 'rmail-summary-by-thread msgnum)
+			 (if (and rmail-summary-intersect-consecutive-filters
+				  (rmail-summary--exists-1))
+			     (lambda (msg msgnum)
+			       (and (eq (aref rmail-summary-currently-displayed-msgs msg)
+					t)
+				    (eq (aref enc-msgs msg) t)))
+			   (lambda (msg msgnum) (eq (aref enc-msgs msg) t)))
+			 msgnum))))
+
 ;;;###autoload
 (defun rmail-summary-by-labels (labels)
   "Display a summary of all messages with one or more LABELS.