| 1 | ;;; mh-thread.el --- MH-E threading support |
| 2 | |
| 3 | ;; Copyright (C) 2002, 2003, 2004, 2006, 2007, 2008 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 3, 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. |
| 121 | When new messages are added, these transformations are rewound, |
| 122 | then the links are added from the newly seen messages. Finally |
| 123 | the transformations are redone to get the new thread tree. This |
| 124 | makes 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 | \f |
| 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 | |
| 138 | If you do not care for the way a particular thread has turned, |
| 139 | you can move up the chain of messages with this command. This |
| 140 | command can also take a prefix argument THREAD-ROOT-FLAG to jump |
| 141 | to 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 | |
| 174 | With non-nil optional argument PREVIOUS-FLAG jump to the previous |
| 175 | sibling." |
| 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 | \f |
| 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. |
| 282 | The result is returned as a list of two elements. The first is |
| 283 | the point at the start of the region and the second is the point |
| 284 | at 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 | \f |
| 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. |
| 333 | All 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. |
| 357 | TEST 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'. |
| 375 | If no container exists then a suitable container is created and |
| 376 | the 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. |
| 397 | Doesn't make any changes if CHILD is already an ancestor of |
| 398 | PARENT. If optional argument AT-END-P is non-nil, the CHILD is |
| 399 | added 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. |
| 443 | In the limit, the function returns t if ANCESTOR and SUCCESSOR |
| 444 | are 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. |
| 456 | If optional argument STRING is given then that is assumed to be |
| 457 | the scan line. Otherwise uses the line at point as the scan line |
| 458 | to 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. |
| 472 | This 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. |
| 479 | If the result after pruning is not the empty string then it is |
| 480 | canonicalized so that subjects can be tested for equality with |
| 481 | eq. This is done so that all the messages without a subject are |
| 482 | not 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. |
| 505 | Bug: Check for and make sure that something without Re: is made |
| 506 | the 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. |
| 523 | If CONTAINER is empty return the subject info of one of its |
| 524 | children." |
| 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. |
| 538 | The function also checks for duplicate messages (that is multiple |
| 539 | messages 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. |
| 548 | If there is no container present then a new container is |
| 549 | allocated." |
| 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. |
| 559 | Otherwise update message already present to have the proper ID, |
| 560 | SUBJECT-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. |
| 586 | Only 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. |
| 667 | Ideally this should have some regexp which will try to guess if a |
| 668 | string between < and > is a message id and not an email address. |
| 669 | For 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. |
| 772 | TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps |
| 773 | message indices to the corresponding scan lines and LEVEL used to |
| 774 | determine 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 | \f |
| 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'. |
| 828 | MSG 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. |
| 842 | This 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 |