Mercurial > emacs
comparison lisp/mh-e/mh-seq.el @ 49459:06b77df47802
* mh-e: Created directory. ChangeLog will appear in a week when we
release version 7.2.
* lisp/mail/mh-alias.el, lisp/mail/mh-comp.el,
lisp/mail/mh-customize.el, lisp/mail/mh-e.el, lisp/mail/mh-funcs.el,
lisp/mail/mh-identity.el, lisp/mail/mh-index.el,
lisp/mail/mh-loaddefs.el, lisp/mail/mh-mime.el, lisp/mail/mh-pick.el,
lisp/mail/mh-seq.el, lisp/mail/mh-speed.el, lisp/mail/mh-utils.el,
lisp/mail/mh-xemacs-compat.el: Moved to mh-e. Note that reply2.pbm and
reply2.xpm, which were created by the MH-E package, were left in mail
since they can probably be used by other mail packages.
* makefile.w32-in (WINS): Added mh-e.
* makefile.nt (WINS): Added mh-e.
| author | Bill Wohler <wohler@newt.com> |
|---|---|
| date | Sun, 26 Jan 2003 02:38:37 +0000 |
| parents | |
| children | b35587af8747 |
comparison
equal
deleted
inserted
replaced
| 49458:5ddabc4c81b0 | 49459:06b77df47802 |
|---|---|
| 1 ;;; mh-seq.el --- MH-E sequences support | |
| 2 | |
| 3 ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc. | |
| 4 | |
| 5 ;; Author: Bill Wohler <wohler@newt.com> | |
| 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., 59 Temple Place - Suite 330, | |
| 25 ;; Boston, MA 02111-1307, USA. | |
| 26 | |
| 27 ;;; Commentary: | |
| 28 ;; | |
| 29 ;; This tries to implement the algorithm described at: | |
| 30 ;; http://www.jwz.org/doc/threading.html | |
| 31 ;; It is also a start to implementing the IMAP Threading extension RFC. The | |
| 32 ;; implementation lacks the reference and subject canonicalization of the | |
| 33 ;; RFC. | |
| 34 ;; | |
| 35 ;; In the presentation buffer, children messages are shown indented with | |
| 36 ;; either [ ] or < > around them. Square brackets ([ ]) denote that the | |
| 37 ;; algorithm can point out some headers which when taken together implies | |
| 38 ;; that the unindented message is an ancestor of the indented message. If | |
| 39 ;; no such proof exists then angles (< >) are used. | |
| 40 ;; | |
| 41 ;; Some issues and problems are as follows: | |
| 42 ;; | |
| 43 ;; (1) Scan truncates the fields at length 512. So longer references: | |
| 44 ;; headers get mutilated. The same kind of MH format string works when | |
| 45 ;; composing messages. Is there a way to avoid this? My scan command | |
| 46 ;; is as follows: | |
| 47 ;; scan +folder -width 10000 \ | |
| 48 ;; -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n" | |
| 49 ;; I would really appreciate it if someone would help me with this. | |
| 50 ;; | |
| 51 ;; (2) Implement heuristics to recognize message-id's in In-Reply-To: | |
| 52 ;; header. Right now it just assumes that the last text between angles | |
| 53 ;; (< and >) is the message-id. There is the chance that this will | |
| 54 ;; incorrectly use an email address like a message-id. | |
| 55 ;; | |
| 56 ;; (3) Error checking of found message-id's should be done. | |
| 57 ;; | |
| 58 ;; (4) Since this breaks the assumption that message indices increase as | |
| 59 ;; one goes down the buffer, the binary search based mh-goto-msg | |
| 60 ;; doesn't work. I have a simpler replacement which may be less | |
| 61 ;; efficient. | |
| 62 ;; | |
| 63 ;; (5) Better canonicalizing for message-id and subject strings. | |
| 64 ;; | |
| 65 | |
| 66 ;; Internal support for MH-E package. | |
| 67 | |
| 68 ;;; Change Log: | |
| 69 | |
| 70 ;; $Id: mh-seq.el,v 1.10 2003/01/08 23:21:16 wohler Exp $ | |
| 71 | |
| 72 ;;; Code: | |
| 73 | |
| 74 (require 'cl) | |
| 75 (require 'mh-e) | |
| 76 | |
| 77 ;; Shush the byte-compiler | |
| 78 (defvar tool-bar-mode) | |
| 79 | |
| 80 ;;; Data structures (used in message threading)... | |
| 81 (defstruct (mh-thread-message (:conc-name mh-message-) | |
| 82 (:constructor mh-thread-make-message)) | |
| 83 (id nil) | |
| 84 (references ()) | |
| 85 (subject "") | |
| 86 (subject-re-p nil)) | |
| 87 | |
| 88 (defstruct (mh-thread-container (:conc-name mh-container-) | |
| 89 (:constructor mh-thread-make-container)) | |
| 90 message parent children | |
| 91 (real-child-p t)) | |
| 92 | |
| 93 | |
| 94 ;;; Internal variables: | |
| 95 (defvar mh-last-seq-used nil | |
| 96 "Name of seq to which a msg was last added.") | |
| 97 | |
| 98 (defvar mh-non-seq-mode-line-annotation nil | |
| 99 "Saved value of `mh-mode-line-annotation' when narrowed to a seq.") | |
| 100 | |
| 101 ;;; Maps and hashes... | |
| 102 (defvar mh-thread-id-hash nil | |
| 103 "Hashtable used to canonicalize message-id strings.") | |
| 104 (defvar mh-thread-subject-hash nil | |
| 105 "Hashtable used to canonicalize subject strings.") | |
| 106 (defvar mh-thread-id-table nil | |
| 107 "Thread ID table maps from message-id's to message containers.") | |
| 108 (defvar mh-thread-id-index-map nil | |
| 109 "Table to lookup message index number from message-id.") | |
| 110 (defvar mh-thread-index-id-map nil | |
| 111 "Table to lookup message-id from message index.") | |
| 112 (defvar mh-thread-scan-line-map nil | |
| 113 "Map of message index to various parts of the scan line.") | |
| 114 (defvar mh-thread-old-scan-line-map nil | |
| 115 "Old map of message index to various parts of the scan line. | |
| 116 This is the original map that is stored when the folder is narrowed.") | |
| 117 (defvar mh-thread-subject-container-hash nil | |
| 118 "Hashtable used to group messages by subject.") | |
| 119 (defvar mh-thread-duplicates nil | |
| 120 "Hashtable used to remember multiple messages with the same message-id.") | |
| 121 (defvar mh-thread-history () | |
| 122 "Variable to remember the transformations to the thread tree. | |
| 123 When new messages are added, these transformations are rewound, then the | |
| 124 links are added from the newly seen messages. Finally the transformations are | |
| 125 redone to get the new thread tree. This makes incremental threading easier.") | |
| 126 (defvar mh-thread-body-width nil | |
| 127 "Width of scan substring that contains subject and body of message.") | |
| 128 | |
| 129 (make-variable-buffer-local 'mh-thread-id-hash) | |
| 130 (make-variable-buffer-local 'mh-thread-subject-hash) | |
| 131 (make-variable-buffer-local 'mh-thread-id-table) | |
| 132 (make-variable-buffer-local 'mh-thread-id-index-map) | |
| 133 (make-variable-buffer-local 'mh-thread-index-id-map) | |
| 134 (make-variable-buffer-local 'mh-thread-scan-line-map) | |
| 135 (make-variable-buffer-local 'mh-thread-old-scan-line-map) | |
| 136 (make-variable-buffer-local 'mh-thread-subject-container-hash) | |
| 137 (make-variable-buffer-local 'mh-thread-duplicates) | |
| 138 (make-variable-buffer-local 'mh-thread-history) | |
| 139 | |
| 140 ;;;###mh-autoload | |
| 141 (defun mh-delete-seq (sequence) | |
| 142 "Delete the SEQUENCE." | |
| 143 (interactive (list (mh-read-seq-default "Delete" t))) | |
| 144 (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq sequence ? (1+ mh-cmd-note) | |
| 145 sequence) | |
| 146 (mh-undefine-sequence sequence '("all")) | |
| 147 (mh-delete-seq-locally sequence)) | |
| 148 | |
| 149 ;; Avoid compiler warnings | |
| 150 (defvar view-exit-action) | |
| 151 | |
| 152 ;;;###mh-autoload | |
| 153 (defun mh-list-sequences () | |
| 154 "List the sequences defined in the folder being visited." | |
| 155 (interactive) | |
| 156 (let ((folder mh-current-folder) | |
| 157 (temp-buffer mh-temp-sequences-buffer) | |
| 158 (seq-list mh-seq-list) | |
| 159 (max-len 0)) | |
| 160 (with-output-to-temp-buffer temp-buffer | |
| 161 (save-excursion | |
| 162 (set-buffer temp-buffer) | |
| 163 (erase-buffer) | |
| 164 (message "Listing sequences ...") | |
| 165 (insert "Sequences in folder " folder ":\n") | |
| 166 (let ((seq-list seq-list)) | |
| 167 (while seq-list | |
| 168 (setq max-len | |
| 169 (max (length (symbol-name (mh-seq-name (pop seq-list)))) | |
| 170 max-len))) | |
| 171 (setq max-len (+ 2 max-len))) | |
| 172 (while seq-list | |
| 173 (let ((name (mh-seq-name (car seq-list))) | |
| 174 (sorted-seq-msgs | |
| 175 (mh-coalesce-msg-list | |
| 176 (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<))) | |
| 177 name-spec) | |
| 178 (insert (setq name-spec (format (format "%%%ss:" max-len) name))) | |
| 179 (while sorted-seq-msgs | |
| 180 (let ((next-element (format " %s" (pop sorted-seq-msgs)))) | |
| 181 (when (>= (+ (current-column) (length next-element)) | |
| 182 (window-width)) | |
| 183 (insert "\n") | |
| 184 (insert (format (format "%%%ss" (length name-spec)) ""))) | |
| 185 (insert next-element))) | |
| 186 (insert "\n")) | |
| 187 (setq seq-list (cdr seq-list))) | |
| 188 (goto-char (point-min)) | |
| 189 (view-mode 1) | |
| 190 (setq view-exit-action 'kill-buffer) | |
| 191 (message "Listing sequences...done"))))) | |
| 192 | |
| 193 ;;;###mh-autoload | |
| 194 (defun mh-msg-is-in-seq (message) | |
| 195 "Display the sequences that contain MESSAGE (default: current message)." | |
| 196 (interactive (list (mh-get-msg-num t))) | |
| 197 (let* ((dest-folder (loop for seq in mh-refile-list | |
| 198 when (member message (cdr seq)) return (car seq))) | |
| 199 (deleted-flag (unless dest-folder (member message mh-delete-list)))) | |
| 200 (message "Message %d%s is in sequences: %s" | |
| 201 message | |
| 202 (cond (dest-folder (format " (to be refiled to %s)" dest-folder)) | |
| 203 (deleted-flag (format " (to be deleted)")) | |
| 204 (t "")) | |
| 205 (mapconcat 'concat | |
| 206 (mh-list-to-string (mh-seq-containing-msg message t)) | |
| 207 " ")))) | |
| 208 | |
| 209 ;;;###mh-autoload | |
| 210 (defun mh-narrow-to-seq (sequence) | |
| 211 "Restrict display of this folder to just messages in SEQUENCE. | |
| 212 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command." | |
| 213 (interactive (list (mh-read-seq "Narrow to" t))) | |
| 214 (with-mh-folder-updating (t) | |
| 215 (cond ((mh-seq-to-msgs sequence) | |
| 216 (mh-widen) | |
| 217 (mh-remove-all-notation) | |
| 218 (let ((eob (point-max)) | |
| 219 (msg-at-cursor (mh-get-msg-num nil))) | |
| 220 (setq mh-thread-old-scan-line-map mh-thread-scan-line-map) | |
| 221 (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) | |
| 222 (mh-copy-seq-to-eob sequence) | |
| 223 (narrow-to-region eob (point-max)) | |
| 224 (mh-notate-user-sequences) | |
| 225 (mh-notate-deleted-and-refiled) | |
| 226 (mh-notate-seq 'cur mh-note-cur mh-cmd-note) | |
| 227 (when msg-at-cursor (mh-goto-msg msg-at-cursor t t)) | |
| 228 (make-variable-buffer-local 'mh-non-seq-mode-line-annotation) | |
| 229 (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation) | |
| 230 (setq mh-mode-line-annotation (symbol-name sequence)) | |
| 231 (mh-make-folder-mode-line) | |
| 232 (mh-recenter nil) | |
| 233 (if (and (boundp 'tool-bar-mode) tool-bar-mode) | |
| 234 (set (make-local-variable 'tool-bar-map) | |
| 235 mh-folder-seq-tool-bar-map)) | |
| 236 (setq mh-narrowed-to-seq sequence) | |
| 237 (push 'widen mh-view-ops))) | |
| 238 (t | |
| 239 (error "No messages in sequence `%s'" (symbol-name sequence)))))) | |
| 240 | |
| 241 ;;;###mh-autoload | |
| 242 (defun mh-put-msg-in-seq (msg-or-seq sequence) | |
| 243 "Add MSG-OR-SEQ (default: displayed message) to SEQUENCE. | |
| 244 If optional prefix argument provided, then prompt for the message sequence. | |
| 245 If variable `transient-mark-mode' is non-nil and the mark is active, then | |
| 246 the selected region is added to the sequence." | |
| 247 (interactive (list (cond | |
| 248 ((mh-mark-active-p t) | |
| 249 (mh-region-to-msg-list (region-beginning) (region-end))) | |
| 250 (current-prefix-arg | |
| 251 (mh-read-seq-default "Add messages from" t)) | |
| 252 (t | |
| 253 (mh-get-msg-num t))) | |
| 254 (mh-read-seq-default "Add to" nil))) | |
| 255 (if (not (mh-internal-seq sequence)) | |
| 256 (setq mh-last-seq-used sequence)) | |
| 257 (mh-add-msgs-to-seq (cond ((numberp msg-or-seq) (list msg-or-seq)) | |
| 258 ((listp msg-or-seq) msg-or-seq) | |
| 259 (t (mh-seq-to-msgs msg-or-seq))) | |
| 260 sequence)) | |
| 261 | |
| 262 (defun mh-valid-view-change-operation-p (op) | |
| 263 "Check if the view change operation can be performed. | |
| 264 OP is one of 'widen and 'unthread." | |
| 265 (cond ((eq (car mh-view-ops) op) | |
| 266 (pop mh-view-ops)) | |
| 267 (t nil))) | |
| 268 | |
| 269 ;;;###mh-autoload | |
| 270 (defun mh-widen () | |
| 271 "Remove restrictions from current folder, thereby showing all messages." | |
| 272 (interactive) | |
| 273 (let ((msg (mh-get-msg-num nil))) | |
| 274 (when mh-narrowed-to-seq | |
| 275 (cond ((mh-valid-view-change-operation-p 'widen) nil) | |
| 276 ((memq 'widen mh-view-ops) | |
| 277 (while (not (eq (car mh-view-ops) 'widen)) | |
| 278 (setq mh-view-ops (cdr mh-view-ops))) | |
| 279 (pop mh-view-ops)) | |
| 280 (t (error "Widening is not applicable"))) | |
| 281 (when (memq 'unthread mh-view-ops) | |
| 282 (setq mh-thread-scan-line-map mh-thread-old-scan-line-map)) | |
| 283 (with-mh-folder-updating (t) | |
| 284 (delete-region (point-min) (point-max)) | |
| 285 (widen) | |
| 286 (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation) | |
| 287 (mh-make-folder-mode-line)) | |
| 288 (if msg | |
| 289 (mh-goto-msg msg t t)) | |
| 290 (mh-notate-deleted-and-refiled) | |
| 291 (mh-notate-user-sequences) | |
| 292 (mh-notate-seq 'cur mh-note-cur mh-cmd-note) | |
| 293 (mh-recenter nil))) | |
| 294 (if (and (boundp 'tool-bar-mode) tool-bar-mode) | |
| 295 (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)) | |
| 296 (setq mh-narrowed-to-seq nil)) | |
| 297 | |
| 298 ;; FIXME? We may want to clear all notations and add one for current-message | |
| 299 ;; and process user sequences. | |
| 300 (defun mh-notate-deleted-and-refiled () | |
| 301 "Notate messages marked for deletion or refiling. | |
| 302 Messages to be deleted are given by `mh-delete-list' while messages to be | |
| 303 refiled are present in `mh-refile-list'." | |
| 304 (mh-mapc #'(lambda (msg) (mh-notate msg mh-note-deleted mh-cmd-note)) | |
| 305 mh-delete-list) | |
| 306 (mh-mapc #'(lambda (dest-msg-list) | |
| 307 ;; foreach folder name, get the keyed sequence from mh-seq-list | |
| 308 (let ((msg-list (cdr dest-msg-list))) | |
| 309 (mh-mapc #'(lambda (msg) | |
| 310 (mh-notate msg mh-note-refiled mh-cmd-note)) | |
| 311 msg-list))) | |
| 312 mh-refile-list)) | |
| 313 | |
| 314 | |
| 315 | |
| 316 ;;; Commands to manipulate sequences. Sequences are stored in an alist | |
| 317 ;;; of the form: | |
| 318 ;;; ((seq-name msgs ...) (seq-name msgs ...) ...) | |
| 319 | |
| 320 (defun mh-read-seq-default (prompt not-empty) | |
| 321 "Read and return sequence name with default narrowed or previous sequence. | |
| 322 PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil then a | |
| 323 non-empty sequence is read." | |
| 324 (mh-read-seq prompt not-empty | |
| 325 (or mh-narrowed-to-seq | |
| 326 mh-last-seq-used | |
| 327 (car (mh-seq-containing-msg (mh-get-msg-num nil) nil))))) | |
| 328 | |
| 329 (defun mh-read-seq (prompt not-empty &optional default) | |
| 330 "Read and return a sequence name. | |
| 331 Prompt with PROMPT, raise an error if the sequence is empty and the NOT-EMPTY | |
| 332 flag is non-nil, and supply an optional DEFAULT sequence. A reply of '%' | |
| 333 defaults to the first sequence containing the current message." | |
| 334 (let* ((input (completing-read (format "%s %s %s" prompt "sequence:" | |
| 335 (if default | |
| 336 (format "[%s] " default) | |
| 337 "")) | |
| 338 (mh-seq-names mh-seq-list))) | |
| 339 (seq (cond ((equal input "%") | |
| 340 (car (mh-seq-containing-msg (mh-get-msg-num t) nil))) | |
| 341 ((equal input "") default) | |
| 342 (t (intern input)))) | |
| 343 (msgs (mh-seq-to-msgs seq))) | |
| 344 (if (and (null msgs) not-empty) | |
| 345 (error "No messages in sequence `%s'" seq)) | |
| 346 seq)) | |
| 347 | |
| 348 (defun mh-seq-names (seq-list) | |
| 349 "Return an alist containing the names of the SEQ-LIST." | |
| 350 (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry)))) | |
| 351 seq-list)) | |
| 352 | |
| 353 ;;;###mh-autoload | |
| 354 (defun mh-rename-seq (sequence new-name) | |
| 355 "Rename SEQUENCE to have NEW-NAME." | |
| 356 (interactive (list (mh-read-seq "Old" t) | |
| 357 (intern (read-string "New sequence name: ")))) | |
| 358 (let ((old-seq (mh-find-seq sequence))) | |
| 359 (or old-seq | |
| 360 (error "Sequence %s does not exist" sequence)) | |
| 361 ;; create new sequence first, since it might raise an error. | |
| 362 (mh-define-sequence new-name (mh-seq-msgs old-seq)) | |
| 363 (mh-undefine-sequence sequence (mh-seq-msgs old-seq)) | |
| 364 (rplaca old-seq new-name))) | |
| 365 | |
| 366 ;;;###mh-autoload | |
| 367 (defun mh-map-to-seq-msgs (func seq &rest args) | |
| 368 "Invoke the FUNC at each message in the SEQ. | |
| 369 SEQ can either be a list of messages or a MH sequence. The remaining ARGS are | |
| 370 passed as arguments to FUNC." | |
| 371 (save-excursion | |
| 372 (let ((msgs (if (listp seq) seq (mh-seq-to-msgs seq)))) | |
| 373 (while msgs | |
| 374 (if (mh-goto-msg (car msgs) t t) | |
| 375 (apply func (car msgs) args)) | |
| 376 (setq msgs (cdr msgs)))))) | |
| 377 | |
| 378 ;;;###mh-autoload | |
| 379 (defun mh-notate-seq (seq notation offset) | |
| 380 "Mark the scan listing. | |
| 381 All messages in SEQ are marked with NOTATION at OFFSET from the beginning of | |
| 382 the line." | |
| 383 (mh-map-to-seq-msgs 'mh-notate seq notation offset)) | |
| 384 | |
| 385 ;;;###mh-autoload | |
| 386 (defun mh-add-to-sequence (seq msgs) | |
| 387 "The sequence SEQ is augmented with the messages in MSGS." | |
| 388 ;; Add to a SEQUENCE each message the list of MSGS. | |
| 389 (if (not (mh-folder-name-p seq)) | |
| 390 (if msgs | |
| 391 (apply 'mh-exec-cmd "mark" mh-current-folder "-add" | |
| 392 "-sequence" (symbol-name seq) | |
| 393 (mh-coalesce-msg-list msgs))))) | |
| 394 | |
| 395 ;; This has a tricky bug. mh-map-to-seq-msgs uses mh-goto-msg, which assumes | |
| 396 ;; that the folder buffer is sorted. However in this case that assumption | |
| 397 ;; doesn't hold. So we will do this the dumb way. | |
| 398 ;(defun mh-copy-seq-to-point (seq location) | |
| 399 ; ;; Copy the scan listing of the messages in SEQUENCE to after the point | |
| 400 ; ;; LOCATION in the current buffer. | |
| 401 ; (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location)) | |
| 402 | |
| 403 (defun mh-copy-seq-to-eob (seq) | |
| 404 "Copy SEQ to the end of the buffer." | |
| 405 ;; It is quite involved to write something which will work at any place in | |
| 406 ;; the buffer, so we will write something which works only at the end of | |
| 407 ;; the buffer. If we ever need to insert sequences in the middle of the | |
| 408 ;; buffer, this will need to be fixed. | |
| 409 (save-excursion | |
| 410 (let* ((msgs (mh-seq-to-msgs seq)) | |
| 411 (coalesced-msgs (mh-coalesce-msg-list msgs))) | |
| 412 (goto-char (point-max)) | |
| 413 (save-restriction | |
| 414 (narrow-to-region (point) (point)) | |
| 415 (mh-regenerate-headers coalesced-msgs t) | |
| 416 (cond ((memq 'unthread mh-view-ops) | |
| 417 ;; Populate restricted scan-line map | |
| 418 (goto-char (point-min)) | |
| 419 (while (not (eobp)) | |
| 420 (let ((msg (mh-get-msg-num nil))) | |
| 421 (when (numberp msg) | |
| 422 (setf (gethash msg mh-thread-scan-line-map) | |
| 423 (mh-thread-parse-scan-line)))) | |
| 424 (forward-line)) | |
| 425 ;; Remove scan lines and read results from pre-computed tree | |
| 426 (delete-region (point-min) (point-max)) | |
| 427 (let ((thread-tree (mh-thread-generate mh-current-folder ())) | |
| 428 (mh-thread-body-width | |
| 429 (- (window-width) mh-cmd-note | |
| 430 (1- mh-scan-field-subject-start-offset))) | |
| 431 (mh-thread-last-ancestor nil)) | |
| 432 (mh-thread-generate-scan-lines thread-tree -2))) | |
| 433 (mh-index-data | |
| 434 (mh-index-insert-folder-headers))))))) | |
| 435 | |
| 436 (defun mh-copy-line-to-point (msg location) | |
| 437 "Copy current message line to a specific location. | |
| 438 The argument MSG is not used. The message in the current line is copied to | |
| 439 LOCATION." | |
| 440 ;; msg is not used? | |
| 441 ;; Copy the current line to the LOCATION in the current buffer. | |
| 442 (beginning-of-line) | |
| 443 (save-excursion | |
| 444 (let ((beginning-of-line (point)) | |
| 445 end) | |
| 446 (forward-line 1) | |
| 447 (setq end (point)) | |
| 448 (goto-char location) | |
| 449 (insert-buffer-substring (current-buffer) beginning-of-line end)))) | |
| 450 | |
| 451 ;;;###mh-autoload | |
| 452 (defun mh-region-to-msg-list (begin end) | |
| 453 "Return a list of messages within the region between BEGIN and END." | |
| 454 (save-excursion | |
| 455 ;; If end is end of buffer back up one position | |
| 456 (setq end (if (equal end (point-max)) (1- end) end)) | |
| 457 (goto-char begin) | |
| 458 (let ((result ())) | |
| 459 (while (<= (point) end) | |
| 460 (let ((index (mh-get-msg-num nil))) | |
| 461 (when (numberp index) (push index result))) | |
| 462 (forward-line 1)) | |
| 463 result))) | |
| 464 | |
| 465 | |
| 466 | |
| 467 ;;; Commands to handle new 'subject sequence. | |
| 468 ;;; Or "Poor man's threading" by psg. | |
| 469 | |
| 470 (defun mh-subject-to-sequence (all) | |
| 471 "Put all following messages with same subject in sequence 'subject. | |
| 472 If arg ALL is t, move to beginning of folder buffer to collect all messages. | |
| 473 If arg ALL is nil, collect only messages fron current one on forward. | |
| 474 | |
| 475 Return number of messages put in the sequence: | |
| 476 | |
| 477 nil -> there was no subject line. | |
| 478 0 -> there were no later messages with the same subject (sequence not made) | |
| 479 >1 -> the total number of messages including current one." | |
| 480 (if (not (eq major-mode 'mh-folder-mode)) | |
| 481 (error "Not in a folder buffer")) | |
| 482 (save-excursion | |
| 483 (beginning-of-line) | |
| 484 (if (or (not (looking-at mh-scan-subject-regexp)) | |
| 485 (not (match-string 3)) | |
| 486 (string-equal "" (match-string 3))) | |
| 487 (progn (message "No subject line.") | |
| 488 nil) | |
| 489 (let ((subject (match-string-no-properties 3)) | |
| 490 (list)) | |
| 491 (if (> (length subject) 41) | |
| 492 (setq subject (substring subject 0 41))) | |
| 493 (save-excursion | |
| 494 (if all | |
| 495 (goto-char (point-min))) | |
| 496 (while (re-search-forward mh-scan-subject-regexp nil t) | |
| 497 (let ((this-subject (match-string-no-properties 3))) | |
| 498 (if (> (length this-subject) 41) | |
| 499 (setq this-subject (substring this-subject 0 41))) | |
| 500 (if (string-equal this-subject subject) | |
| 501 (setq list (cons (mh-get-msg-num t) list)))))) | |
| 502 (cond | |
| 503 (list | |
| 504 ;; If we created a new sequence, add the initial message to it too. | |
| 505 (if (not (member (mh-get-msg-num t) list)) | |
| 506 (setq list (cons (mh-get-msg-num t) list))) | |
| 507 (if (member '("subject") (mh-seq-names mh-seq-list)) | |
| 508 (mh-delete-seq 'subject)) | |
| 509 ;; sort the result into a sequence | |
| 510 (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))) | |
| 511 (while sorted-list | |
| 512 (mh-add-msgs-to-seq (car sorted-list) 'subject nil) | |
| 513 (setq sorted-list (cdr sorted-list))) | |
| 514 (safe-length list))) | |
| 515 (t | |
| 516 0)))))) | |
| 517 | |
| 518 ;;;###mh-autoload | |
| 519 (defun mh-narrow-to-subject () | |
| 520 "Narrow to a sequence containing all following messages with same subject." | |
| 521 (interactive) | |
| 522 (let ((num (mh-get-msg-num nil)) | |
| 523 (count (mh-subject-to-sequence t))) | |
| 524 (cond | |
| 525 ((not count) ; No subject line, delete msg anyway | |
| 526 nil) | |
| 527 ((= 0 count) ; No other msgs, delete msg anyway. | |
| 528 (message "No other messages with same Subject following this one.") | |
| 529 nil) | |
| 530 (t ; We have a subject sequence. | |
| 531 (message "Found %d messages for subject sequence." count) | |
| 532 (mh-narrow-to-seq 'subject) | |
| 533 (if (numberp num) | |
| 534 (mh-goto-msg num t t)))))) | |
| 535 | |
| 536 ;;;###mh-autoload | |
| 537 (defun mh-delete-subject () | |
| 538 "Mark all following messages with same subject to be deleted. | |
| 539 This puts the messages in a sequence named subject. You can undo the last | |
| 540 deletion marks using `mh-undo' with a prefix argument and then specifying the | |
| 541 subject sequence." | |
| 542 (interactive) | |
| 543 (let ((count (mh-subject-to-sequence nil))) | |
| 544 (cond | |
| 545 ((not count) ; No subject line, delete msg anyway | |
| 546 (mh-delete-msg (mh-get-msg-num t))) | |
| 547 ((= 0 count) ; No other msgs, delete msg anyway. | |
| 548 (message "No other messages with same Subject following this one.") | |
| 549 (mh-delete-msg (mh-get-msg-num t))) | |
| 550 (t ; We have a subject sequence. | |
| 551 (message "Marked %d messages for deletion" count) | |
| 552 (mh-delete-msg 'subject))))) | |
| 553 | |
| 554 ;;;###mh-autoload | |
| 555 (defun mh-delete-subject-or-thread () | |
| 556 "Mark messages for deletion intelligently. | |
| 557 If the folder is threaded then `mh-thread-delete' is used to mark the current | |
| 558 message and all its descendants for deletion. Otherwise `mh-delete-subject' is | |
| 559 used to mark the current message and all messages following it with the same | |
| 560 subject for deletion." | |
| 561 (interactive) | |
| 562 (if (memq 'unthread mh-view-ops) | |
| 563 (mh-thread-delete) | |
| 564 (mh-delete-subject))) | |
| 565 | |
| 566 ;;; Message threading: | |
| 567 | |
| 568 (defun mh-thread-initialize () | |
| 569 "Make hash tables, otherwise clear them." | |
| 570 (cond | |
| 571 (mh-thread-id-hash | |
| 572 (clrhash mh-thread-id-hash) | |
| 573 (clrhash mh-thread-subject-hash) | |
| 574 (clrhash mh-thread-id-table) | |
| 575 (clrhash mh-thread-id-index-map) | |
| 576 (clrhash mh-thread-index-id-map) | |
| 577 (clrhash mh-thread-scan-line-map) | |
| 578 (clrhash mh-thread-subject-container-hash) | |
| 579 (clrhash mh-thread-duplicates) | |
| 580 (setq mh-thread-history ())) | |
| 581 (t (setq mh-thread-id-hash (make-hash-table :test #'equal)) | |
| 582 (setq mh-thread-subject-hash (make-hash-table :test #'equal)) | |
| 583 (setq mh-thread-id-table (make-hash-table :test #'eq)) | |
| 584 (setq mh-thread-id-index-map (make-hash-table :test #'eq)) | |
| 585 (setq mh-thread-index-id-map (make-hash-table :test #'eql)) | |
| 586 (setq mh-thread-scan-line-map (make-hash-table :test #'eql)) | |
| 587 (setq mh-thread-subject-container-hash (make-hash-table :test #'eq)) | |
| 588 (setq mh-thread-duplicates (make-hash-table :test #'eq)) | |
| 589 (setq mh-thread-history ())))) | |
| 590 | |
| 591 (defsubst mh-thread-id-container (id) | |
| 592 "Given ID, return the corresponding container in `mh-thread-id-table'. | |
| 593 If no container exists then a suitable container is created and the id-table | |
| 594 is updated." | |
| 595 (when (not id) | |
| 596 (error "1")) | |
| 597 (or (gethash id mh-thread-id-table) | |
| 598 (setf (gethash id mh-thread-id-table) | |
| 599 (let ((message (mh-thread-make-message :id id))) | |
| 600 (mh-thread-make-container :message message))))) | |
| 601 | |
| 602 (defsubst mh-thread-remove-parent-link (child) | |
| 603 "Remove parent link of CHILD if it exists." | |
| 604 (let* ((child-container (if (mh-thread-container-p child) | |
| 605 child (mh-thread-id-container child))) | |
| 606 (parent-container (mh-container-parent child-container))) | |
| 607 (when parent-container | |
| 608 (setf (mh-container-children parent-container) | |
| 609 (loop for elem in (mh-container-children parent-container) | |
| 610 unless (eq child-container elem) collect elem)) | |
| 611 (setf (mh-container-parent child-container) nil)))) | |
| 612 | |
| 613 (defsubst mh-thread-add-link (parent child &optional at-end-p) | |
| 614 "Add links so that PARENT becomes a parent of CHILD. | |
| 615 Doesn't make any changes if CHILD is already an ancestor of PARENT. If | |
| 616 optional argument AT-END-P is non-nil, the CHILD is added to the end of the | |
| 617 children list of PARENT." | |
| 618 (let ((parent-container (cond ((null parent) nil) | |
| 619 ((mh-thread-container-p parent) parent) | |
| 620 (t (mh-thread-id-container parent)))) | |
| 621 (child-container (if (mh-thread-container-p child) | |
| 622 child (mh-thread-id-container child)))) | |
| 623 (when (and parent-container | |
| 624 (not (mh-thread-ancestor-p child-container parent-container)) | |
| 625 (not (mh-thread-ancestor-p parent-container child-container))) | |
| 626 (mh-thread-remove-parent-link child-container) | |
| 627 (cond ((not at-end-p) | |
| 628 (push child-container (mh-container-children parent-container))) | |
| 629 ((null (mh-container-children parent-container)) | |
| 630 (push child-container (mh-container-children parent-container))) | |
| 631 (t (let ((last-child (mh-container-children parent-container))) | |
| 632 (while (cdr last-child) | |
| 633 (setq last-child (cdr last-child))) | |
| 634 (setcdr last-child (cons child-container nil))))) | |
| 635 (setf (mh-container-parent child-container) parent-container)) | |
| 636 (unless parent-container | |
| 637 (mh-thread-remove-parent-link child-container)))) | |
| 638 | |
| 639 (defun mh-thread-ancestor-p (ancestor successor) | |
| 640 "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise. | |
| 641 In the limit, the function returns t if ANCESTOR and SUCCESSOR are the same | |
| 642 containers." | |
| 643 (block nil | |
| 644 (while successor | |
| 645 (when (eq ancestor successor) (return t)) | |
| 646 (setq successor (mh-container-parent successor))) | |
| 647 nil)) | |
| 648 | |
| 649 (defsubst mh-thread-get-message-container (message) | |
| 650 "Return container which has MESSAGE in it. | |
| 651 If there is no container present then a new container is allocated." | |
| 652 (let* ((id (mh-message-id message)) | |
| 653 (container (gethash id mh-thread-id-table))) | |
| 654 (cond (container (setf (mh-container-message container) message) | |
| 655 container) | |
| 656 (t (setf (gethash id mh-thread-id-table) | |
| 657 (mh-thread-make-container :message message)))))) | |
| 658 | |
| 659 (defsubst mh-thread-get-message (id subject-re-p subject refs) | |
| 660 "Return appropriate message. | |
| 661 Otherwise update message already present to have the proper ID, SUBJECT-RE-P, | |
| 662 SUBJECT and REFS fields." | |
| 663 (let* ((container (gethash id mh-thread-id-table)) | |
| 664 (message (if container (mh-container-message container) nil))) | |
| 665 (cond (message | |
| 666 (setf (mh-message-subject-re-p message) subject-re-p) | |
| 667 (setf (mh-message-subject message) subject) | |
| 668 (setf (mh-message-id message) id) | |
| 669 (setf (mh-message-references message) refs) | |
| 670 message) | |
| 671 (container | |
| 672 (setf (mh-container-message container) | |
| 673 (mh-thread-make-message :subject subject | |
| 674 :subject-re-p subject-re-p | |
| 675 :id id :references refs))) | |
| 676 (t (let ((message (mh-thread-make-message | |
| 677 :subject subject | |
| 678 :subject-re-p subject-re-p | |
| 679 :id id :references refs))) | |
| 680 (prog1 message | |
| 681 (mh-thread-get-message-container message))))))) | |
| 682 | |
| 683 (defsubst mh-thread-canonicalize-id (id) | |
| 684 "Produce canonical string representation for ID. | |
| 685 This allows cheap string comparison with EQ." | |
| 686 (or (and (equal id "") (copy-sequence "")) | |
| 687 (gethash id mh-thread-id-hash) | |
| 688 (setf (gethash id mh-thread-id-hash) id))) | |
| 689 | |
| 690 (defsubst mh-thread-prune-subject (subject) | |
| 691 "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT. | |
| 692 If the result after pruning is not the empty string then it is canonicalized | |
| 693 so that subjects can be tested for equality with eq. This is done so that all | |
| 694 the messages without a subject are not put into a single thread." | |
| 695 (let ((case-fold-search t) | |
| 696 (subject-pruned-flag nil)) | |
| 697 ;; Prune subject leader | |
| 698 (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*" | |
| 699 subject) | |
| 700 (string-match "^[ \t]*\\[[^\\]][ \t]*" subject)) | |
| 701 (setq subject-pruned-flag t) | |
| 702 (setq subject (substring subject (match-end 0)))) | |
| 703 ;; Prune subject trailer | |
| 704 (while (or (string-match "(fwd)$" subject) | |
| 705 (string-match "[ \t]+$" subject)) | |
| 706 (setq subject-pruned-flag t) | |
| 707 (setq subject (substring subject 0 (match-beginning 0)))) | |
| 708 ;; Canonicalize subject only if it is non-empty | |
| 709 (cond ((equal subject "") (values subject subject-pruned-flag)) | |
| 710 (t (values | |
| 711 (or (gethash subject mh-thread-subject-hash) | |
| 712 (setf (gethash subject mh-thread-subject-hash) subject)) | |
| 713 subject-pruned-flag))))) | |
| 714 | |
| 715 (defun mh-thread-container-subject (container) | |
| 716 "Return the subject of CONTAINER. | |
| 717 If CONTAINER is empty return the subject info of one of its children." | |
| 718 (cond ((and (mh-container-message container) | |
| 719 (mh-message-id (mh-container-message container))) | |
| 720 (mh-message-subject (mh-container-message container))) | |
| 721 (t (block nil | |
| 722 (dolist (kid (mh-container-children container)) | |
| 723 (when (and (mh-container-message kid) | |
| 724 (mh-message-id (mh-container-message kid))) | |
| 725 (let ((kid-message (mh-container-message kid))) | |
| 726 (return (mh-message-subject kid-message))))) | |
| 727 (error "This can't happen!"))))) | |
| 728 | |
| 729 (defun mh-thread-rewind-pruning () | |
| 730 "Restore the thread tree to its state before pruning." | |
| 731 (while mh-thread-history | |
| 732 (let ((action (pop mh-thread-history))) | |
| 733 (cond ((eq (car action) 'DROP) | |
| 734 (mh-thread-remove-parent-link (cadr action)) | |
| 735 (mh-thread-add-link (caddr action) (cadr action))) | |
| 736 ((eq (car action) 'PROMOTE) | |
| 737 (let ((node (cadr action)) | |
| 738 (parent (caddr action)) | |
| 739 (children (cdddr action))) | |
| 740 (dolist (child children) | |
| 741 (mh-thread-remove-parent-link child) | |
| 742 (mh-thread-add-link node child)) | |
| 743 (mh-thread-add-link parent node))) | |
| 744 ((eq (car action) 'SUBJECT) | |
| 745 (let ((node (cadr action))) | |
| 746 (mh-thread-remove-parent-link node) | |
| 747 (setf (mh-container-real-child-p node) t))))))) | |
| 748 | |
| 749 (defun mh-thread-prune-containers (roots) | |
| 750 "Prune empty containers in the containers ROOTS." | |
| 751 (let ((dfs-ordered-nodes ()) | |
| 752 (work-list roots)) | |
| 753 (while work-list | |
| 754 (let ((node (pop work-list))) | |
| 755 (dolist (child (mh-container-children node)) | |
| 756 (push child work-list)) | |
| 757 (push node dfs-ordered-nodes))) | |
| 758 (while dfs-ordered-nodes | |
| 759 (let ((node (pop dfs-ordered-nodes))) | |
| 760 (cond ((gethash (mh-message-id (mh-container-message node)) | |
| 761 mh-thread-id-index-map) | |
| 762 ;; Keep it | |
| 763 (setf (mh-container-children node) | |
| 764 (mh-thread-sort-containers (mh-container-children node)))) | |
| 765 ((and (mh-container-children node) | |
| 766 (or (null (cdr (mh-container-children node))) | |
| 767 (mh-container-parent node))) | |
| 768 ;; Promote kids | |
| 769 (let ((children ())) | |
| 770 (dolist (kid (mh-container-children node)) | |
| 771 (mh-thread-remove-parent-link kid) | |
| 772 (mh-thread-add-link (mh-container-parent node) kid) | |
| 773 (push kid children)) | |
| 774 (push `(PROMOTE ,node ,(mh-container-parent node) ,@children) | |
| 775 mh-thread-history) | |
| 776 (mh-thread-remove-parent-link node))) | |
| 777 ((mh-container-children node) | |
| 778 ;; Promote the first orphan to parent and add the other kids as | |
| 779 ;; his children | |
| 780 (setf (mh-container-children node) | |
| 781 (mh-thread-sort-containers (mh-container-children node))) | |
| 782 (let ((new-parent (car (mh-container-children node))) | |
| 783 (other-kids (cdr (mh-container-children node)))) | |
| 784 (mh-thread-remove-parent-link new-parent) | |
| 785 (dolist (kid other-kids) | |
| 786 (mh-thread-remove-parent-link kid) | |
| 787 (setf (mh-container-real-child-p kid) nil) | |
| 788 (mh-thread-add-link new-parent kid t)) | |
| 789 (push `(PROMOTE ,node ,(mh-container-parent node) | |
| 790 ,new-parent ,@other-kids) | |
| 791 mh-thread-history) | |
| 792 (mh-thread-remove-parent-link node))) | |
| 793 (t | |
| 794 ;; Drop it | |
| 795 (push `(DROP ,node ,(mh-container-parent node)) | |
| 796 mh-thread-history) | |
| 797 (mh-thread-remove-parent-link node))))) | |
| 798 (let ((results ())) | |
| 799 (maphash #'(lambda (k v) | |
| 800 (declare (ignore k)) | |
| 801 (when (and (null (mh-container-parent v)) | |
| 802 (gethash (mh-message-id (mh-container-message v)) | |
| 803 mh-thread-id-index-map)) | |
| 804 (push v results))) | |
| 805 mh-thread-id-table) | |
| 806 (mh-thread-sort-containers results)))) | |
| 807 | |
| 808 (defun mh-thread-sort-containers (containers) | |
| 809 "Sort a list of message CONTAINERS to be in ascending order wrt index." | |
| 810 (sort containers | |
| 811 #'(lambda (x y) | |
| 812 (when (and (mh-container-message x) (mh-container-message y)) | |
| 813 (let* ((id-x (mh-message-id (mh-container-message x))) | |
| 814 (id-y (mh-message-id (mh-container-message y))) | |
| 815 (index-x (gethash id-x mh-thread-id-index-map)) | |
| 816 (index-y (gethash id-y mh-thread-id-index-map))) | |
| 817 (and (integerp index-x) (integerp index-y) | |
| 818 (< index-x index-y))))))) | |
| 819 | |
| 820 (defsubst mh-thread-group-by-subject (roots) | |
| 821 "Group the set of message containers, ROOTS based on subject. | |
| 822 Bug: Check for and make sure that something without Re: is made the parent in | |
| 823 preference to something that has it." | |
| 824 (clrhash mh-thread-subject-container-hash) | |
| 825 (let ((results ())) | |
| 826 (dolist (root roots) | |
| 827 (let* ((subject (mh-thread-container-subject root)) | |
| 828 (parent (gethash subject mh-thread-subject-container-hash))) | |
| 829 (cond (parent (mh-thread-remove-parent-link root) | |
| 830 (mh-thread-add-link parent root t) | |
| 831 (setf (mh-container-real-child-p root) nil) | |
| 832 (push `(SUBJECT ,root) mh-thread-history)) | |
| 833 (t | |
| 834 (setf (gethash subject mh-thread-subject-container-hash) root) | |
| 835 (push root results))))) | |
| 836 (nreverse results))) | |
| 837 | |
| 838 (defsubst mh-thread-process-in-reply-to (reply-to-header) | |
| 839 "Extract message id's from REPLY-TO-HEADER. | |
| 840 Ideally this should have some regexp which will try to guess if a string | |
| 841 between < and > is a message id and not an email address. For now it will | |
| 842 take the last string inside angles." | |
| 843 (let ((end (mh-search-from-end ?> reply-to-header))) | |
| 844 (when (numberp end) | |
| 845 (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end)))) | |
| 846 (when (numberp begin) | |
| 847 (list (substring reply-to-header begin (1+ end)))))))) | |
| 848 | |
| 849 (defun mh-thread-set-tables (folder) | |
| 850 "Use the tables of FOLDER in current buffer." | |
| 851 (flet ((mh-get-table (symbol) | |
| 852 (save-excursion | |
| 853 (set-buffer folder) | |
| 854 (symbol-value symbol)))) | |
| 855 (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash)) | |
| 856 (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash)) | |
| 857 (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table)) | |
| 858 (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map)) | |
| 859 (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map)) | |
| 860 (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map)) | |
| 861 (setq mh-thread-subject-container-hash | |
| 862 (mh-get-table 'mh-thread-subject-container-hash)) | |
| 863 (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates)) | |
| 864 (setq mh-thread-history (mh-get-table 'mh-thread-history)))) | |
| 865 | |
| 866 (defsubst mh-thread-update-id-index-maps (id index) | |
| 867 "Message with id, ID is the message in INDEX. | |
| 868 The function also checks for duplicate messages (that is multiple messages | |
| 869 with the same ID). These messages are put in the `mh-thread-duplicates' hash | |
| 870 table." | |
| 871 (let ((old-index (gethash id mh-thread-id-index-map))) | |
| 872 (when old-index (push old-index (gethash id mh-thread-duplicates))) | |
| 873 (setf (gethash id mh-thread-id-index-map) index) | |
| 874 (setf (gethash index mh-thread-index-id-map) id))) | |
| 875 | |
| 876 | |
| 877 | |
| 878 ;;; Generate Threads... | |
| 879 | |
| 880 (defun mh-thread-generate (folder msg-list) | |
| 881 "Scan FOLDER to get info for threading. | |
| 882 Only information about messages in MSG-LIST are added to the tree." | |
| 883 (save-excursion | |
| 884 (set-buffer (get-buffer-create "*mh-thread*")) | |
| 885 (mh-thread-set-tables folder) | |
| 886 (erase-buffer) | |
| 887 (when msg-list | |
| 888 (apply | |
| 889 #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil | |
| 890 "-width" "10000" "-format" | |
| 891 "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n" | |
| 892 folder (mapcar #'(lambda (x) (format "%s" x)) msg-list))) | |
| 893 (goto-char (point-min)) | |
| 894 (let ((roots ()) | |
| 895 (case-fold-search t)) | |
| 896 (block nil | |
| 897 (while (not (eobp)) | |
| 898 (block process-message | |
| 899 (let* ((index-line | |
| 900 (prog1 (buffer-substring (point) (line-end-position)) | |
| 901 (forward-line))) | |
| 902 (index (car (read-from-string index-line))) | |
| 903 (id (prog1 (buffer-substring (point) (line-end-position)) | |
| 904 (forward-line))) | |
| 905 (refs (prog1 (buffer-substring (point) (line-end-position)) | |
| 906 (forward-line))) | |
| 907 (in-reply-to (prog1 (buffer-substring (point) | |
| 908 (line-end-position)) | |
| 909 (forward-line))) | |
| 910 (subject (prog1 | |
| 911 (buffer-substring (point) (line-end-position)) | |
| 912 (forward-line))) | |
| 913 (subject-re-p nil)) | |
| 914 (unless (gethash index mh-thread-scan-line-map) | |
| 915 (return-from process-message)) | |
| 916 (unless (integerp index) (return)) ;Error message here | |
| 917 (multiple-value-setq (subject subject-re-p) | |
| 918 (mh-thread-prune-subject subject)) | |
| 919 (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to)) | |
| 920 (setq refs (append (split-string refs) in-reply-to)) | |
| 921 (setq id (mh-thread-canonicalize-id id)) | |
| 922 (mh-thread-update-id-index-maps id index) | |
| 923 (setq refs (mapcar #'mh-thread-canonicalize-id refs)) | |
| 924 (mh-thread-get-message id subject-re-p subject refs) | |
| 925 (do ((ancestors refs (cdr ancestors))) | |
| 926 ((null (cdr ancestors)) | |
| 927 (when (car ancestors) | |
| 928 (mh-thread-remove-parent-link id) | |
| 929 (mh-thread-add-link (car ancestors) id))) | |
| 930 (mh-thread-add-link (car ancestors) (cadr ancestors))))))) | |
| 931 (maphash #'(lambda (k v) | |
| 932 (declare (ignore k)) | |
| 933 (when (null (mh-container-parent v)) | |
| 934 (push v roots))) | |
| 935 mh-thread-id-table) | |
| 936 (setq roots (mh-thread-prune-containers roots)) | |
| 937 (prog1 (setq roots (mh-thread-group-by-subject roots)) | |
| 938 (let ((history mh-thread-history)) | |
| 939 (set-buffer folder) | |
| 940 (setq mh-thread-history history)))))) | |
| 941 | |
| 942 ;;;###mh-autoload | |
| 943 (defun mh-thread-inc (folder start-point) | |
| 944 "Update thread tree for FOLDER. | |
| 945 All messages after START-POINT are added to the thread tree." | |
| 946 (mh-thread-rewind-pruning) | |
| 947 (goto-char start-point) | |
| 948 (let ((msg-list ())) | |
| 949 (while (not (eobp)) | |
| 950 (let ((index (mh-get-msg-num nil))) | |
| 951 (when (numberp index) | |
| 952 (push index msg-list) | |
| 953 (setf (gethash index mh-thread-scan-line-map) | |
| 954 (mh-thread-parse-scan-line))) | |
| 955 (forward-line))) | |
| 956 (let ((thread-tree (mh-thread-generate folder msg-list)) | |
| 957 (buffer-read-only nil) | |
| 958 (old-buffer-modified-flag (buffer-modified-p))) | |
| 959 (delete-region (point-min) (point-max)) | |
| 960 (let ((mh-thread-body-width (- (window-width) mh-cmd-note | |
| 961 (1- mh-scan-field-subject-start-offset))) | |
| 962 (mh-thread-last-ancestor nil)) | |
| 963 (mh-thread-generate-scan-lines thread-tree -2)) | |
| 964 (mh-notate-user-sequences) | |
| 965 (mh-notate-deleted-and-refiled) | |
| 966 (mh-notate-seq 'cur mh-note-cur mh-cmd-note) | |
| 967 (set-buffer-modified-p old-buffer-modified-flag)))) | |
| 968 | |
| 969 (defvar mh-thread-last-ancestor) | |
| 970 | |
| 971 (defun mh-thread-generate-scan-lines (tree level) | |
| 972 "Generate scan lines. | |
| 973 TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps message indices | |
| 974 to the corresponding scan lines and LEVEL used to determine indentation of | |
| 975 the message." | |
| 976 (cond ((null tree) nil) | |
| 977 ((mh-thread-container-p tree) | |
| 978 (let* ((message (mh-container-message tree)) | |
| 979 (id (mh-message-id message)) | |
| 980 (index (gethash id mh-thread-id-index-map)) | |
| 981 (duplicates (gethash id mh-thread-duplicates)) | |
| 982 (new-level (+ level 2)) | |
| 983 (dupl-flag t) | |
| 984 (force-angle-flag nil) | |
| 985 (increment-level-flag nil)) | |
| 986 (dolist (scan-line (mapcar (lambda (x) | |
| 987 (gethash x mh-thread-scan-line-map)) | |
| 988 (reverse (cons index duplicates)))) | |
| 989 (when scan-line | |
| 990 (when (and dupl-flag (equal level 0) | |
| 991 (mh-thread-ancestor-p mh-thread-last-ancestor tree)) | |
| 992 (setq level (+ level 2) | |
| 993 new-level (+ new-level 2) | |
| 994 force-angle-flag t)) | |
| 995 (when (equal level 0) | |
| 996 (setq mh-thread-last-ancestor tree) | |
| 997 (while (mh-container-parent mh-thread-last-ancestor) | |
| 998 (setq mh-thread-last-ancestor | |
| 999 (mh-container-parent mh-thread-last-ancestor)))) | |
| 1000 (insert (car scan-line) | |
| 1001 (format (format "%%%ss" | |
| 1002 (if dupl-flag level new-level)) "") | |
| 1003 (if (and (mh-container-real-child-p tree) dupl-flag | |
| 1004 (not force-angle-flag)) | |
| 1005 "[" "<") | |
| 1006 (cadr scan-line) | |
| 1007 (if (and (mh-container-real-child-p tree) dupl-flag | |
| 1008 (not force-angle-flag)) | |
| 1009 "]" ">") | |
| 1010 (truncate-string-to-width | |
| 1011 (caddr scan-line) (- mh-thread-body-width | |
| 1012 (if dupl-flag level new-level))) | |
| 1013 "\n") | |
| 1014 (setq increment-level-flag t) | |
| 1015 (setq dupl-flag nil))) | |
| 1016 (unless increment-level-flag (setq new-level level)) | |
| 1017 (dolist (child (mh-container-children tree)) | |
| 1018 (mh-thread-generate-scan-lines child new-level)))) | |
| 1019 (t (let ((nlevel (+ level 2))) | |
| 1020 (dolist (ch tree) | |
| 1021 (mh-thread-generate-scan-lines ch nlevel)))))) | |
| 1022 | |
| 1023 ;; Another and may be better approach would be to generate all the info from | |
| 1024 ;; the scan which generates the threading info. For now this will have to do. | |
| 1025 (defun mh-thread-parse-scan-line (&optional string) | |
| 1026 "Parse a scan line. | |
| 1027 If optional argument STRING is given then that is assumed to be the scan line. | |
| 1028 Otherwise uses the line at point as the scan line to parse." | |
| 1029 (let* ((string (or string | |
| 1030 (buffer-substring-no-properties (line-beginning-position) | |
| 1031 (line-end-position)))) | |
| 1032 (first-string (substring string 0 (+ mh-cmd-note 8)))) | |
| 1033 (setf (elt first-string mh-cmd-note) ? ) | |
| 1034 (when (equal (elt first-string (1+ mh-cmd-note)) (elt mh-note-seq 0)) | |
| 1035 (setf (elt first-string (1+ mh-cmd-note)) ? )) | |
| 1036 (list first-string | |
| 1037 (substring string | |
| 1038 (+ mh-cmd-note mh-scan-field-from-start-offset) | |
| 1039 (+ mh-cmd-note mh-scan-field-from-end-offset -2)) | |
| 1040 (substring string (+ mh-cmd-note mh-scan-field-from-end-offset)) | |
| 1041 string))) | |
| 1042 | |
| 1043 ;;;###mh-autoload | |
| 1044 (defun mh-thread-add-spaces (count) | |
| 1045 "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'." | |
| 1046 (let ((spaces (format (format "%%%ss" count) ""))) | |
| 1047 (while (not (eobp)) | |
| 1048 (let* ((msg-num (mh-get-msg-num nil)) | |
| 1049 (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map)))) | |
| 1050 (when (numberp msg-num) | |
| 1051 (setf (gethash msg-num mh-thread-scan-line-map) | |
| 1052 (mh-thread-parse-scan-line (format "%s%s" spaces old-line))))) | |
| 1053 (forward-line 1)))) | |
| 1054 | |
| 1055 (defun mh-thread-folder () | |
| 1056 "Generate thread view of folder." | |
| 1057 (message "Threading %s..." (buffer-name)) | |
| 1058 (mh-thread-initialize) | |
| 1059 (goto-char (point-min)) | |
| 1060 (while (not (eobp)) | |
| 1061 (let ((index (mh-get-msg-num nil))) | |
| 1062 (when (numberp index) | |
| 1063 (setf (gethash index mh-thread-scan-line-map) | |
| 1064 (mh-thread-parse-scan-line)))) | |
| 1065 (forward-line)) | |
| 1066 (let* ((range (format "%s-%s" mh-first-msg-num mh-last-msg-num)) | |
| 1067 (thread-tree (mh-thread-generate (buffer-name) (list range)))) | |
| 1068 (delete-region (point-min) (point-max)) | |
| 1069 (let ((mh-thread-body-width (- (window-width) mh-cmd-note | |
| 1070 (1- mh-scan-field-subject-start-offset))) | |
| 1071 (mh-thread-last-ancestor nil)) | |
| 1072 (mh-thread-generate-scan-lines thread-tree -2)) | |
| 1073 (mh-notate-user-sequences) | |
| 1074 (mh-notate-deleted-and-refiled) | |
| 1075 (mh-notate-seq 'cur mh-note-cur mh-cmd-note) | |
| 1076 (message "Threading %s...done" (buffer-name)))) | |
| 1077 | |
| 1078 ;;;###mh-autoload | |
| 1079 (defun mh-toggle-threads () | |
| 1080 "Toggle threaded view of folder. | |
| 1081 The conversion of normal view to threaded view is exact, that is the same | |
| 1082 messages are displayed in the folder buffer before and after threading. However | |
| 1083 the conversion from threaded view to normal view is inexact. So more messages | |
| 1084 than were originally present may be shown as a result." | |
| 1085 (interactive) | |
| 1086 (let ((msg-at-point (mh-get-msg-num nil)) | |
| 1087 (old-buffer-modified-flag (buffer-modified-p)) | |
| 1088 (buffer-read-only nil)) | |
| 1089 (cond ((and (memq 'unthread mh-view-ops) mh-narrowed-to-seq) | |
| 1090 (unless (mh-valid-view-change-operation-p 'unthread) | |
| 1091 (error "Can't unthread folder")) | |
| 1092 (mh-scan-folder mh-current-folder | |
| 1093 (format "%s" mh-narrowed-to-seq) | |
| 1094 t) | |
| 1095 (when mh-index-data | |
| 1096 (mh-index-insert-folder-headers))) | |
| 1097 ((memq 'unthread mh-view-ops) | |
| 1098 (unless (mh-valid-view-change-operation-p 'unthread) | |
| 1099 (error "Can't unthread folder")) | |
| 1100 (mh-scan-folder mh-current-folder | |
| 1101 (format "%s-%s" mh-first-msg-num mh-last-msg-num) | |
| 1102 t) | |
| 1103 (when mh-index-data | |
| 1104 (mh-index-insert-folder-headers))) | |
| 1105 (t (mh-thread-folder) | |
| 1106 (push 'unthread mh-view-ops))) | |
| 1107 (when msg-at-point (mh-goto-msg msg-at-point t t)) | |
| 1108 (set-buffer-modified-p old-buffer-modified-flag) | |
| 1109 (mh-recenter nil))) | |
| 1110 | |
| 1111 ;;;###mh-autoload | |
| 1112 (defun mh-thread-forget-message (index) | |
| 1113 "Forget the message INDEX from the threading tables." | |
| 1114 (let* ((id (gethash index mh-thread-index-id-map)) | |
| 1115 (id-index (gethash id mh-thread-id-index-map)) | |
| 1116 (duplicates (gethash id mh-thread-duplicates))) | |
| 1117 (remhash index mh-thread-index-id-map) | |
| 1118 (cond ((and (eql index id-index) (null duplicates)) | |
| 1119 (remhash id mh-thread-id-index-map)) | |
| 1120 ((eql index id-index) | |
| 1121 (setf (gethash id mh-thread-id-index-map) (car duplicates)) | |
| 1122 (setf (gethash (car duplicates) mh-thread-index-id-map) id) | |
| 1123 (setf (gethash id mh-thread-duplicates) (cdr duplicates))) | |
| 1124 (t | |
| 1125 (setf (gethash id mh-thread-duplicates) | |
| 1126 (remove index duplicates)))))) | |
| 1127 | |
| 1128 | |
| 1129 | |
| 1130 ;;; Operations on threads | |
| 1131 | |
| 1132 (defun mh-thread-current-indentation-level () | |
| 1133 "Find the number of spaces by which current message is indented." | |
| 1134 (save-excursion | |
| 1135 (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width | |
| 1136 mh-scan-date-width 1)) | |
| 1137 (level 0)) | |
| 1138 (beginning-of-line) | |
| 1139 (forward-char address-start-offset) | |
| 1140 (while (char-equal (char-after) ? ) | |
| 1141 (incf level) | |
| 1142 (forward-char)) | |
| 1143 level))) | |
| 1144 | |
| 1145 ;;;###mh-autoload | |
| 1146 (defun mh-thread-next-sibling (&optional previous-flag) | |
| 1147 "Jump to next sibling. | |
| 1148 With non-nil optional argument PREVIOUS-FLAG jump to the previous sibling." | |
| 1149 (interactive) | |
| 1150 (cond ((not (memq 'unthread mh-view-ops)) | |
| 1151 (error "Folder isn't threaded")) | |
| 1152 ((eobp) | |
| 1153 (error "No message at point"))) | |
| 1154 (beginning-of-line) | |
| 1155 (let ((point (point)) | |
| 1156 (done nil) | |
| 1157 (my-level (mh-thread-current-indentation-level))) | |
| 1158 (while (and (not done) | |
| 1159 (equal (forward-line (if previous-flag -1 1)) 0) | |
| 1160 (not (eobp))) | |
| 1161 (let ((level (mh-thread-current-indentation-level))) | |
| 1162 (cond ((equal level my-level) | |
| 1163 (setq done 'success)) | |
| 1164 ((< level my-level) | |
| 1165 (message "No %s sibling" (if previous-flag "previous" "next")) | |
| 1166 (setq done 'failure))))) | |
| 1167 (cond ((eq done 'success) (mh-maybe-show)) | |
| 1168 ((eq done 'failure) (goto-char point)) | |
| 1169 (t (message "No %s sibling" (if previous-flag "previous" "next")) | |
| 1170 (goto-char point))))) | |
| 1171 | |
| 1172 ;;;###mh-autoload | |
| 1173 (defun mh-thread-previous-sibling () | |
| 1174 "Jump to previous sibling." | |
| 1175 (interactive) | |
| 1176 (mh-thread-next-sibling t)) | |
| 1177 | |
| 1178 (defun mh-thread-immediate-ancestor () | |
| 1179 "Jump to immediate ancestor in thread tree." | |
| 1180 (beginning-of-line) | |
| 1181 (let ((point (point)) | |
| 1182 (ancestor-level (- (mh-thread-current-indentation-level) 2)) | |
| 1183 (done nil)) | |
| 1184 (if (< ancestor-level 0) | |
| 1185 nil | |
| 1186 (while (and (not done) (equal (forward-line -1) 0)) | |
| 1187 (when (equal ancestor-level (mh-thread-current-indentation-level)) | |
| 1188 (setq done t))) | |
| 1189 (unless done | |
| 1190 (goto-char point)) | |
| 1191 done))) | |
| 1192 | |
| 1193 ;;;###mh-autoload | |
| 1194 (defun mh-thread-ancestor (&optional thread-root-flag) | |
| 1195 "Jump to the ancestor of current message. | |
| 1196 If optional argument THREAD-ROOT-FLAG is non-nil then jump to the root of the | |
| 1197 thread tree the message belongs to." | |
| 1198 (interactive "P") | |
| 1199 (beginning-of-line) | |
| 1200 (cond ((not (memq 'unthread mh-view-ops)) | |
| 1201 (error "Folder isn't threaded")) | |
| 1202 ((eobp) | |
| 1203 (error "No message at point"))) | |
| 1204 (let ((current-level (mh-thread-current-indentation-level))) | |
| 1205 (cond (thread-root-flag | |
| 1206 (while (mh-thread-immediate-ancestor)) | |
| 1207 (mh-maybe-show)) | |
| 1208 ((equal current-level 1) | |
| 1209 (message "Message has no ancestor")) | |
| 1210 (t (mh-thread-immediate-ancestor) | |
| 1211 (mh-maybe-show))))) | |
| 1212 | |
| 1213 (defun mh-thread-find-children () | |
| 1214 "Return a region containing the current message and its children. | |
| 1215 The result is returned as a list of two elements. The first is the point at the | |
| 1216 start of the region and the second is the point at the end." | |
| 1217 (beginning-of-line) | |
| 1218 (if (eobp) | |
| 1219 nil | |
| 1220 (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width | |
| 1221 mh-scan-date-width 1)) | |
| 1222 (level (mh-thread-current-indentation-level)) | |
| 1223 spaces begin) | |
| 1224 (setq begin (point)) | |
| 1225 (setq spaces (format (format "%%%ss" (1+ level)) "")) | |
| 1226 (forward-line) | |
| 1227 (block nil | |
| 1228 (while (not (eobp)) | |
| 1229 (forward-char address-start-offset) | |
| 1230 (unless (equal (string-match spaces (buffer-substring-no-properties | |
| 1231 (point) (line-end-position))) | |
| 1232 0) | |
| 1233 (beginning-of-line) | |
| 1234 (backward-char) | |
| 1235 (return)) | |
| 1236 (forward-line))) | |
| 1237 (list begin (point))))) | |
| 1238 | |
| 1239 ;;;###mh-autoload | |
| 1240 (defun mh-thread-delete () | |
| 1241 "Mark current message and all its children for subsequent deletion." | |
| 1242 (interactive) | |
| 1243 (cond ((not (memq 'unthread mh-view-ops)) | |
| 1244 (error "Folder isn't threaded")) | |
| 1245 ((eobp) | |
| 1246 (error "No message at point")) | |
| 1247 (t (mh-delete-msg | |
| 1248 (apply #'mh-region-to-msg-list (mh-thread-find-children)))))) | |
| 1249 | |
| 1250 ;; This doesn't handle mh-default-folder-for-message-function. We should | |
| 1251 ;; refactor that code so that we don't copy it. | |
| 1252 ;;;###mh-autoload | |
| 1253 (defun mh-thread-refile (folder) | |
| 1254 "Mark current message and all its children for refiling to FOLDER." | |
| 1255 (interactive (list | |
| 1256 (intern (mh-prompt-for-folder | |
| 1257 "Destination" | |
| 1258 (cond ((eq 'refile (car mh-last-destination-folder)) | |
| 1259 (symbol-name (cdr mh-last-destination-folder))) | |
| 1260 (t "")) | |
| 1261 t)))) | |
| 1262 (cond ((not (memq 'unthread mh-view-ops)) | |
| 1263 (error "Folder isn't threaded")) | |
| 1264 ((eobp) | |
| 1265 (error "No message at point")) | |
| 1266 (t (mh-refile-msg | |
| 1267 (apply #'mh-region-to-msg-list (mh-thread-find-children)) | |
| 1268 folder)))) | |
| 1269 | |
| 1270 (provide 'mh-seq) | |
| 1271 | |
| 1272 ;;; Local Variables: | |
| 1273 ;;; indent-tabs-mode: nil | |
| 1274 ;;; sentence-end-double-space: nil | |
| 1275 ;;; End: | |
| 1276 | |
| 1277 ;;; mh-seq.el ends here |