KaMailV3 で、スレッドの表示順を変える

オリジナルのスレッド表示順は、スレッドの最初のメールで順番付けされるが、それをスレッド中のメールすべてを見て決定するようにできるようにしてみた。

(defvar *kamail3-thread-order-all-mails* t
  "スレッド内すべてのメールを見てスレッド順を決めるときは t, オリジナルの動作にするときは nil")

(defun kamail3-thread-order (key prep response-list)
  (let ((nval key)
	(rep (assoc key response-list)))
    (dolist (i (if (consp rep)
		   (mapcar #'(lambda (y) (kamail3-thread-order y prep response-list))
			   (cdr rep))))
      (if (funcall prep i nval)
	  (setq nval i)))
    nval))

(defun summary-thread-parse (messages)
  (let (id-alist
	rp-alist
	response-list
	parent-list)
    (dolist (x messages)
      (let* ((num (car x))
	     (h (cdr x))
	     (message-id  (junk::mail-get-header-value "message-id" h))
	     (in-reply-to (junk::mail-get-header-value "in-reply-to" h))
	     (references  (junk::mail-get-header-value "references" h))
	     tmp
	     )
	(if (and (stringp in-reply-to)
		 (string-match "\\(<[^>]+>\\)" in-reply-to))
	    (setq in-reply-to (match-string 1))
	  (if (stringp references)
	      (progn
		(while (string-match "<[^>]+>" references)
		  (setq tmp (match-string 0))
		  (setq references (substring references (match-end 0) (length references))))
		(if tmp
		    (setq in-reply-to tmp)
		  (setq in-reply-to nil)))))
	(push (cons message-id num) id-alist)
	(push (cons num in-reply-to) rp-alist)))
    (dolist (x (reverse rp-alist))
      (let ((num (car x))
	    (in-reply-to (cdr x))
	    parent
	    )
	(if (and in-reply-to
		 (setq parent (cdr (assoc in-reply-to id-alist :test #'equal))))
	    (let ((num-childs (assoc parent response-list)))
	      (if num-childs
		  (push num (cdr num-childs))
		(push (cons parent (list num)) response-list)))
	  (push num parent-list))))

    (if (and *kamail3-thread-order-all-mails*
	     (query-order *query-last-query*))
	(let ((prep (if (string-match "\\<NUMA\\>" (query-order *query-last-query*))
			#'>
		      #'<)))
	  ;; スレッドの表示順を変更
	  (setq parent-list (stable-sort (nreverse parent-list) #'<
					 :key #'(lambda (x)
						  (or (kamail3-thread-order x prep response-list) x)
						  )))
	  (values parent-list
		  (nreverse response-list)))
      (values (nreverse parent-list)
	      (nreverse response-list))
      )))

う〜、一年ぶりの更新。一応、生きてます。。。