1;;; mh-thread.el --- MH-E threading support 2 3;; Copyright (C) 2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc. 4 5;; Author: Satyaki Das <satyaki@theforce.stanford.edu> 6;; Maintainer: Bill Wohler <wohler@newt.com> 7;; Keywords: mail 8;; See: mh-e.el 9 10;; This file is part of GNU Emacs. 11 12;; GNU Emacs is free software; you can redistribute it and/or modify 13;; it under the terms of the GNU General Public License as published by 14;; the Free Software Foundation; either version 2, or (at your option) 15;; any later version. 16 17;; GNU Emacs is distributed in the hope that it will be useful, 18;; but WITHOUT ANY WARRANTY; without even the implied warranty of 19;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 20;; GNU General Public License for more details. 21 22;; You should have received a copy of the GNU General Public License 23;; along with GNU Emacs; see the file COPYING. If not, write to the 24;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 25;; Boston, MA 02110-1301, USA. 26 27;;; Commentary: 28 29;; The threading portion of this files tries to implement the 30;; algorithm described at: 31;; http://www.jwz.org/doc/threading.html 32;; It also begins to implement the IMAP Threading extension RFC. The 33;; implementation lacks the reference and subject canonicalization of 34;; the RFC. 35 36;; In the presentation buffer, children messages are shown indented 37;; with either [ ] or < > around them. Square brackets ([ ]) denote 38;; that the algorithm can point out some headers which when taken 39;; together implies that the unindented message is an ancestor of the 40;; indented message. If no such proof exists then angles (< >) are 41;; used. 42 43;; If threading is slow on your machine, compile this file. Of all the 44;; files in MH-E, this one really benefits from compilation. 45 46;; Some issues and problems are as follows: 47 48;; (1) Scan truncates the fields at length 512. So longer 49;; references: headers get mutilated. The same kind of MH 50;; format string works when composing messages. Is there a way 51;; to avoid this? My scan command is as follows: 52;; scan +folder -width 10000 \ 53;; -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n" 54;; I would really appreciate it if someone would help me with this. 55 56;; (2) Implement heuristics to recognize message identifiers in 57;; In-Reply-To: header. Right now it just assumes that the last 58;; text between angles (< and >) is the message identifier. 59;; There is the chance that this will incorrectly use an email 60;; address like a message identifier. 61 62;; (3) Error checking of found message identifiers should be done. 63 64;; (4) Since this breaks the assumption that message indices 65;; increase as one goes down the buffer, the binary search 66;; based mh-goto-msg doesn't work. I have a simpler replacement 67;; which may be less efficient. 68 69;; (5) Better canonicalizing for message identifier and subject 70;; strings. 71 72;;; Change Log: 73 74;;; Code: 75 76(require 'mh-e) 77(require 'mh-scan) 78 79(mh-defstruct (mh-thread-message (:conc-name mh-message-) 80 (:constructor mh-thread-make-message)) 81 (id nil) 82 (references ()) 83 (subject "") 84 (subject-re-p nil)) 85 86(mh-defstruct (mh-thread-container (:conc-name mh-container-) 87 (:constructor mh-thread-make-container)) 88 message parent children 89 (real-child-p t)) 90 91(defvar mh-thread-id-hash nil 92 "Hashtable used to canonicalize message identifiers.") 93(make-variable-buffer-local 'mh-thread-id-hash) 94 95(defvar mh-thread-subject-hash nil 96 "Hashtable used to canonicalize subject strings.") 97(make-variable-buffer-local 'mh-thread-subject-hash) 98 99(defvar mh-thread-id-table nil 100 "Thread ID table maps from message identifiers to message containers.") 101(make-variable-buffer-local 'mh-thread-id-table) 102 103(defvar mh-thread-index-id-map nil 104 "Table to look up message identifier from message index.") 105(make-variable-buffer-local 'mh-thread-index-id-map) 106 107(defvar mh-thread-id-index-map nil 108 "Table to look up message index number from message identifier.") 109(make-variable-buffer-local 'mh-thread-id-index-map) 110 111(defvar mh-thread-subject-container-hash nil 112 "Hashtable used to group messages by subject.") 113(make-variable-buffer-local 'mh-thread-subject-container-hash) 114 115(defvar mh-thread-duplicates nil 116 "Hashtable used to associate messages with the same message identifier.") 117(make-variable-buffer-local 'mh-thread-duplicates) 118 119(defvar mh-thread-history () 120 "Variable to remember the transformations to the thread tree. 121When new messages are added, these transformations are rewound, 122then the links are added from the newly seen messages. Finally 123the transformations are redone to get the new thread tree. This 124makes incremental threading easier.") 125(make-variable-buffer-local 'mh-thread-history) 126 127(defvar mh-thread-body-width nil 128 "Width of scan substring that contains subject and body of message.") 129 130 131 132;;; MH-Folder Commands 133 134;;;###mh-autoload 135(defun mh-thread-ancestor (&optional thread-root-flag) 136 "Display ancestor of current message. 137 138If you do not care for the way a particular thread has turned, 139you can move up the chain of messages with this command. This 140command can also take a prefix argument THREAD-ROOT-FLAG to jump 141to the message that started everything." 142 (interactive "P") 143 (beginning-of-line) 144 (cond ((not (memq 'unthread mh-view-ops)) 145 (error "Folder isn't threaded")) 146 ((eobp) 147 (error "No message at point"))) 148 (let ((current-level (mh-thread-current-indentation-level))) 149 (cond (thread-root-flag 150 (while (mh-thread-immediate-ancestor)) 151 (mh-maybe-show)) 152 ((equal current-level 1) 153 (message "Message has no ancestor")) 154 (t (mh-thread-immediate-ancestor) 155 (mh-maybe-show))))) 156 157;;;###mh-autoload 158(defun mh-thread-delete () 159 "Delete thread." 160 (interactive) 161 (cond ((not (memq 'unthread mh-view-ops)) 162 (error "Folder isn't threaded")) 163 ((eobp) 164 (error "No message at point")) 165 (t (let ((region (mh-thread-find-children))) 166 (mh-iterate-on-messages-in-region () (car region) (cadr region) 167 (mh-delete-a-msg nil)) 168 (mh-next-msg))))) 169 170;;;###mh-autoload 171(defun mh-thread-next-sibling (&optional previous-flag) 172 "Display next sibling. 173 174With non-nil optional argument PREVIOUS-FLAG jump to the previous 175sibling." 176 (interactive) 177 (cond ((not (memq 'unthread mh-view-ops)) 178 (error "Folder isn't threaded")) 179 ((eobp) 180 (error "No message at point"))) 181 (beginning-of-line) 182 (let ((point (point)) 183 (done nil) 184 (my-level (mh-thread-current-indentation-level))) 185 (while (and (not done) 186 (equal (forward-line (if previous-flag -1 1)) 0) 187 (not (eobp))) 188 (let ((level (mh-thread-current-indentation-level))) 189 (cond ((equal level my-level) 190 (setq done 'success)) 191 ((< level my-level) 192 (message "No %s sibling" (if previous-flag "previous" "next")) 193 (setq done 'failure))))) 194 (cond ((eq done 'success) (mh-maybe-show)) 195 ((eq done 'failure) (goto-char point)) 196 (t (message "No %s sibling" (if previous-flag "previous" "next")) 197 (goto-char point))))) 198 199;;;###mh-autoload 200(defun mh-thread-previous-sibling () 201 "Display previous sibling." 202 (interactive) 203 (mh-thread-next-sibling t)) 204 205;;;###mh-autoload 206(defun mh-thread-refile (folder) 207 "Refile (output) thread into FOLDER." 208 (interactive (list (intern (mh-prompt-for-refile-folder)))) 209 (cond ((not (memq 'unthread mh-view-ops)) 210 (error "Folder isn't threaded")) 211 ((eobp) 212 (error "No message at point")) 213 (t (let ((region (mh-thread-find-children))) 214 (mh-iterate-on-messages-in-region () (car region) (cadr region) 215 (mh-refile-a-msg nil folder)) 216 (mh-next-msg))))) 217 218;;;###mh-autoload 219(defun mh-toggle-threads () 220 "Toggle threaded view of folder." 221 (interactive) 222 (let ((msg-at-point (mh-get-msg-num nil)) 223 (old-buffer-modified-flag (buffer-modified-p)) 224 (buffer-read-only nil)) 225 (cond ((memq 'unthread mh-view-ops) 226 (unless (mh-valid-view-change-operation-p 'unthread) 227 (error "Can't unthread folder")) 228 (let ((msg-list ())) 229 (goto-char (point-min)) 230 (while (not (eobp)) 231 (let ((index (mh-get-msg-num nil))) 232 (when index 233 (push index msg-list))) 234 (forward-line)) 235 (mh-scan-folder mh-current-folder 236 (mapcar #'(lambda (x) (format "%s" x)) 237 (mh-coalesce-msg-list msg-list)) 238 t)) 239 (when mh-index-data 240 (mh-index-insert-folder-headers) 241 (mh-notate-cur))) 242 (t (mh-thread-folder) 243 (push 'unthread mh-view-ops))) 244 (when msg-at-point (mh-goto-msg msg-at-point t t)) 245 (set-buffer-modified-p old-buffer-modified-flag) 246 (mh-recenter nil))) 247 248 249 250;;; Support Routines 251 252(defun mh-thread-current-indentation-level () 253 "Find the number of spaces by which current message is indented." 254 (save-excursion 255 (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width 256 mh-scan-date-width 1)) 257 (level 0)) 258 (beginning-of-line) 259 (forward-char address-start-offset) 260 (while (char-equal (char-after) ? ) 261 (incf level) 262 (forward-char)) 263 level))) 264 265(defun mh-thread-immediate-ancestor () 266 "Jump to immediate ancestor in thread tree." 267 (beginning-of-line) 268 (let ((point (point)) 269 (ancestor-level (- (mh-thread-current-indentation-level) 2)) 270 (done nil)) 271 (if (< ancestor-level 0) 272 nil 273 (while (and (not done) (equal (forward-line -1) 0)) 274 (when (equal ancestor-level (mh-thread-current-indentation-level)) 275 (setq done t))) 276 (unless done 277 (goto-char point)) 278 done))) 279 280(defun mh-thread-find-children () 281 "Return a region containing the current message and its children. 282The result is returned as a list of two elements. The first is 283the point at the start of the region and the second is the point 284at the end." 285 (beginning-of-line) 286 (if (eobp) 287 nil 288 (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width 289 mh-scan-date-width 1)) 290 (level (mh-thread-current-indentation-level)) 291 spaces begin) 292 (setq begin (point)) 293 (setq spaces (format (format "%%%ss" (1+ level)) "")) 294 (forward-line) 295 (block nil 296 (while (not (eobp)) 297 (forward-char address-start-offset) 298 (unless (equal (string-match spaces (buffer-substring-no-properties 299 (point) (mh-line-end-position))) 300 0) 301 (beginning-of-line) 302 (backward-char) 303 (return)) 304 (forward-line))) 305 (list begin (point))))) 306 307 308 309;;; Thread Creation 310 311(defun mh-thread-folder () 312 "Generate thread view of folder." 313 (message "Threading %s..." (buffer-name)) 314 (mh-thread-initialize) 315 (goto-char (point-min)) 316 (mh-remove-all-notation) 317 (let ((msg-list ())) 318 (mh-iterate-on-range msg (cons (point-min) (point-max)) 319 (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line)) 320 (push msg msg-list)) 321 (let* ((range (mh-coalesce-msg-list msg-list)) 322 (thread-tree (mh-thread-generate (buffer-name) range))) 323 (delete-region (point-min) (point-max)) 324 (mh-thread-print-scan-lines thread-tree) 325 (mh-notate-user-sequences) 326 (mh-notate-deleted-and-refiled) 327 (mh-notate-cur) 328 (message "Threading %s...done" (buffer-name))))) 329 330;;;###mh-autoload 331(defun mh-thread-inc (folder start-point) 332 "Update thread tree for FOLDER. 333All messages after START-POINT are added to the thread tree." 334 (mh-thread-rewind-pruning) 335 (mh-remove-all-notation) 336 (goto-char start-point) 337 (let ((msg-list ())) 338 (while (not (eobp)) 339 (let ((index (mh-get-msg-num nil))) 340 (when (numberp index) 341 (push index msg-list) 342 (setf (gethash index mh-thread-scan-line-map) 343 (mh-thread-parse-scan-line))) 344 (forward-line))) 345 (let ((thread-tree (mh-thread-generate folder msg-list)) 346 (buffer-read-only nil) 347 (old-buffer-modified-flag (buffer-modified-p))) 348 (delete-region (point-min) (point-max)) 349 (mh-thread-print-scan-lines thread-tree) 350 (mh-notate-user-sequences) 351 (mh-notate-deleted-and-refiled) 352 (mh-notate-cur) 353 (set-buffer-modified-p old-buffer-modified-flag)))) 354 355(defmacro mh-thread-initialize-hash (var test) 356 "Initialize the hash table in VAR. 357TEST is the test to use when creating a new hash table." 358 (unless (symbolp var) (error "Expected a symbol: %s" var)) 359 `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test)))) 360 361(defun mh-thread-initialize () 362 "Make new hash tables, or clear them if already present." 363 (mh-thread-initialize-hash mh-thread-id-hash #'equal) 364 (mh-thread-initialize-hash mh-thread-subject-hash #'equal) 365 (mh-thread-initialize-hash mh-thread-id-table #'eq) 366 (mh-thread-initialize-hash mh-thread-id-index-map #'eq) 367 (mh-thread-initialize-hash mh-thread-index-id-map #'eql) 368 (mh-thread-initialize-hash mh-thread-scan-line-map #'eql) 369 (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq) 370 (mh-thread-initialize-hash mh-thread-duplicates #'eq) 371 (setq mh-thread-history ())) 372 373(defsubst mh-thread-id-container (id) 374 "Given ID, return the corresponding container in `mh-thread-id-table'. 375If no container exists then a suitable container is created and 376the id-table is updated." 377 (when (not id) 378 (error "1")) 379 (or (gethash id mh-thread-id-table) 380 (setf (gethash id mh-thread-id-table) 381 (let ((message (mh-thread-make-message :id id))) 382 (mh-thread-make-container :message message))))) 383 384(defsubst mh-thread-remove-parent-link (child) 385 "Remove parent link of CHILD if it exists." 386 (let* ((child-container (if (mh-thread-container-p child) 387 child (mh-thread-id-container child))) 388 (parent-container (mh-container-parent child-container))) 389 (when parent-container 390 (setf (mh-container-children parent-container) 391 (loop for elem in (mh-container-children parent-container) 392 unless (eq child-container elem) collect elem)) 393 (setf (mh-container-parent child-container) nil)))) 394 395(defsubst mh-thread-add-link (parent child &optional at-end-p) 396 "Add links so that PARENT becomes a parent of CHILD. 397Doesn't make any changes if CHILD is already an ancestor of 398PARENT. If optional argument AT-END-P is non-nil, the CHILD is 399added to the end of the children list of PARENT." 400 (let ((parent-container (cond ((null parent) nil) 401 ((mh-thread-container-p parent) parent) 402 (t (mh-thread-id-container parent)))) 403 (child-container (if (mh-thread-container-p child) 404 child (mh-thread-id-container child)))) 405 (when (and parent-container 406 (not (mh-thread-ancestor-p child-container parent-container)) 407 (not (mh-thread-ancestor-p parent-container child-container))) 408 (mh-thread-remove-parent-link child-container) 409 (cond ((not at-end-p) 410 (push child-container (mh-container-children parent-container))) 411 ((null (mh-container-children parent-container)) 412 (push child-container (mh-container-children parent-container))) 413 (t (let ((last-child (mh-container-children parent-container))) 414 (while (cdr last-child) 415 (setq last-child (cdr last-child))) 416 (setcdr last-child (cons child-container nil))))) 417 (setf (mh-container-parent child-container) parent-container)) 418 (unless parent-container 419 (mh-thread-remove-parent-link child-container)))) 420 421(defun mh-thread-rewind-pruning () 422 "Restore the thread tree to its state before pruning." 423 (while mh-thread-history 424 (let ((action (pop mh-thread-history))) 425 (cond ((eq (car action) 'DROP) 426 (mh-thread-remove-parent-link (cadr action)) 427 (mh-thread-add-link (caddr action) (cadr action))) 428 ((eq (car action) 'PROMOTE) 429 (let ((node (cadr action)) 430 (parent (caddr action)) 431 (children (cdddr action))) 432 (dolist (child children) 433 (mh-thread-remove-parent-link child) 434 (mh-thread-add-link node child)) 435 (mh-thread-add-link parent node))) 436 ((eq (car action) 'SUBJECT) 437 (let ((node (cadr action))) 438 (mh-thread-remove-parent-link node) 439 (setf (mh-container-real-child-p node) t))))))) 440 441(defun mh-thread-ancestor-p (ancestor successor) 442 "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. 443In the limit, the function returns t if ANCESTOR and SUCCESSOR 444are the same containers." 445 (block nil 446 (while successor 447 (when (eq ancestor successor) (return t)) 448 (setq successor (mh-container-parent successor))) 449 nil)) 450 451;; Another and may be better approach would be to generate all the info from 452;; the scan which generates the threading info. For now this will have to do. 453;;;###mh-autoload 454(defun mh-thread-parse-scan-line (&optional string) 455 "Parse a scan line. 456If optional argument STRING is given then that is assumed to be 457the scan line. Otherwise uses the line at point as the scan line 458to parse." 459 (let* ((string (or string (buffer-substring-no-properties 460 (mh-line-beginning-position) 461 (mh-line-end-position)))) 462 (address-start (+ mh-cmd-note mh-scan-field-from-start-offset)) 463 (body-start (+ mh-cmd-note mh-scan-field-from-end-offset)) 464 (first-string (substring string 0 address-start))) 465 (list first-string 466 (substring string address-start (- body-start 2)) 467 (substring string body-start) 468 string))) 469 470(defsubst mh-thread-canonicalize-id (id) 471 "Produce canonical string representation for ID. 472This allows cheap string comparison with EQ." 473 (or (and (equal id "") (copy-sequence "")) 474 (gethash id mh-thread-id-hash) 475 (setf (gethash id mh-thread-id-hash) id))) 476 477(defsubst mh-thread-prune-subject (subject) 478 "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT. 479If the result after pruning is not the empty string then it is 480canonicalized so that subjects can be tested for equality with 481eq. This is done so that all the messages without a subject are 482not put into a single thread." 483 (let ((case-fold-search t) 484 (subject-pruned-flag nil)) 485 ;; Prune subject leader 486 (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*" 487 subject) 488 (string-match "^[ \t]*\\[[^\\]][ \t]*" subject)) 489 (setq subject-pruned-flag t) 490 (setq subject (substring subject (match-end 0)))) 491 ;; Prune subject trailer 492 (while (or (string-match "(fwd)$" subject) 493 (string-match "[ \t]+$" subject)) 494 (setq subject-pruned-flag t) 495 (setq subject (substring subject 0 (match-beginning 0)))) 496 ;; Canonicalize subject only if it is non-empty 497 (cond ((equal subject "") (values subject subject-pruned-flag)) 498 (t (values 499 (or (gethash subject mh-thread-subject-hash) 500 (setf (gethash subject mh-thread-subject-hash) subject)) 501 subject-pruned-flag))))) 502 503(defsubst mh-thread-group-by-subject (roots) 504 "Group the set of message containers, ROOTS based on subject. 505Bug: Check for and make sure that something without Re: is made 506the parent in preference to something that has it." 507 (clrhash mh-thread-subject-container-hash) 508 (let ((results ())) 509 (dolist (root roots) 510 (let* ((subject (mh-thread-container-subject root)) 511 (parent (gethash subject mh-thread-subject-container-hash))) 512 (cond (parent (mh-thread-remove-parent-link root) 513 (mh-thread-add-link parent root t) 514 (setf (mh-container-real-child-p root) nil) 515 (push `(SUBJECT ,root) mh-thread-history)) 516 (t 517 (setf (gethash subject mh-thread-subject-container-hash) root) 518 (push root results))))) 519 (nreverse results))) 520 521(defun mh-thread-container-subject (container) 522 "Return the subject of CONTAINER. 523If CONTAINER is empty return the subject info of one of its 524children." 525 (cond ((and (mh-container-message container) 526 (mh-message-id (mh-container-message container))) 527 (mh-message-subject (mh-container-message container))) 528 (t (block nil 529 (dolist (kid (mh-container-children container)) 530 (when (and (mh-container-message kid) 531 (mh-message-id (mh-container-message kid))) 532 (let ((kid-message (mh-container-message kid))) 533 (return (mh-message-subject kid-message))))) 534 (error "This can't happen"))))) 535 536(defsubst mh-thread-update-id-index-maps (id index) 537 "Message with id, ID is the message in INDEX. 538The function also checks for duplicate messages (that is multiple 539messages with the same ID). These messages are put in the 540`mh-thread-duplicates' hash table." 541 (let ((old-index (gethash id mh-thread-id-index-map))) 542 (when old-index (push old-index (gethash id mh-thread-duplicates))) 543 (setf (gethash id mh-thread-id-index-map) index) 544 (setf (gethash index mh-thread-index-id-map) id))) 545 546(defsubst mh-thread-get-message-container (message) 547 "Return container which has MESSAGE in it. 548If there is no container present then a new container is 549allocated." 550 (let* ((id (mh-message-id message)) 551 (container (gethash id mh-thread-id-table))) 552 (cond (container (setf (mh-container-message container) message) 553 container) 554 (t (setf (gethash id mh-thread-id-table) 555 (mh-thread-make-container :message message)))))) 556 557(defsubst mh-thread-get-message (id subject-re-p subject refs) 558 "Return appropriate message. 559Otherwise update message already present to have the proper ID, 560SUBJECT-RE-P, SUBJECT and REFS fields." 561 (let* ((container (gethash id mh-thread-id-table)) 562 (message (if container (mh-container-message container) nil))) 563 (cond (message 564 (setf (mh-message-subject-re-p message) subject-re-p) 565 (setf (mh-message-subject message) subject) 566 (setf (mh-message-id message) id) 567 (setf (mh-message-references message) refs) 568 message) 569 (container 570 (setf (mh-container-message container) 571 (mh-thread-make-message :id id :references refs 572 :subject subject 573 :subject-re-p subject-re-p))) 574 (t (let ((message (mh-thread-make-message :id id :references refs 575 :subject-re-p subject-re-p 576 :subject subject))) 577 (prog1 message 578 (mh-thread-get-message-container message))))))) 579 580(defvar mh-message-id-regexp "^<.*@.*>$" 581 "Regexp to recognize whether a string is a message identifier.") 582 583;;;###mh-autoload 584(defun mh-thread-generate (folder msg-list) 585 "Scan FOLDER to get info for threading. 586Only information about messages in MSG-LIST are added to the tree." 587 (with-temp-buffer 588 (mh-thread-set-tables folder) 589 (when msg-list 590 (apply 591 #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil 592 "-width" "10000" "-format" 593 "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n" 594 folder (mapcar #'(lambda (x) (format "%s" x)) msg-list))) 595 (goto-char (point-min)) 596 (let ((roots ()) 597 (case-fold-search t)) 598 (block nil 599 (while (not (eobp)) 600 (block process-message 601 (let* ((index-line 602 (prog1 (buffer-substring (point) (mh-line-end-position)) 603 (forward-line))) 604 (index (string-to-number index-line)) 605 (id (prog1 (buffer-substring (point) (mh-line-end-position)) 606 (forward-line))) 607 (refs (prog1 608 (buffer-substring (point) (mh-line-end-position)) 609 (forward-line))) 610 (in-reply-to (prog1 (buffer-substring (point) 611 (mh-line-end-position)) 612 (forward-line))) 613 (subject (prog1 614 (buffer-substring 615 (point) (mh-line-end-position)) 616 (forward-line))) 617 (subject-re-p nil)) 618 (unless (gethash index mh-thread-scan-line-map) 619 (return-from process-message)) 620 (unless (integerp index) (return)) ;Error message here 621 (multiple-value-setq (subject subject-re-p) 622 (mh-thread-prune-subject subject)) 623 (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) 624 (setq refs (loop for x in (append (split-string refs) in-reply-to) 625 when (string-match mh-message-id-regexp x) 626 collect x)) 627 (setq id (mh-thread-canonicalize-id id)) 628 (mh-thread-update-id-index-maps id index) 629 (setq refs (mapcar #'mh-thread-canonicalize-id refs)) 630 (mh-thread-get-message id subject-re-p subject refs) 631 (do ((ancestors refs (cdr ancestors))) 632 ((null (cdr ancestors)) 633 (when (car ancestors) 634 (mh-thread-remove-parent-link id) 635 (mh-thread-add-link (car ancestors) id))) 636 (mh-thread-add-link (car ancestors) (cadr ancestors))))))) 637 (maphash #'(lambda (k v) 638 (declare (ignore k)) 639 (when (null (mh-container-parent v)) 640 (push v roots))) 641 mh-thread-id-table) 642 (setq roots (mh-thread-prune-containers roots)) 643 (prog1 (setq roots (mh-thread-group-by-subject roots)) 644 (let ((history mh-thread-history)) 645 (set-buffer folder) 646 (setq mh-thread-history history)))))) 647 648(defun mh-thread-set-tables (folder) 649 "Use the tables of FOLDER in current buffer." 650 (flet ((mh-get-table (symbol) 651 (save-excursion 652 (set-buffer folder) 653 (symbol-value symbol)))) 654 (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) 655 (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) 656 (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) 657 (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) 658 (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) 659 (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) 660 (setq mh-thread-subject-container-hash 661 (mh-get-table 'mh-thread-subject-container-hash)) 662 (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) 663 (setq mh-thread-history (mh-get-table 'mh-thread-history)))) 664 665(defun mh-thread-process-in-reply-to (reply-to-header) 666 "Extract message id's from REPLY-TO-HEADER. 667Ideally this should have some regexp which will try to guess if a 668string between < and > is a message id and not an email address. 669For now it will take the last string inside angles." 670 (let ((end (mh-search-from-end ?> reply-to-header))) 671 (when (numberp end) 672 (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end)))) 673 (when (numberp begin) 674 (list (substring reply-to-header begin (1+ end)))))))) 675 676(defun mh-thread-prune-containers (roots) 677 "Prune empty containers in the containers ROOTS." 678 (let ((dfs-ordered-nodes ()) 679 (work-list roots)) 680 (while work-list 681 (let ((node (pop work-list))) 682 (dolist (child (mh-container-children node)) 683 (push child work-list)) 684 (push node dfs-ordered-nodes))) 685 (while dfs-ordered-nodes 686 (let ((node (pop dfs-ordered-nodes))) 687 (cond ((gethash (mh-message-id (mh-container-message node)) 688 mh-thread-id-index-map) 689 ;; Keep it 690 (setf (mh-container-children node) 691 (mh-thread-sort-containers (mh-container-children node)))) 692 ((and (mh-container-children node) 693 (or (null (cdr (mh-container-children node))) 694 (mh-container-parent node))) 695 ;; Promote kids 696 (let ((children ())) 697 (dolist (kid (mh-container-children node)) 698 (mh-thread-remove-parent-link kid) 699 (mh-thread-add-link (mh-container-parent node) kid) 700 (push kid children)) 701 (push `(PROMOTE ,node ,(mh-container-parent node) ,@children) 702 mh-thread-history) 703 (mh-thread-remove-parent-link node))) 704 ((mh-container-children node) 705 ;; Promote the first orphan to parent and add the other kids as 706 ;; his children 707 (setf (mh-container-children node) 708 (mh-thread-sort-containers (mh-container-children node))) 709 (let ((new-parent (car (mh-container-children node))) 710 (other-kids (cdr (mh-container-children node)))) 711 (mh-thread-remove-parent-link new-parent) 712 (dolist (kid other-kids) 713 (mh-thread-remove-parent-link kid) 714 (setf (mh-container-real-child-p kid) nil) 715 (mh-thread-add-link new-parent kid t)) 716 (push `(PROMOTE ,node ,(mh-container-parent node) 717 ,new-parent ,@other-kids) 718 mh-thread-history) 719 (mh-thread-remove-parent-link node))) 720 (t 721 ;; Drop it 722 (push `(DROP ,node ,(mh-container-parent node)) 723 mh-thread-history) 724 (mh-thread-remove-parent-link node))))) 725 (let ((results ())) 726 (maphash #'(lambda (k v) 727 (declare (ignore k)) 728 (when (and (null (mh-container-parent v)) 729 (gethash (mh-message-id (mh-container-message v)) 730 mh-thread-id-index-map)) 731 (push v results))) 732 mh-thread-id-table) 733 (mh-thread-sort-containers results)))) 734 735(defun mh-thread-sort-containers (containers) 736 "Sort a list of message CONTAINERS to be in ascending order wrt index." 737 (sort containers 738 #'(lambda (x y) 739 (when (and (mh-container-message x) (mh-container-message y)) 740 (let* ((id-x (mh-message-id (mh-container-message x))) 741 (id-y (mh-message-id (mh-container-message y))) 742 (index-x (gethash id-x mh-thread-id-index-map)) 743 (index-y (gethash id-y mh-thread-id-index-map))) 744 (and (integerp index-x) (integerp index-y) 745 (< index-x index-y))))))) 746 747(defvar mh-thread-last-ancestor) 748 749;;;###mh-autoload 750(defun mh-thread-print-scan-lines (thread-tree) 751 "Print scan lines in THREAD-TREE in threaded mode." 752 (let ((mh-thread-body-width (- (window-width) mh-cmd-note 753 (1- mh-scan-field-subject-start-offset))) 754 (mh-thread-last-ancestor nil)) 755 (if (null mh-index-data) 756 (mh-thread-generate-scan-lines thread-tree -2) 757 (loop for x in (mh-index-group-by-folder) 758 do (let* ((old-map mh-thread-scan-line-map) 759 (mh-thread-scan-line-map (make-hash-table))) 760 (setq mh-thread-last-ancestor nil) 761 (loop for msg in (cdr x) 762 do (let ((v (gethash msg old-map))) 763 (when v 764 (setf (gethash msg mh-thread-scan-line-map) v)))) 765 (when (> (hash-table-count mh-thread-scan-line-map) 0) 766 (insert (if (bobp) "" "\n") (car x) "\n") 767 (mh-thread-generate-scan-lines thread-tree -2)))) 768 (mh-index-create-imenu-index)))) 769 770(defun mh-thread-generate-scan-lines (tree level) 771 "Generate scan lines. 772TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps 773message indices to the corresponding scan lines and LEVEL used to 774determine indentation of the message." 775 (cond ((null tree) nil) 776 ((mh-thread-container-p tree) 777 (let* ((message (mh-container-message tree)) 778 (id (mh-message-id message)) 779 (index (gethash id mh-thread-id-index-map)) 780 (duplicates (gethash id mh-thread-duplicates)) 781 (new-level (+ level 2)) 782 (dupl-flag t) 783 (force-angle-flag nil) 784 (increment-level-flag nil)) 785 (dolist (scan-line (mapcar (lambda (x) 786 (gethash x mh-thread-scan-line-map)) 787 (reverse (cons index duplicates)))) 788 (when scan-line 789 (when (and dupl-flag (equal level 0) 790 (mh-thread-ancestor-p mh-thread-last-ancestor tree)) 791 (setq level (+ level 2) 792 new-level (+ new-level 2) 793 force-angle-flag t)) 794 (when (equal level 0) 795 (setq mh-thread-last-ancestor tree) 796 (while (mh-container-parent mh-thread-last-ancestor) 797 (setq mh-thread-last-ancestor 798 (mh-container-parent mh-thread-last-ancestor)))) 799 (let* ((lev (if dupl-flag level new-level)) 800 (square-flag (or (and (mh-container-real-child-p tree) 801 (not force-angle-flag) 802 dupl-flag) 803 (equal lev 0)))) 804 (insert (car scan-line) 805 (format (format "%%%ss" lev) "") 806 (if square-flag "[" "<") 807 (cadr scan-line) 808 (if square-flag "]" ">") 809 (truncate-string-to-width 810 (caddr scan-line) (- mh-thread-body-width lev)) 811 "\n")) 812 (setq increment-level-flag t) 813 (setq dupl-flag nil))) 814 (unless increment-level-flag (setq new-level level)) 815 (dolist (child (mh-container-children tree)) 816 (mh-thread-generate-scan-lines child new-level)))) 817 (t (let ((nlevel (+ level 2))) 818 (dolist (ch tree) 819 (mh-thread-generate-scan-lines ch nlevel)))))) 820 821 822 823;;; Additional Utilities 824 825;;;###mh-autoload 826(defun mh-thread-update-scan-line-map (msg notation offset) 827 "In threaded view update `mh-thread-scan-line-map'. 828MSG is the message being notated with NOTATION at OFFSET." 829 (let* ((msg (or msg (mh-get-msg-num nil))) 830 (cur-scan-line (and mh-thread-scan-line-map 831 (gethash msg mh-thread-scan-line-map))) 832 (old-scan-lines (loop for map in mh-thread-scan-line-map-stack 833 collect (and map (gethash msg map))))) 834 (when cur-scan-line 835 (setf (aref (car cur-scan-line) offset) notation)) 836 (dolist (line old-scan-lines) 837 (when line (setf (aref (car line) offset) notation))))) 838 839;;;###mh-autoload 840(defun mh-thread-find-msg-subject (msg) 841 "Find canonicalized subject of MSG. 842This function can only be used the folder is threaded." 843 (ignore-errors 844 (mh-message-subject 845 (mh-container-message (gethash (gethash msg mh-thread-index-id-map) 846 mh-thread-id-table))))) 847 848;;;###mh-autoload 849(defun mh-thread-add-spaces (count) 850 "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." 851 (let ((spaces (format (format "%%%ss" count) ""))) 852 (while (not (eobp)) 853 (let* ((msg-num (mh-get-msg-num nil)) 854 (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map)))) 855 (when (numberp msg-num) 856 (setf (gethash msg-num mh-thread-scan-line-map) 857 (mh-thread-parse-scan-line (format "%s%s" spaces old-line))))) 858 (forward-line 1)))) 859 860;;;###mh-autoload 861(defun mh-thread-forget-message (index) 862 "Forget the message INDEX from the threading tables." 863 (let* ((id (gethash index mh-thread-index-id-map)) 864 (id-index (gethash id mh-thread-id-index-map)) 865 (duplicates (gethash id mh-thread-duplicates))) 866 (remhash index mh-thread-index-id-map) 867 (remhash index mh-thread-scan-line-map) 868 (cond ((and (eql index id-index) (null duplicates)) 869 (remhash id mh-thread-id-index-map)) 870 ((eql index id-index) 871 (setf (gethash id mh-thread-id-index-map) (car duplicates)) 872 (setf (gethash (car duplicates) mh-thread-index-id-map) id) 873 (setf (gethash id mh-thread-duplicates) (cdr duplicates))) 874 (t 875 (setf (gethash id mh-thread-duplicates) 876 (remove index duplicates)))))) 877 878(provide 'mh-thread) 879 880;; Local Variables: 881;; indent-tabs-mode: nil 882;; sentence-end-double-space: nil 883;; End: 884 885;; arch-tag: b10e62f5-f028-4e04-873e-89d0e069b3d5 886;;; mh-thread.el ends here 887