code.delx.au - gnu-emacs/blob - lisp/mh-e/mh-seq.el

   1 ;;; mh-seq.el --- MH-E sequences support
   2
   3 ;; Copyright (C) 1993, 1995,
   4 ;;  2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc.
   5
   6 ;; Author: Bill Wohler <wohler@newt.com>
   7 ;; Maintainer: Bill Wohler <wohler@newt.com>
   8 ;; Keywords: mail
   9 ;; See: mh-e.el
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software; you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation; either version 2, or (at your option)
  16 ;; any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  25 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  26 ;; Boston, MA 02110-1301, USA.
  27
  28 ;;; Commentary:
  29 ;;
  30 ;;   This tries to implement the algorithm described at:
  31 ;;     http://www.jwz.org/doc/threading.html
  32 ;;   It is also a start to implementing the IMAP Threading extension RFC. The
  33 ;;   implementation lacks the reference and subject canonicalization of the
  34 ;;   RFC.
  35 ;;
  36 ;;   In the presentation buffer, children messages are shown indented with
  37 ;;   either [ ] or < > around them. Square brackets ([ ]) denote that the
  38 ;;   algorithm can point out some headers which when taken together implies
  39 ;;   that the unindented message is an ancestor of the indented message. If
  40 ;;   no such proof exists then angles (< >) are used.
  41 ;;
  42 ;;   Some issues and problems are as follows:
  43 ;;
  44 ;;    (1) Scan truncates the fields at length 512. So longer references:
  45 ;;        headers get mutilated. The same kind of MH format string works when
  46 ;;        composing messages. Is there a way to avoid this? My scan command
  47 ;;        is as follows:
  48 ;;          scan +folder -width 10000 \
  49 ;;               -format "%(msg)\n%{message-id}\n%{references}\n%{subject}\n"
  50 ;;        I would really appreciate it if someone would help me with this.
  51 ;;
  52 ;;    (2) Implement heuristics to recognize message identifiers in
  53 ;;        In-Reply-To: header. Right now it just assumes that the last text
  54 ;;        between angles (< and >) is the message identifier. There is the
  55 ;;        chance that this will incorrectly use an email address like a
  56 ;;        message identifier.
  57 ;;
  58 ;;    (3) Error checking of found message identifiers should be done.
  59 ;;
  60 ;;    (4) Since this breaks the assumption that message indices increase as
  61 ;;        one goes down the buffer, the binary search based mh-goto-msg
  62 ;;        doesn't work. I have a simpler replacement which may be less
  63 ;;        efficient.
  64 ;;
  65 ;;    (5) Better canonicalizing for message identifier and subject strings.
  66 ;;
  67
  68 ;; Internal support for MH-E package.
  69
  70 ;;; Change Log:
  71
  72 ;;; Code:
  73
  74 (eval-when-compile (require 'mh-acros))
  75 (mh-require-cl)
  76 (require 'mh-e)
  77
  78 ;; Shush the byte-compiler
  79 (defvar tool-bar-mode)
  80
  81 \f
  82
  83 ;;; Data structures (used in message threading)...
  84
  85 (mh-defstruct (mh-thread-message (:conc-name mh-message-)
  86                                  (:constructor mh-thread-make-message))
  87   (id nil)
  88   (references ())
  89   (subject "")
  90   (subject-re-p nil))
  91
  92 (mh-defstruct (mh-thread-container (:conc-name mh-container-)
  93                                    (:constructor mh-thread-make-container))
  94   message parent children
  95   (real-child-p t))
  96
  97 \f
  98
  99 ;;; Internal variables:
 100
 101 (defvar mh-last-seq-used nil
 102   "Name of seq to which a msg was last added.")
 103
 104 (defvar mh-non-seq-mode-line-annotation nil
 105   "Saved value of `mh-mode-line-annotation' when narrowed to a seq.")
 106
 107 \f
 108
 109 ;;; Maps and hashes...
 110
 111 (defvar mh-thread-id-hash nil
 112   "Hashtable used to canonicalize message identifiers.")
 113 (defvar mh-thread-subject-hash nil
 114   "Hashtable used to canonicalize subject strings.")
 115 (defvar mh-thread-id-table nil
 116   "Thread ID table maps from message identifiers to message containers.")
 117 (defvar mh-thread-id-index-map nil
 118   "Table to look up message index number from message identifier.")
 119 (defvar mh-thread-index-id-map nil
 120   "Table to look up message identifier from message index.")
 121 (defvar mh-thread-scan-line-map nil
 122   "Map of message index to various parts of the scan line.")
 123 (defvar mh-thread-scan-line-map-stack nil
 124   "Old map of message index to various parts of the scan line.
 125 This is the original map that is stored when the folder is
 126 narrowed.")
 127 (defvar mh-thread-subject-container-hash nil
 128   "Hashtable used to group messages by subject.")
 129 (defvar mh-thread-duplicates nil
 130   "Hashtable used to associate messages with the same message identifier.")
 131 (defvar mh-thread-history ()
 132   "Variable to remember the transformations to the thread tree.
 133 When new messages are added, these transformations are rewound,
 134 then the links are added from the newly seen messages. Finally
 135 the transformations are redone to get the new thread tree. This
 136 makes incremental threading easier.")
 137 (defvar mh-thread-body-width nil
 138   "Width of scan substring that contains subject and body of message.")
 139
 140 (make-variable-buffer-local 'mh-thread-id-hash)
 141 (make-variable-buffer-local 'mh-thread-subject-hash)
 142 (make-variable-buffer-local 'mh-thread-id-table)
 143 (make-variable-buffer-local 'mh-thread-id-index-map)
 144 (make-variable-buffer-local 'mh-thread-index-id-map)
 145 (make-variable-buffer-local 'mh-thread-scan-line-map)
 146 (make-variable-buffer-local 'mh-thread-scan-line-map-stack)
 147 (make-variable-buffer-local 'mh-thread-subject-container-hash)
 148 (make-variable-buffer-local 'mh-thread-duplicates)
 149 (make-variable-buffer-local 'mh-thread-history)
 150
 151 ;;;###mh-autoload
 152 (defun mh-delete-seq (sequence)
 153   "Delete SEQUENCE.
 154
 155 You are prompted for the sequence to delete. Note that this
 156 deletes only the sequence, not the messages in the sequence. If
 157 you want to delete the messages, use \"\\[universal-argument]
 158 \\[mh-delete-msg]\"."
 159   (interactive (list (mh-read-seq-default "Delete" t)))
 160   (let ((msg-list (mh-seq-to-msgs sequence))
 161         (internal-flag (mh-internal-seq sequence))
 162         (folders-changed (list mh-current-folder)))
 163     (mh-iterate-on-range msg sequence
 164       (mh-remove-sequence-notation msg internal-flag))
 165     (mh-undefine-sequence sequence '("all"))
 166     (mh-delete-seq-locally sequence)
 167     (when mh-index-data
 168       (setq folders-changed
 169             (append folders-changed
 170                     (mh-index-delete-from-sequence sequence msg-list))))
 171     (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
 172       (apply #'mh-speed-flists t folders-changed))))
 173
 174 ;; Avoid compiler warnings
 175 (defvar view-exit-action)
 176
 177 ;;;###mh-autoload
 178 (defun mh-list-sequences ()
 179   "List all sequences in folder.
 180
 181 The list appears in a buffer named \"*MH-E Sequences*\"."
 182   (interactive)
 183   (let ((folder mh-current-folder)
 184         (temp-buffer mh-sequences-buffer)
 185         (seq-list mh-seq-list)
 186         (max-len 0))
 187     (with-output-to-temp-buffer temp-buffer
 188       (save-excursion
 189         (set-buffer temp-buffer)
 190         (erase-buffer)
 191         (message "Listing sequences ...")
 192         (insert "Sequences in folder " folder ":\n")
 193         (let ((seq-list seq-list))
 194           (while seq-list
 195             (setq max-len
 196                   (max (length (symbol-name (mh-seq-name (pop seq-list))))
 197                        max-len)))
 198           (setq max-len (+ 2 max-len)))
 199         (while seq-list
 200           (let ((name (mh-seq-name (car seq-list)))
 201                 (sorted-seq-msgs
 202                  (mh-coalesce-msg-list
 203                   (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<)))
 204                 name-spec)
 205             (insert (setq name-spec (format (format "%%%ss:" max-len) name)))
 206             (while sorted-seq-msgs
 207               (let ((next-element (format " %s" (pop sorted-seq-msgs))))
 208                 (when (>= (+ (current-column) (length next-element))
 209                           (window-width))
 210                   (insert "\n")
 211                   (insert (format (format "%%%ss" (length name-spec)) "")))
 212                 (insert next-element)))
 213             (insert "\n"))
 214           (setq seq-list (cdr seq-list)))
 215         (goto-char (point-min))
 216         (view-mode-enter)
 217         (setq view-exit-action 'kill-buffer)
 218         (message "Listing sequences...done")))))
 219
 220 ;;;###mh-autoload
 221 (defun mh-msg-is-in-seq (message)
 222   "Display the sequences in which the current message appears.
 223
 224 Use a prefix argument to display the sequences in which another
 225 MESSAGE appears."
 226   (interactive "P")
 227   (if (not message)
 228       (setq message (mh-get-msg-num t)))
 229   (let* ((dest-folder (loop for seq in mh-refile-list
 230                             when (member message (cdr seq)) return (car seq)
 231                             finally return nil))
 232          (deleted-flag (unless dest-folder (member message mh-delete-list))))
 233     (message "Message %d%s is in sequences: %s"
 234              message
 235              (cond (dest-folder (format " (to be refiled to %s)" dest-folder))
 236                    (deleted-flag (format " (to be deleted)"))
 237                    (t ""))
 238              (mapconcat 'concat
 239                         (mh-list-to-string (mh-seq-containing-msg message t))
 240                         " "))))
 241
 242 ;; Avoid compiler warning
 243 (defvar tool-bar-map)
 244
 245 (make-variable-buffer-local 'mh-non-seq-mode-line-annotation)
 246
 247 ;;;###mh-autoload
 248 (defun mh-narrow-to-seq (sequence)
 249   "Restrict display to messages in SEQUENCE.
 250
 251 You are prompted for the name of the sequence. What this command
 252 does is show only those messages that are in the selected
 253 sequence in the MH-Folder buffer. In addition, it limits further
 254 MH-E searches to just those messages.
 255
 256 When you want to widen the view to all your messages again, use
 257 \\[mh-widen]."
 258   (interactive (list (mh-read-seq "Narrow to" t)))
 259   (with-mh-folder-updating (t)
 260     (cond ((mh-seq-to-msgs sequence)
 261            (mh-remove-all-notation)
 262            (let ((eob (point-max))
 263                  (msg-at-cursor (mh-get-msg-num nil)))
 264              (push mh-thread-scan-line-map mh-thread-scan-line-map-stack)
 265              (setq mh-thread-scan-line-map (make-hash-table :test #'eql))
 266              (mh-copy-seq-to-eob sequence)
 267              (push (buffer-substring-no-properties (point-min) eob)
 268                    mh-folder-view-stack)
 269              (delete-region (point-min) eob)
 270              (mh-notate-deleted-and-refiled)
 271              (mh-notate-cur)
 272              (when msg-at-cursor (mh-goto-msg msg-at-cursor t t))
 273              (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation)
 274              (setq mh-mode-line-annotation (symbol-name sequence))
 275              (mh-make-folder-mode-line)
 276              (mh-recenter nil)
 277              (when (and (boundp 'tool-bar-mode) tool-bar-mode)
 278                (set (make-local-variable 'tool-bar-map)
 279                     mh-folder-seq-tool-bar-map)
 280                (when (buffer-live-p (get-buffer mh-show-buffer))
 281                  (save-excursion
 282                    (set-buffer (get-buffer mh-show-buffer))
 283                    (set (make-local-variable 'tool-bar-map)
 284                         mh-show-seq-tool-bar-map))))
 285              (push 'widen mh-view-ops)))
 286           (t
 287            (error "No messages in sequence %s" (symbol-name sequence))))))
 288
 289 ;;;###mh-autoload
 290 (defun mh-put-msg-in-seq (range sequence)
 291   "Add RANGE to SEQUENCE\\<mh-folder-mode-map>.
 292
 293 To place a message in a sequence, use this command to do it
 294 manually, or use the MH command \"pick\" or the MH-E version of
 295 \"pick\", \\[mh-search-folder], which create a sequence
 296 automatically.
 297
 298 Give this command a RANGE and you can add all the messages in a
 299 sequence to another sequence (for example,
 300 \"\\[universal-argument] \\[mh-put-msg-in-seq] SourceSequence RET
 301 DestSequence RET\"). Check the documentation of
 302 `mh-interactive-range' to see how RANGE is read in interactive
 303 use."
 304   (interactive (list (mh-interactive-range "Add messages from")
 305                      (mh-read-seq-default "Add to" nil)))
 306   (unless (mh-valid-seq-p sequence)
 307     (error "Can't put message in invalid sequence %s" sequence))
 308   (let* ((internal-seq-flag (mh-internal-seq sequence))
 309          (original-msgs (mh-seq-msgs (mh-find-seq sequence)))
 310          (folders (list mh-current-folder))
 311          (msg-list (mh-range-to-msg-list range)))
 312     (mh-add-msgs-to-seq msg-list sequence nil t)
 313     (mh-iterate-on-range m range
 314       (unless (memq m original-msgs)
 315         (mh-add-sequence-notation m internal-seq-flag)))
 316     (if (not internal-seq-flag)
 317         (setq mh-last-seq-used sequence))
 318     (when mh-index-data
 319       (setq folders
 320             (append folders (mh-index-add-to-sequence sequence msg-list))))
 321     (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
 322       (apply #'mh-speed-flists t folders))))
 323
 324 (defun mh-valid-view-change-operation-p (op)
 325   "Check if the view change operation can be performed.
 326 OP is one of 'widen and 'unthread."
 327   (cond ((eq (car mh-view-ops) op)
 328          (pop mh-view-ops))
 329         (t nil)))
 330
 331 ;;;###mh-autoload
 332 (defun mh-widen (&optional all-flag)
 333   "Remove last restriction.
 334
 335 Each limit or sequence restriction can be undone in turn with
 336 this command. Give this command a prefix argument ALL-FLAG to
 337 remove all limits and sequence restrictions."
 338   (interactive "P")
 339   (let ((msg (mh-get-msg-num nil)))
 340     (when mh-folder-view-stack
 341       (cond (all-flag
 342              (while (cdr mh-view-ops)
 343                (setq mh-view-ops (cdr mh-view-ops)))
 344              (when (eq (car mh-view-ops) 'widen)
 345                (setq mh-view-ops (cdr mh-view-ops))))
 346             ((mh-valid-view-change-operation-p 'widen) nil)
 347             ((memq 'widen mh-view-ops)
 348              (while (not (eq (car mh-view-ops) 'widen))
 349                (setq mh-view-ops (cdr mh-view-ops)))
 350              (setq mh-view-ops (cdr mh-view-ops)))
 351             (t (error "Widening is not applicable")))
 352       ;; If ALL-FLAG is non-nil then rewind stacks
 353       (when all-flag
 354         (while (cdr mh-thread-scan-line-map-stack)
 355           (setq mh-thread-scan-line-map-stack
 356                 (cdr mh-thread-scan-line-map-stack)))
 357         (while (cdr mh-folder-view-stack)
 358           (setq mh-folder-view-stack (cdr mh-folder-view-stack))))
 359       (setq mh-thread-scan-line-map (pop mh-thread-scan-line-map-stack))
 360       (with-mh-folder-updating (t)
 361         (delete-region (point-min) (point-max))
 362         (insert (pop mh-folder-view-stack))
 363         (mh-remove-all-notation)
 364         (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation)
 365         (mh-make-folder-mode-line))
 366       (if msg
 367           (mh-goto-msg msg t t))
 368       (mh-notate-deleted-and-refiled)
 369       (mh-notate-user-sequences)
 370       (mh-notate-cur)
 371       (mh-recenter nil)))
 372   (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode)
 373     (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)
 374     (when (buffer-live-p (get-buffer mh-show-buffer))
 375       (save-excursion
 376         (set-buffer (get-buffer mh-show-buffer))
 377         (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)))))
 378
 379 ;; FIXME?  We may want to clear all notations and add one for current-message
 380 ;;         and process user sequences.
 381 ;;;###mh-autoload
 382 (defun mh-notate-deleted-and-refiled ()
 383   "Notate messages marked for deletion or refiling.
 384 Messages to be deleted are given by `mh-delete-list' while
 385 messages to be refiled are present in `mh-refile-list'."
 386   (let ((refiled-hash (make-hash-table))
 387         (deleted-hash (make-hash-table)))
 388     (dolist (msg mh-delete-list)
 389       (setf (gethash msg deleted-hash) t))
 390     (dolist (dest-msg-list mh-refile-list)
 391       (dolist (msg (cdr dest-msg-list))
 392         (setf (gethash msg refiled-hash) t)))
 393     (mh-iterate-on-messages-in-region msg (point-min) (point-max)
 394       (cond ((gethash msg refiled-hash)
 395              (mh-notate nil mh-note-refiled mh-cmd-note))
 396             ((gethash msg deleted-hash)
 397              (mh-notate nil mh-note-deleted mh-cmd-note))))))
 398
 399 \f
 400
 401 ;;; Commands to manipulate sequences.
 402
 403 ;; Sequences are stored in an alist of the form:
 404 ;;     ((seq-name msgs ...) (seq-name msgs ...) ...)
 405
 406 (defvar mh-sequence-history ())
 407
 408 ;;;###mh-autoload
 409 (defun mh-read-seq-default (prompt not-empty)
 410   "Read and return sequence name with default narrowed or previous sequence.
 411 PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil
 412 then a non-empty sequence is read."
 413   (mh-read-seq prompt not-empty
 414                (or mh-last-seq-used
 415                    (car (mh-seq-containing-msg (mh-get-msg-num nil) nil)))))
 416
 417 (defun mh-read-seq (prompt not-empty &optional default)
 418   "Read and return a sequence name.
 419 Prompt with PROMPT, raise an error if the sequence is empty and
 420 the NOT-EMPTY flag is non-nil, and supply an optional DEFAULT
 421 sequence. A reply of '%' defaults to the first sequence
 422 containing the current message."
 423   (let* ((input (completing-read (format "%s sequence%s: " prompt
 424                                          (if default
 425                                              (format " (default %s)" default)
 426                                            ""))
 427                                  (mh-seq-names mh-seq-list)
 428                                  nil nil nil 'mh-sequence-history))
 429          (seq (cond ((equal input "%")
 430                      (car (mh-seq-containing-msg (mh-get-msg-num t) nil)))
 431                     ((equal input "") default)
 432                     (t (intern input))))
 433          (msgs (mh-seq-to-msgs seq)))
 434     (if (and (null msgs) not-empty)
 435         (error "No messages in sequence %s" seq))
 436     seq))
 437
 438 \f
 439
 440 ;;; Functions to read ranges with completion...
 441
 442 (defvar mh-range-seq-names)
 443 (defvar mh-range-history ())
 444 (defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map))
 445 (define-key mh-range-completion-map " " 'self-insert-command)
 446
 447 (defun mh-range-completion-function (string predicate flag)
 448   "Programmable completion of message ranges.
 449 STRING is the user input that is to be completed. PREDICATE if non-nil is a
 450 function used to filter the possible choices and FLAG determines whether the
 451 completion is over."
 452   (let* ((candidates mh-range-seq-names)
 453          (last-char (and (not (equal string ""))
 454                          (aref string (1- (length string)))))
 455          (last-word (cond ((null last-char) "")
 456                           ((memq last-char '(?  ?- ?:)) "")
 457                           (t (car (last (split-string string "[ -:]+"))))))
 458          (prefix (substring string 0 (- (length string) (length last-word)))))
 459     (cond ((eq flag nil)
 460            (let ((res (try-completion last-word candidates predicate)))
 461              (cond ((null res) nil)
 462                    ((eq res t) t)
 463                    (t (concat prefix res)))))
 464           ((eq flag t)
 465            (all-completions last-word candidates predicate))
 466           ((eq flag 'lambda)
 467            (loop for x in candidates
 468                  when (equal x last-word) return t
 469                  finally return nil)))))
 470
 471 ;;;###mh-autoload
 472 (defun mh-read-range (prompt &optional folder default
 473                              expand-flag ask-flag number-as-range-flag)
 474   "Read a message range with PROMPT.
 475
 476 If FOLDER is non-nil then a range is read from that folder, otherwise
 477 use `mh-current-folder'.
 478
 479 If DEFAULT is a string then use that as default range to return. If
 480 DEFAULT is nil then ask user with default answer a range based on the
 481 sequences that seem relevant. Finally if DEFAULT is t, try to avoid
 482 prompting the user. Unseen messages, if present, are returned. If the
 483 folder has fewer than `mh-large-folder' messages then \"all\" messages
 484 are returned. Finally as a last resort prompt the user.
 485
 486 If EXPAND-FLAG is non-nil then a list of message numbers corresponding
 487 to the input is returned. If this list is empty then an error is
 488 raised. If EXPAND-FLAG is nil just return the input string. In this
 489 case we don't check if the range is empty.
 490
 491 If ASK-FLAG is non-nil, then the user is always queried for a range of
 492 messages. If ASK-FLAG is nil, then the function checks if the unseen
 493 sequence is non-empty. If that is the case, `mh-unseen-seq', or the
 494 list of messages in it depending on the value of EXPAND, is returned.
 495 Otherwise if the folder has fewer than `mh-large-folder' messages then
 496 the list of messages corresponding to \"all\" is returned. If neither
 497 of the above holds then as a last resort the user is queried for a
 498 range of messages.
 499
 500 If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as
 501 input, it is interpreted as the range \"last:N\".
 502
 503 This function replaces the existing function `mh-read-msg-range'.
 504 Calls to:
 505
 506   (mh-read-msg-range folder flag)
 507
 508 should be replaced with:
 509
 510   (mh-read-range \"Suitable prompt\" folder t nil flag
 511                  mh-interpret-number-as-range-flag)"
 512   (setq default (or default mh-last-seq-used
 513                     (car (mh-seq-containing-msg (mh-get-msg-num nil) t)))
 514         prompt (format "%s range" prompt))
 515   (let* ((folder (or folder mh-current-folder))
 516          (guess (eq default t))
 517          (counts (and guess (mh-folder-size folder)))
 518          (unseen (and counts (> (cadr counts) 0)))
 519          (large (and counts mh-large-folder (> (car counts) mh-large-folder)))
 520          (default (cond ((and guess large) (format "last:%s" mh-large-folder))
 521                         ((and guess (not large)) "all")
 522                         ((stringp default) default)
 523                         ((symbolp default) (symbol-name default))))
 524          (prompt (cond ((and guess large default)
 525                         (format "%s (folder has %s messages, default %s)"
 526                                 prompt (car counts) default))
 527                        ((and guess large)
 528                         (format "%s (folder has %s messages)"
 529                                 prompt (car counts)))
 530                        (default
 531                          (format "%s (default %s)" prompt default))))
 532          (minibuffer-local-completion-map mh-range-completion-map)
 533          (seq-list (if (eq folder mh-current-folder)
 534                        mh-seq-list
 535                      (mh-read-folder-sequences folder nil)))
 536          (mh-range-seq-names
 537           (append '(("first") ("last") ("all") ("prev") ("next"))
 538                   (mh-seq-names seq-list)))
 539          (input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq))
 540                       ((and (not ask-flag) (not large)) "all")
 541                       (t (completing-read (format "%s: " prompt)
 542                                           'mh-range-completion-function nil nil
 543                                           nil 'mh-range-history default))))
 544          msg-list)
 545     (when (and number-as-range-flag
 546                (string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input))
 547       (setq input (concat "last:" (match-string 1 input))))
 548     (cond ((not expand-flag) input)
 549           ((assoc (intern input) seq-list)
 550            (cdr (assoc (intern input) seq-list)))
 551           ((setq msg-list (mh-translate-range folder input)) msg-list)
 552           (t (error "No messages in range %s" input)))))
 553
 554 ;;;###mh-autoload
 555 (defun mh-translate-range (folder expr)
 556   "In FOLDER, translate the string EXPR to a list of messages numbers."
 557   (save-excursion
 558     (let ((strings (delete "" (split-string expr "[ \t\n]")))
 559           (result ()))
 560       (ignore-errors
 561         (apply #'mh-exec-cmd-quiet nil "mhpath" folder strings)
 562         (set-buffer mh-temp-buffer)
 563         (goto-char (point-min))
 564         (while (re-search-forward "/\\([0-9]*\\)$" nil t)
 565           (push (car (read-from-string (match-string 1))) result))
 566         (nreverse result)))))
 567
 568 (defun mh-seq-names (seq-list)
 569   "Return an alist containing the names of the SEQ-LIST."
 570   (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry))))
 571           seq-list))
 572
 573 ;;;###mh-autoload
 574 (defun mh-rename-seq (sequence new-name)
 575   "Rename SEQUENCE to have NEW-NAME."
 576   (interactive (list (mh-read-seq "Old" t)
 577                      (intern (read-string "New sequence name: "))))
 578   (let ((old-seq (mh-find-seq sequence)))
 579     (or old-seq
 580         (error "Sequence %s does not exist" sequence))
 581     ;; create new sequence first, since it might raise an error.
 582     (mh-define-sequence new-name (mh-seq-msgs old-seq))
 583     (mh-undefine-sequence sequence (mh-seq-msgs old-seq))
 584     (rplaca old-seq new-name)))
 585
 586 ;;;###mh-autoload
 587 (defun mh-notate-cur ()
 588   "Mark the MH sequence cur.
 589 In addition to notating the current message with `mh-note-cur'
 590 the function uses `overlay-arrow-position' to put a marker in the
 591 fringe."
 592   (let ((cur (car (mh-seq-to-msgs 'cur))))
 593     (when (and cur (mh-goto-msg cur t t))
 594       (beginning-of-line)
 595       (when (looking-at mh-scan-good-msg-regexp)
 596         (mh-notate nil mh-note-cur mh-cmd-note))
 597       (setq mh-arrow-marker (set-marker mh-arrow-marker (point)))
 598       (setq overlay-arrow-position mh-arrow-marker))))
 599
 600 ;;;###mh-autoload
 601 (defun mh-add-to-sequence (seq msgs)
 602   "The sequence SEQ is augmented with the messages in MSGS."
 603   ;; Add to a SEQUENCE each message the list of MSGS.
 604   (if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq)))
 605       (if msgs
 606           (apply 'mh-exec-cmd "mark" mh-current-folder "-add"
 607                  "-sequence" (symbol-name seq)
 608                  (mh-coalesce-msg-list msgs)))))
 609
 610 (defvar mh-thread-last-ancestor)
 611
 612 (defun mh-copy-seq-to-eob (seq)
 613   "Copy SEQ to the end of the buffer."
 614   ;; It is quite involved to write something which will work at any place in
 615   ;; the buffer, so we will write something which works only at the end of
 616   ;; the buffer. If we ever need to insert sequences in the middle of the
 617   ;; buffer, this will need to be fixed.
 618   (save-excursion
 619     (let* ((msgs (mh-seq-to-msgs seq))
 620            (coalesced-msgs (mh-coalesce-msg-list msgs)))
 621       (goto-char (point-max))
 622       (save-restriction
 623         (narrow-to-region (point) (point))
 624         (mh-regenerate-headers coalesced-msgs t)
 625         (cond ((memq 'unthread mh-view-ops)
 626                ;; Populate restricted scan-line map
 627                (mh-remove-all-notation)
 628                (mh-iterate-on-range msg (cons (point-min) (point-max))
 629                  (setf (gethash msg mh-thread-scan-line-map)
 630                        (mh-thread-parse-scan-line)))
 631                ;; Remove scan lines and read results from pre-computed tree
 632                (delete-region (point-min) (point-max))
 633                (mh-thread-print-scan-lines
 634                 (mh-thread-generate mh-current-folder ()))
 635                (mh-notate-user-sequences))
 636               (mh-index-data
 637                (mh-index-insert-folder-headers)))))))
 638
 639 ;;;###mh-autoload
 640 (defmacro mh-iterate-on-messages-in-region (var begin end &rest body)
 641   "Iterate over region.
 642
 643 VAR is bound to the message on the current line as we loop
 644 starting from BEGIN till END. In each step BODY is executed.
 645
 646 If VAR is nil then the loop is executed without any binding."
 647   (unless (symbolp var)
 648     (error "Can not bind the non-symbol %s" var))
 649   (let ((binding-needed-flag var))
 650     `(save-excursion
 651        (goto-char ,begin)
 652        (beginning-of-line)
 653        (while (and (<= (point) ,end) (not (eobp)))
 654          (when (looking-at mh-scan-valid-regexp)
 655            (let ,(if binding-needed-flag `((,var (mh-get-msg-num t))) ())
 656              ,@body))
 657          (forward-line 1)))))
 658
 659 (put 'mh-iterate-on-messages-in-region 'lisp-indent-hook 'defun)
 660
 661 ;;;###mh-autoload
 662 (defmacro mh-iterate-on-range (var range &rest body)
 663   "Iterate an operation over a region or sequence.
 664
 665 VAR is bound to each message in turn in a loop over RANGE, which
 666 can be a message number, a list of message numbers, a sequence, a
 667 region in a cons cell, or a MH range (something like last:20) in
 668 a string. In each iteration, BODY is executed.
 669
 670 The parameter RANGE is usually created with
 671 `mh-interactive-range' in order to provide a uniform interface to
 672 MH-E functions."
 673   (unless (symbolp var)
 674     (error "Can not bind the non-symbol %s" var))
 675   (let ((binding-needed-flag var)
 676         (msgs (make-symbol "msgs"))
 677         (seq-hash-table (make-symbol "seq-hash-table")))
 678     `(cond ((numberp ,range)
 679             (when (mh-goto-msg ,range t t)
 680               (let ,(if binding-needed-flag `((,var ,range)) ())
 681                 ,@body)))
 682            ((and (consp ,range)
 683                  (numberp (car ,range)) (numberp (cdr ,range)))
 684             (mh-iterate-on-messages-in-region ,var
 685               (car ,range) (cdr ,range)
 686               ,@body))
 687            (t (let ((,msgs (cond ((and ,range (symbolp ,range))
 688                                   (mh-seq-to-msgs ,range))
 689                                  ((stringp ,range)
 690                                   (mh-translate-range mh-current-folder
 691                                                       ,range))
 692                                  (t ,range)))
 693                     (,seq-hash-table (make-hash-table)))
 694                 (dolist (msg ,msgs)
 695                   (setf (gethash msg ,seq-hash-table) t))
 696                 (mh-iterate-on-messages-in-region v (point-min) (point-max)
 697                   (when (gethash v ,seq-hash-table)
 698                     (let ,(if binding-needed-flag `((,var v)) ())
 699                       ,@body))))))))
 700
 701 (put 'mh-iterate-on-range 'lisp-indent-hook 'defun)
 702
 703 ;;;###mh-autoload
 704 (defun mh-range-to-msg-list (range)
 705   "Return a list of messages for RANGE.
 706
 707 Check the documentation of `mh-interactive-range' to see how
 708 RANGE is read in interactive use."
 709   (let (msg-list)
 710     (mh-iterate-on-range msg range
 711       (push msg msg-list))
 712     (nreverse msg-list)))
 713
 714 ;;;###mh-autoload
 715 (defun mh-interactive-range (range-prompt &optional default)
 716   "Return interactive specification for message, sequence, range or region.
 717 By convention, the name of this argument is RANGE.
 718
 719 If variable `transient-mark-mode' is non-nil and the mark is active,
 720 then this function returns a cons-cell of the region.
 721
 722 If optional prefix argument is provided, then prompt for message range
 723 with RANGE-PROMPT. A list of messages in that range is returned.
 724
 725 If a MH range is given, say something like last:20, then a list
 726 containing the messages in that range is returned.
 727
 728 If DEFAULT non-nil then it is returned.
 729
 730 Otherwise, the message number at point is returned.
 731
 732 This function is usually used with `mh-iterate-on-range' in order to
 733 provide a uniform interface to MH-E functions."
 734   (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))
 735         (current-prefix-arg (mh-read-range range-prompt nil nil t t))
 736         (default default)
 737         (t (mh-get-msg-num t))))
 738
 739 \f
 740
 741 ;;; Commands to handle new 'subject sequence ("Poor man's threading" by psg)
 742
 743 ;; XXX: The function mh-subject-to-sequence-unthreaded uses the magic number
 744 ;;  41 for the max size of the subject part. Avoiding this would be desirable.
 745 (defun mh-subject-to-sequence (all)
 746   "Put all following messages with same subject in sequence 'subject.
 747 If arg ALL is t, move to beginning of folder buffer to collect all
 748 messages.
 749 If arg ALL is nil, collect only messages fron current one on forward.
 750
 751 Return number of messages put in the sequence:
 752
 753  nil -> there was no subject line.
 754
 755  0   -> there were no later messages with the same
 756         subject (sequence not made)
 757
 758  >1  -> the total number of messages including current one."
 759   (if (memq 'unthread mh-view-ops)
 760       (mh-subject-to-sequence-threaded all)
 761     (mh-subject-to-sequence-unthreaded all)))
 762
 763 (defun mh-subject-to-sequence-unthreaded (all)
 764   "Put all following messages with same subject in sequence 'subject.
 765
 766 This function only works with an unthreaded folder. If arg ALL is
 767 t, move to beginning of folder buffer to collect all messages. If
 768 arg ALL is nil, collect only messages fron current one on
 769 forward.
 770
 771 Return number of messages put in the sequence:
 772
 773  nil -> there was no subject line.
 774  0   -> there were no later messages with the same
 775         subject (sequence not made)
 776  >1  -> the total number of messages including current one."
 777   (if (not (eq major-mode 'mh-folder-mode))
 778       (error "Not in a folder buffer"))
 779   (save-excursion
 780     (beginning-of-line)
 781     (if (or (not (looking-at mh-scan-subject-regexp))
 782             (not (match-string 3))
 783             (string-equal "" (match-string 3)))
 784         (progn (message "No subject line")
 785                nil)
 786       (let ((subject (match-string-no-properties 3))
 787             (list))
 788         (if (> (length subject) 41)
 789             (setq subject (substring subject 0 41)))
 790         (save-excursion
 791           (if all
 792               (goto-char (point-min)))
 793           (while (re-search-forward mh-scan-subject-regexp nil t)
 794             (let ((this-subject (match-string-no-properties 3)))
 795               (if (> (length this-subject) 41)
 796                   (setq this-subject (substring this-subject 0 41)))
 797               (if (string-equal this-subject subject)
 798                   (setq list (cons (mh-get-msg-num t) list))))))
 799         (cond
 800          (list
 801           ;; If we created a new sequence, add the initial message to it too.
 802           (if (not (member (mh-get-msg-num t) list))
 803               (setq list (cons (mh-get-msg-num t) list)))
 804           (if (assoc 'subject mh-seq-list) (mh-delete-seq 'subject))
 805           ;; sort the result into a sequence
 806           (let ((sorted-list (sort (copy-sequence list) 'mh-lessp)))
 807             (while sorted-list
 808               (mh-add-msgs-to-seq (car sorted-list) 'subject nil)
 809               (setq sorted-list (cdr sorted-list)))
 810             (safe-length list)))
 811          (t
 812           0))))))
 813
 814 (defun mh-subject-to-sequence-threaded (all)
 815   "Put all messages with the same subject in the 'subject sequence.
 816
 817 This function works when the folder is threaded. In this
 818 situation the subject could get truncated and so the normal
 819 matching doesn't work.
 820
 821 The parameter ALL is non-nil then all the messages in the buffer
 822 are considered, otherwise only the messages after the current one
 823 are taken into account."
 824   (let* ((cur (mh-get-msg-num nil))
 825          (subject (mh-thread-find-msg-subject cur))
 826          region msgs)
 827     (if (null subject)
 828         (and (message "No subject line") nil)
 829       (setq region (cons (if all (point-min) (point)) (point-max)))
 830       (mh-iterate-on-range msg region
 831         (when (eq (mh-thread-find-msg-subject msg) subject)
 832           (push msg msgs)))
 833       (setq msgs (sort msgs #'mh-lessp))
 834       (if (null msgs)
 835           0
 836         (when (assoc 'subject mh-seq-list)
 837           (mh-delete-seq 'subject))
 838         (mh-add-msgs-to-seq msgs 'subject)
 839         (length msgs)))))
 840
 841 (defun mh-thread-find-msg-subject (msg)
 842   "Find canonicalized subject of MSG.
 843 This function can only be used the folder is threaded."
 844   (ignore-errors
 845     (mh-message-subject
 846      (mh-container-message (gethash (gethash msg mh-thread-index-id-map)
 847                                     mh-thread-id-table)))))
 848
 849 (defun mh-edit-pick-expr (default)
 850   "With prefix arg edit a pick expression.
 851 If no prefix arg is given, then return DEFAULT."
 852   (let ((default-string (loop for x in default concat (format " %s" x))))
 853     (if (or current-prefix-arg (equal default-string ""))
 854         (mh-pick-args-list (read-string "Pick expression: "
 855                                         default-string))
 856       default)))
 857
 858 (defun mh-pick-args-list (s)
 859   "Form list by grouping elements in string S suitable for pick arguments.
 860 For example, the string \"-subject a b c -from Joe User
 861 <user@domain.com>\" is converted to (\"-subject\" \"a b c\"
 862 \"-from\" \"Joe User <user@domain.com>\""
 863   (let ((full-list (split-string s))
 864         current-arg collection arg-list)
 865     (while full-list
 866       (setq current-arg (car full-list))
 867       (if (null (string-match "^-" current-arg))
 868           (setq collection
 869                 (if (null collection)
 870                     current-arg
 871                   (format "%s %s" collection current-arg)))
 872         (when collection
 873           (setq arg-list (append arg-list (list collection)))
 874           (setq collection nil))
 875         (setq arg-list (append arg-list (list current-arg))))
 876       (setq full-list (cdr full-list)))
 877     (when collection
 878       (setq arg-list (append arg-list (list collection))))
 879     arg-list))
 880
 881 ;;;###mh-autoload
 882 (defun mh-narrow-to-subject (&optional pick-expr)
 883   "Limit to messages with same subject.
 884 With a prefix argument, edit PICK-EXPR.
 885
 886 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
 887   (interactive
 888    (list (mh-edit-pick-expr (mh-current-message-header-field 'subject))))
 889   (mh-narrow-to-header-field 'subject pick-expr))
 890
 891 ;;;###mh-autoload
 892 (defun mh-narrow-to-from (&optional pick-expr)
 893   "Limit to messages with the same \"From:\" field.
 894 With a prefix argument, edit PICK-EXPR.
 895
 896 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
 897   (interactive
 898    (list (mh-edit-pick-expr (mh-current-message-header-field 'from))))
 899   (mh-narrow-to-header-field 'from pick-expr))
 900
 901 ;;;###mh-autoload
 902 (defun mh-narrow-to-cc (&optional pick-expr)
 903   "Limit to messages with the same \"Cc:\" field.
 904 With a prefix argument, edit PICK-EXPR.
 905
 906 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
 907   (interactive
 908    (list (mh-edit-pick-expr (mh-current-message-header-field 'cc))))
 909   (mh-narrow-to-header-field 'cc pick-expr))
 910
 911 ;;;###mh-autoload
 912 (defun mh-narrow-to-to (&optional pick-expr)
 913   "Limit to messages with the same \"To:\" field.
 914 With a prefix argument, edit PICK-EXPR.
 915
 916 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
 917   (interactive
 918    (list (mh-edit-pick-expr (mh-current-message-header-field 'to))))
 919   (mh-narrow-to-header-field 'to pick-expr))
 920
 921 (defun mh-narrow-to-header-field (header-field pick-expr)
 922   "Limit to messages whose HEADER-FIELD match PICK-EXPR.
 923 The MH command pick is used to do the match."
 924   (let ((folder mh-current-folder)
 925         (original (mh-coalesce-msg-list
 926                    (mh-range-to-msg-list (cons (point-min) (point-max)))))
 927         (msg-list ()))
 928     (with-temp-buffer
 929       (apply #'mh-exec-cmd-output "pick" nil folder
 930              (append original (list "-list") pick-expr))
 931       (goto-char (point-min))
 932       (while (not (eobp))
 933         (let ((num (read-from-string
 934                     (buffer-substring (point) (line-end-position)))))
 935           (when (numberp (car num)) (push (car num) msg-list))
 936           (forward-line))))
 937     (if (null msg-list)
 938         (message "No matches")
 939       (when (assoc 'header mh-seq-list) (mh-delete-seq 'header))
 940       (mh-add-msgs-to-seq msg-list 'header)
 941       (mh-narrow-to-seq 'header))))
 942
 943 (defun mh-current-message-header-field (header-field)
 944   "Return a pick regexp to match HEADER-FIELD of the message at point."
 945   (let ((num (mh-get-msg-num nil)))
 946     (when num
 947       (let ((folder mh-current-folder))
 948         (with-temp-buffer
 949           (insert-file-contents-literally (mh-msg-filename num folder))
 950           (goto-char (point-min))
 951           (when (search-forward "\n\n" nil t)
 952             (narrow-to-region (point-min) (point)))
 953           (let* ((field (or (message-fetch-field (format "%s" header-field))
 954                             ""))
 955                  (field-option (format "-%s" header-field))
 956                  (patterns (loop for x in (split-string  field "[ ]*,[ ]*")
 957                                  unless (equal x "")
 958                                  collect (if (string-match "<\\(.*@.*\\)>" x)
 959                                              (match-string 1 x)
 960                                            x))))
 961             (when patterns
 962               (loop with accum = `(,field-option ,(car patterns))
 963                     for e in (cdr patterns)
 964                     do (setq accum `(,field-option ,e "-or" ,@accum))
 965                     finally return accum))))))))
 966
 967 ;;;###mh-autoload
 968 (defun mh-narrow-to-range (range)
 969   "Limit to RANGE.
 970
 971 Check the documentation of `mh-interactive-range' to see how
 972 RANGE is read in interactive use.
 973
 974 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
 975   (interactive (list (mh-interactive-range "Narrow to")))
 976   (when (assoc 'range mh-seq-list) (mh-delete-seq 'range))
 977   (mh-add-msgs-to-seq (mh-range-to-msg-list range) 'range)
 978   (mh-narrow-to-seq 'range))
 979
 980
 981 ;;;###mh-autoload
 982 (defun mh-delete-subject ()
 983   "Delete messages with same subject\\<mh-folder-mode-map>.
 984
 985 To delete messages faster, you can use this command to delete all
 986 the messages with the same subject as the current message. This
 987 command puts these messages in a sequence named \"subject\". You
 988 can undo this action by using \\[mh-undo] with a prefix argument
 989 and then specifying the \"subject\" sequence."
 990   (interactive)
 991   (let ((count (mh-subject-to-sequence nil)))
 992     (cond
 993      ((not count)                       ; No subject line, delete msg anyway
 994       (mh-delete-msg (mh-get-msg-num t)))
 995      ((= 0 count)                       ; No other msgs, delete msg anyway.
 996       (message "No other messages with same Subject following this one")
 997       (mh-delete-msg (mh-get-msg-num t)))
 998      (t                                 ; We have a subject sequence.
 999       (message "Marked %d messages for deletion" count)
1000       (mh-delete-msg 'subject)))))
1001
1002 ;;;###mh-autoload
1003 (defun mh-delete-subject-or-thread ()
1004   "Delete messages with same subject or thread\\<mh-folder-mode-map>.
1005
1006 To delete messages faster, you can use this command to delete all
1007 the messages with the same subject as the current message. This
1008 command puts these messages in a sequence named \"subject\". You
1009 can undo this action by using \\[mh-undo] with a prefix argument
1010 and then specifying the \"subject\" sequence.
1011
1012 However, if the buffer is displaying a threaded view of the
1013 folder then this command behaves like \\[mh-thread-delete]."
1014   (interactive)
1015   (if (memq 'unthread mh-view-ops)
1016       (mh-thread-delete)
1017     (mh-delete-subject)))
1018
1019 \f
1020
1021 ;;; Message threading:
1022
1023 (defmacro mh-thread-initialize-hash (var test)
1024   "Initialize the hash table in VAR.
1025 TEST is the test to use when creating a new hash table."
1026   (unless (symbolp var) (error "Expected a symbol: %s" var))
1027   `(if ,var (clrhash ,var) (setq ,var (make-hash-table :test ,test))))
1028
1029 (defun mh-thread-initialize ()
1030   "Make new hash tables, or clear them if already present."
1031   (mh-thread-initialize-hash mh-thread-id-hash #'equal)
1032   (mh-thread-initialize-hash mh-thread-subject-hash #'equal)
1033   (mh-thread-initialize-hash mh-thread-id-table #'eq)
1034   (mh-thread-initialize-hash mh-thread-id-index-map #'eq)
1035   (mh-thread-initialize-hash mh-thread-index-id-map #'eql)
1036   (mh-thread-initialize-hash mh-thread-scan-line-map #'eql)
1037   (mh-thread-initialize-hash mh-thread-subject-container-hash #'eq)
1038   (mh-thread-initialize-hash mh-thread-duplicates #'eq)
1039   (setq mh-thread-history ()))
1040
1041 (defsubst mh-thread-id-container (id)
1042   "Given ID, return the corresponding container in `mh-thread-id-table'.
1043 If no container exists then a suitable container is created and
1044 the id-table is updated."
1045   (when (not id)
1046     (error "1"))
1047   (or (gethash id mh-thread-id-table)
1048       (setf (gethash id mh-thread-id-table)
1049             (let ((message (mh-thread-make-message :id id)))
1050               (mh-thread-make-container :message message)))))
1051
1052 (defsubst mh-thread-remove-parent-link (child)
1053   "Remove parent link of CHILD if it exists."
1054   (let* ((child-container (if (mh-thread-container-p child)
1055                               child (mh-thread-id-container child)))
1056          (parent-container (mh-container-parent child-container)))
1057     (when parent-container
1058       (setf (mh-container-children parent-container)
1059             (loop for elem in (mh-container-children parent-container)
1060                   unless (eq child-container elem) collect elem))
1061       (setf (mh-container-parent child-container) nil))))
1062
1063 (defsubst mh-thread-add-link (parent child &optional at-end-p)
1064   "Add links so that PARENT becomes a parent of CHILD.
1065 Doesn't make any changes if CHILD is already an ancestor of
1066 PARENT. If optional argument AT-END-P is non-nil, the CHILD is
1067 added to the end of the children list of PARENT."
1068   (let ((parent-container (cond ((null parent) nil)
1069                                 ((mh-thread-container-p parent) parent)
1070                                 (t (mh-thread-id-container parent))))
1071         (child-container (if (mh-thread-container-p child)
1072                              child (mh-thread-id-container child))))
1073     (when (and parent-container
1074                (not (mh-thread-ancestor-p child-container parent-container))
1075                (not (mh-thread-ancestor-p parent-container child-container)))
1076       (mh-thread-remove-parent-link child-container)
1077       (cond ((not at-end-p)
1078              (push child-container (mh-container-children parent-container)))
1079             ((null (mh-container-children parent-container))
1080              (push child-container (mh-container-children parent-container)))
1081             (t (let ((last-child (mh-container-children parent-container)))
1082                  (while (cdr last-child)
1083                    (setq last-child (cdr last-child)))
1084                  (setcdr last-child (cons child-container nil)))))
1085       (setf (mh-container-parent child-container) parent-container))
1086     (unless parent-container
1087       (mh-thread-remove-parent-link child-container))))
1088
1089 (defun mh-thread-ancestor-p (ancestor successor)
1090   "Return t if ANCESTOR is really an ancestor of SUCCESSOR and nil otherwise.
1091 In the limit, the function returns t if ANCESTOR and SUCCESSOR
1092 are the same containers."
1093   (block nil
1094     (while successor
1095       (when (eq ancestor successor) (return t))
1096       (setq successor (mh-container-parent successor)))
1097     nil))
1098
1099 (defsubst mh-thread-get-message-container (message)
1100   "Return container which has MESSAGE in it.
1101 If there is no container present then a new container is
1102 allocated."
1103   (let* ((id (mh-message-id message))
1104          (container (gethash id mh-thread-id-table)))
1105     (cond (container (setf (mh-container-message container) message)
1106                      container)
1107           (t (setf (gethash id mh-thread-id-table)
1108                    (mh-thread-make-container :message message))))))
1109
1110 (defsubst mh-thread-get-message (id subject-re-p subject refs)
1111   "Return appropriate message.
1112 Otherwise update message already present to have the proper ID,
1113 SUBJECT-RE-P, SUBJECT and REFS fields."
1114   (let* ((container (gethash id mh-thread-id-table))
1115          (message (if container (mh-container-message container) nil)))
1116     (cond (message
1117            (setf (mh-message-subject-re-p message) subject-re-p)
1118            (setf (mh-message-subject message) subject)
1119            (setf (mh-message-id message) id)
1120            (setf (mh-message-references message) refs)
1121            message)
1122           (container
1123            (setf (mh-container-message container)
1124                  (mh-thread-make-message :id id :references refs
1125                                          :subject subject
1126                                          :subject-re-p subject-re-p)))
1127           (t (let ((message (mh-thread-make-message :id id :references refs
1128                                                     :subject-re-p subject-re-p
1129                                                     :subject subject)))
1130                (prog1 message
1131                  (mh-thread-get-message-container message)))))))
1132
1133 (defsubst mh-thread-canonicalize-id (id)
1134   "Produce canonical string representation for ID.
1135 This allows cheap string comparison with EQ."
1136   (or (and (equal id "") (copy-sequence ""))
1137       (gethash id mh-thread-id-hash)
1138       (setf (gethash id mh-thread-id-hash) id)))
1139
1140 (defsubst mh-thread-prune-subject (subject)
1141   "Prune leading Re:'s, Fwd:'s etc. and trailing (fwd)'s from SUBJECT.
1142 If the result after pruning is not the empty string then it is
1143 canonicalized so that subjects can be tested for equality with
1144 eq. This is done so that all the messages without a subject are
1145 not put into a single thread."
1146   (let ((case-fold-search t)
1147         (subject-pruned-flag nil))
1148     ;; Prune subject leader
1149     (while (or (string-match "^[ \t]*\\(re\\|fwd?\\)\\(\\[[0-9]*\\]\\)?:[ \t]*"
1150                              subject)
1151                (string-match "^[ \t]*\\[[^\\]][ \t]*" subject))
1152       (setq subject-pruned-flag t)
1153       (setq subject (substring subject (match-end 0))))
1154     ;; Prune subject trailer
1155     (while (or (string-match "(fwd)$" subject)
1156                (string-match "[ \t]+$" subject))
1157       (setq subject-pruned-flag t)
1158       (setq subject (substring subject 0 (match-beginning 0))))
1159     ;; Canonicalize subject only if it is non-empty
1160     (cond ((equal subject "") (values subject subject-pruned-flag))
1161           (t (values
1162               (or (gethash subject mh-thread-subject-hash)
1163                   (setf (gethash subject mh-thread-subject-hash) subject))
1164               subject-pruned-flag)))))
1165
1166 (defun mh-thread-container-subject (container)
1167   "Return the subject of CONTAINER.
1168 If CONTAINER is empty return the subject info of one of its
1169 children."
1170   (cond ((and (mh-container-message container)
1171               (mh-message-id (mh-container-message container)))
1172          (mh-message-subject (mh-container-message container)))
1173         (t (block nil
1174              (dolist (kid (mh-container-children container))
1175                (when (and (mh-container-message kid)
1176                           (mh-message-id (mh-container-message kid)))
1177                  (let ((kid-message (mh-container-message kid)))
1178                    (return (mh-message-subject kid-message)))))
1179              (error "This can't happen")))))
1180
1181 (defun mh-thread-rewind-pruning ()
1182   "Restore the thread tree to its state before pruning."
1183   (while mh-thread-history
1184     (let ((action (pop mh-thread-history)))
1185       (cond ((eq (car action) 'DROP)
1186              (mh-thread-remove-parent-link (cadr action))
1187              (mh-thread-add-link (caddr action) (cadr action)))
1188             ((eq (car action) 'PROMOTE)
1189              (let ((node (cadr action))
1190                    (parent (caddr action))
1191                    (children (cdddr action)))
1192                (dolist (child children)
1193                  (mh-thread-remove-parent-link child)
1194                  (mh-thread-add-link node child))
1195                (mh-thread-add-link parent node)))
1196             ((eq (car action) 'SUBJECT)
1197              (let ((node (cadr action)))
1198                (mh-thread-remove-parent-link node)
1199                (setf (mh-container-real-child-p node) t)))))))
1200
1201 (defun mh-thread-prune-containers (roots)
1202   "Prune empty containers in the containers ROOTS."
1203   (let ((dfs-ordered-nodes ())
1204         (work-list roots))
1205     (while work-list
1206       (let ((node (pop work-list)))
1207         (dolist (child (mh-container-children node))
1208           (push child work-list))
1209         (push node dfs-ordered-nodes)))
1210     (while dfs-ordered-nodes
1211       (let ((node (pop dfs-ordered-nodes)))
1212         (cond ((gethash (mh-message-id (mh-container-message node))
1213                         mh-thread-id-index-map)
1214                ;; Keep it
1215                (setf (mh-container-children node)
1216                      (mh-thread-sort-containers (mh-container-children node))))
1217               ((and (mh-container-children node)
1218                     (or (null (cdr (mh-container-children node)))
1219                         (mh-container-parent node)))
1220                ;; Promote kids
1221                (let ((children ()))
1222                  (dolist (kid (mh-container-children node))
1223                    (mh-thread-remove-parent-link kid)
1224                    (mh-thread-add-link (mh-container-parent node) kid)
1225                    (push kid children))
1226                  (push `(PROMOTE ,node ,(mh-container-parent node) ,@children)
1227                        mh-thread-history)
1228                  (mh-thread-remove-parent-link node)))
1229               ((mh-container-children node)
1230                ;; Promote the first orphan to parent and add the other kids as
1231                ;; his children
1232                (setf (mh-container-children node)
1233                      (mh-thread-sort-containers (mh-container-children node)))
1234                (let ((new-parent (car (mh-container-children node)))
1235                      (other-kids (cdr (mh-container-children node))))
1236                  (mh-thread-remove-parent-link new-parent)
1237                  (dolist (kid other-kids)
1238                    (mh-thread-remove-parent-link kid)
1239                    (setf (mh-container-real-child-p kid) nil)
1240                    (mh-thread-add-link new-parent kid t))
1241                  (push `(PROMOTE ,node ,(mh-container-parent node)
1242                                  ,new-parent ,@other-kids)
1243                        mh-thread-history)
1244                  (mh-thread-remove-parent-link node)))
1245               (t
1246                ;; Drop it
1247                (push `(DROP ,node ,(mh-container-parent node))
1248                      mh-thread-history)
1249                (mh-thread-remove-parent-link node)))))
1250     (let ((results ()))
1251       (maphash #'(lambda (k v)
1252                    (declare (ignore k))
1253                    (when (and (null (mh-container-parent v))
1254                               (gethash (mh-message-id (mh-container-message v))
1255                                        mh-thread-id-index-map))
1256                      (push v results)))
1257                mh-thread-id-table)
1258       (mh-thread-sort-containers results))))
1259
1260 (defun mh-thread-sort-containers (containers)
1261   "Sort a list of message CONTAINERS to be in ascending order wrt index."
1262   (sort containers
1263         #'(lambda (x y)
1264             (when (and (mh-container-message x) (mh-container-message y))
1265               (let* ((id-x (mh-message-id (mh-container-message x)))
1266                      (id-y (mh-message-id (mh-container-message y)))
1267                      (index-x (gethash id-x mh-thread-id-index-map))
1268                      (index-y (gethash id-y mh-thread-id-index-map)))
1269                 (and (integerp index-x) (integerp index-y)
1270                      (< index-x index-y)))))))
1271
1272 (defsubst mh-thread-group-by-subject (roots)
1273   "Group the set of message containers, ROOTS based on subject.
1274 Bug: Check for and make sure that something without Re: is made
1275 the parent in preference to something that has it."
1276   (clrhash mh-thread-subject-container-hash)
1277   (let ((results ()))
1278     (dolist (root roots)
1279       (let* ((subject (mh-thread-container-subject root))
1280              (parent (gethash subject mh-thread-subject-container-hash)))
1281         (cond (parent (mh-thread-remove-parent-link root)
1282                       (mh-thread-add-link parent root t)
1283                       (setf (mh-container-real-child-p root) nil)
1284                       (push `(SUBJECT ,root) mh-thread-history))
1285               (t
1286                (setf (gethash subject mh-thread-subject-container-hash) root)
1287                (push root results)))))
1288     (nreverse results)))
1289
1290 (defun mh-thread-process-in-reply-to (reply-to-header)
1291   "Extract message id's from REPLY-TO-HEADER.
1292 Ideally this should have some regexp which will try to guess if a
1293 string between < and > is a message id and not an email address.
1294 For now it will take the last string inside angles."
1295   (let ((end (mh-search-from-end ?> reply-to-header)))
1296     (when (numberp end)
1297       (let ((begin (mh-search-from-end ?< (substring reply-to-header 0 end))))
1298         (when (numberp begin)
1299           (list (substring reply-to-header begin (1+ end))))))))
1300
1301 (defun mh-thread-set-tables (folder)
1302   "Use the tables of FOLDER in current buffer."
1303   (flet ((mh-get-table (symbol)
1304                        (save-excursion
1305                          (set-buffer folder)
1306                          (symbol-value symbol))))
1307     (setq mh-thread-id-hash (mh-get-table 'mh-thread-id-hash))
1308     (setq mh-thread-subject-hash (mh-get-table 'mh-thread-subject-hash))
1309     (setq mh-thread-id-table (mh-get-table 'mh-thread-id-table))
1310     (setq mh-thread-id-index-map (mh-get-table 'mh-thread-id-index-map))
1311     (setq mh-thread-index-id-map (mh-get-table 'mh-thread-index-id-map))
1312     (setq mh-thread-scan-line-map (mh-get-table 'mh-thread-scan-line-map))
1313     (setq mh-thread-subject-container-hash
1314           (mh-get-table 'mh-thread-subject-container-hash))
1315     (setq mh-thread-duplicates (mh-get-table 'mh-thread-duplicates))
1316     (setq mh-thread-history (mh-get-table 'mh-thread-history))))
1317
1318 (defsubst mh-thread-update-id-index-maps (id index)
1319   "Message with id, ID is the message in INDEX.
1320 The function also checks for duplicate messages (that is multiple
1321 messages with the same ID). These messages are put in the
1322 `mh-thread-duplicates' hash table."
1323   (let ((old-index (gethash id mh-thread-id-index-map)))
1324     (when old-index (push old-index (gethash id mh-thread-duplicates)))
1325     (setf (gethash id mh-thread-id-index-map) index)
1326     (setf (gethash index mh-thread-index-id-map) id)))
1327
1328 \f
1329
1330 ;;; Generate Threads...
1331
1332 (defvar mh-message-id-regexp "^<.*@.*>$"
1333   "Regexp to recognize whether a string is a message identifier.")
1334
1335 (defun mh-thread-generate (folder msg-list)
1336   "Scan FOLDER to get info for threading.
1337 Only information about messages in MSG-LIST are added to the tree."
1338   (with-temp-buffer
1339     (mh-thread-set-tables folder)
1340     (when msg-list
1341       (apply
1342        #'call-process (expand-file-name mh-scan-prog mh-progs) nil '(t nil) nil
1343        "-width" "10000" "-format"
1344        "%(msg)\n%{message-id}\n%{references}\n%{in-reply-to}\n%{subject}\n"
1345        folder (mapcar #'(lambda (x) (format "%s" x)) msg-list)))
1346     (goto-char (point-min))
1347     (let ((roots ())
1348           (case-fold-search t))
1349       (block nil
1350         (while (not (eobp))
1351           (block process-message
1352             (let* ((index-line
1353                     (prog1 (buffer-substring (point) (line-end-position))
1354                       (forward-line)))
1355                    (index (car (read-from-string index-line)))
1356                    (id (prog1 (buffer-substring (point) (line-end-position))
1357                          (forward-line)))
1358                    (refs (prog1 (buffer-substring (point) (line-end-position))
1359                            (forward-line)))
1360                    (in-reply-to (prog1 (buffer-substring (point)
1361                                                          (line-end-position))
1362                                   (forward-line)))
1363                    (subject (prog1
1364                                 (buffer-substring (point) (line-end-position))
1365                               (forward-line)))
1366                    (subject-re-p nil))
1367               (unless (gethash index mh-thread-scan-line-map)
1368                 (return-from process-message))
1369               (unless (integerp index) (return)) ;Error message here
1370               (multiple-value-setq (subject subject-re-p)
1371                 (mh-thread-prune-subject subject))
1372               (setq in-reply-to (mh-thread-process-in-reply-to in-reply-to))
1373               (setq refs (loop for x in (append (split-string refs) in-reply-to)
1374                                when (string-match mh-message-id-regexp x)
1375                                collect x))
1376               (setq id (mh-thread-canonicalize-id id))
1377               (mh-thread-update-id-index-maps id index)
1378               (setq refs (mapcar #'mh-thread-canonicalize-id refs))
1379               (mh-thread-get-message id subject-re-p subject refs)
1380               (do ((ancestors refs (cdr ancestors)))
1381                   ((null (cdr ancestors))
1382                    (when (car ancestors)
1383                      (mh-thread-remove-parent-link id)
1384                      (mh-thread-add-link (car ancestors) id)))
1385                 (mh-thread-add-link (car ancestors) (cadr ancestors)))))))
1386       (maphash #'(lambda (k v)
1387                    (declare (ignore k))
1388                    (when (null (mh-container-parent v))
1389                      (push v roots)))
1390                mh-thread-id-table)
1391       (setq roots (mh-thread-prune-containers roots))
1392       (prog1 (setq roots (mh-thread-group-by-subject roots))
1393         (let ((history mh-thread-history))
1394           (set-buffer folder)
1395           (setq mh-thread-history history))))))
1396
1397 ;;;###mh-autoload
1398 (defun mh-thread-inc (folder start-point)
1399   "Update thread tree for FOLDER.
1400 All messages after START-POINT are added to the thread tree."
1401   (mh-thread-rewind-pruning)
1402   (mh-remove-all-notation)
1403   (goto-char start-point)
1404   (let ((msg-list ()))
1405     (while (not (eobp))
1406       (let ((index (mh-get-msg-num nil)))
1407         (when (numberp index)
1408           (push index msg-list)
1409           (setf (gethash index mh-thread-scan-line-map)
1410                 (mh-thread-parse-scan-line)))
1411         (forward-line)))
1412     (let ((thread-tree (mh-thread-generate folder msg-list))
1413           (buffer-read-only nil)
1414           (old-buffer-modified-flag (buffer-modified-p)))
1415       (delete-region (point-min) (point-max))
1416       (mh-thread-print-scan-lines thread-tree)
1417       (mh-notate-user-sequences)
1418       (mh-notate-deleted-and-refiled)
1419       (mh-notate-cur)
1420       (set-buffer-modified-p old-buffer-modified-flag))))
1421
1422 (defun mh-thread-generate-scan-lines (tree level)
1423   "Generate scan lines.
1424 TREE is the hierarchical tree of messages, SCAN-LINE-MAP maps
1425 message indices to the corresponding scan lines and LEVEL used to
1426 determine indentation of the message."
1427   (cond ((null tree) nil)
1428         ((mh-thread-container-p tree)
1429          (let* ((message (mh-container-message tree))
1430                 (id (mh-message-id message))
1431                 (index (gethash id mh-thread-id-index-map))
1432                 (duplicates (gethash id mh-thread-duplicates))
1433                 (new-level (+ level 2))
1434                 (dupl-flag t)
1435                 (force-angle-flag nil)
1436                 (increment-level-flag nil))
1437            (dolist (scan-line (mapcar (lambda (x)
1438                                         (gethash x mh-thread-scan-line-map))
1439                                       (reverse (cons index duplicates))))
1440              (when scan-line
1441                (when (and dupl-flag (equal level 0)
1442                           (mh-thread-ancestor-p mh-thread-last-ancestor tree))
1443                  (setq level (+ level 2)
1444                        new-level (+ new-level 2)
1445                        force-angle-flag t))
1446                (when (equal level 0)
1447                  (setq mh-thread-last-ancestor tree)
1448                  (while (mh-container-parent mh-thread-last-ancestor)
1449                    (setq mh-thread-last-ancestor
1450                          (mh-container-parent mh-thread-last-ancestor))))
1451                (let* ((lev (if dupl-flag level new-level))
1452                       (square-flag (or (and (mh-container-real-child-p tree)
1453                                             (not force-angle-flag)
1454                                             dupl-flag)
1455                                        (equal lev 0))))
1456                  (insert (car scan-line)
1457                          (format (format "%%%ss" lev) "")
1458                          (if square-flag "[" "<")
1459                          (cadr scan-line)
1460                          (if square-flag "]" ">")
1461                          (truncate-string-to-width
1462                           (caddr scan-line) (- mh-thread-body-width lev))
1463                          "\n"))
1464                (setq increment-level-flag t)
1465                (setq dupl-flag nil)))
1466            (unless increment-level-flag (setq new-level level))
1467            (dolist (child (mh-container-children tree))
1468              (mh-thread-generate-scan-lines child new-level))))
1469         (t (let ((nlevel (+ level 2)))
1470              (dolist (ch tree)
1471                (mh-thread-generate-scan-lines ch nlevel))))))
1472
1473 ;; Another and may be better approach would be to generate all the info from
1474 ;; the scan which generates the threading info. For now this will have to do.
1475 (defun mh-thread-parse-scan-line (&optional string)
1476   "Parse a scan line.
1477 If optional argument STRING is given then that is assumed to be
1478 the scan line. Otherwise uses the line at point as the scan line
1479 to parse."
1480   (let* ((string (or string
1481                      (buffer-substring-no-properties (line-beginning-position)
1482                                                      (line-end-position))))
1483          (address-start (+ mh-cmd-note mh-scan-field-from-start-offset))
1484          (body-start (+ mh-cmd-note mh-scan-field-from-end-offset))
1485          (first-string (substring string 0 address-start)))
1486     (list first-string
1487           (substring string address-start (- body-start 2))
1488           (substring string body-start)
1489           string)))
1490
1491 ;;;###mh-autoload
1492 (defun mh-thread-update-scan-line-map (msg notation offset)
1493   "In threaded view update `mh-thread-scan-line-map'.
1494 MSG is the message being notated with NOTATION at OFFSET."
1495   (let* ((msg (or msg (mh-get-msg-num nil)))
1496          (cur-scan-line (and mh-thread-scan-line-map
1497                              (gethash msg mh-thread-scan-line-map)))
1498          (old-scan-lines (loop for map in mh-thread-scan-line-map-stack
1499                                collect (and map (gethash msg map)))))
1500     (when cur-scan-line
1501       (setf (aref (car cur-scan-line) offset) notation))
1502     (dolist (line old-scan-lines)
1503       (when line (setf (aref (car line) offset) notation)))))
1504
1505 ;;;###mh-autoload
1506 (defun mh-thread-add-spaces (count)
1507   "Add COUNT spaces to each scan line in `mh-thread-scan-line-map'."
1508   (let ((spaces (format (format "%%%ss" count) "")))
1509     (while (not (eobp))
1510       (let* ((msg-num (mh-get-msg-num nil))
1511              (old-line (nth 3 (gethash msg-num mh-thread-scan-line-map))))
1512         (when (numberp msg-num)
1513           (setf (gethash msg-num mh-thread-scan-line-map)
1514                 (mh-thread-parse-scan-line (format "%s%s" spaces old-line)))))
1515       (forward-line 1))))
1516
1517 (defun mh-thread-print-scan-lines (thread-tree)
1518   "Print scan lines in THREAD-TREE in threaded mode."
1519   (let ((mh-thread-body-width (- (window-width) mh-cmd-note
1520                                  (1- mh-scan-field-subject-start-offset)))
1521         (mh-thread-last-ancestor nil))
1522     (if (null mh-index-data)
1523         (mh-thread-generate-scan-lines thread-tree -2)
1524       (loop for x in (mh-index-group-by-folder)
1525             do (let* ((old-map mh-thread-scan-line-map)
1526                       (mh-thread-scan-line-map (make-hash-table)))
1527                  (setq mh-thread-last-ancestor nil)
1528                  (loop for msg in (cdr x)
1529                        do (let ((v (gethash msg old-map)))
1530                             (when v
1531                               (setf (gethash msg mh-thread-scan-line-map) v))))
1532                  (when (> (hash-table-count mh-thread-scan-line-map) 0)
1533                    (insert (if (bobp) "" "\n") (car x) "\n")
1534                    (mh-thread-generate-scan-lines thread-tree -2))))
1535       (mh-index-create-imenu-index))))
1536
1537 (defun mh-thread-folder ()
1538   "Generate thread view of folder."
1539   (message "Threading %s..." (buffer-name))
1540   (mh-thread-initialize)
1541   (goto-char (point-min))
1542   (mh-remove-all-notation)
1543   (let ((msg-list ()))
1544     (mh-iterate-on-range msg (cons (point-min) (point-max))
1545       (setf (gethash msg mh-thread-scan-line-map) (mh-thread-parse-scan-line))
1546       (push msg msg-list))
1547     (let* ((range (mh-coalesce-msg-list msg-list))
1548            (thread-tree (mh-thread-generate (buffer-name) range)))
1549       (delete-region (point-min) (point-max))
1550       (mh-thread-print-scan-lines thread-tree)
1551       (mh-notate-user-sequences)
1552       (mh-notate-deleted-and-refiled)
1553       (mh-notate-cur)
1554       (message "Threading %s...done" (buffer-name)))))
1555
1556 ;;;###mh-autoload
1557 (defun mh-toggle-threads ()
1558   "Toggle threaded view of folder."
1559   (interactive)
1560   (let ((msg-at-point (mh-get-msg-num nil))
1561         (old-buffer-modified-flag (buffer-modified-p))
1562         (buffer-read-only nil))
1563     (cond ((memq 'unthread mh-view-ops)
1564            (unless (mh-valid-view-change-operation-p 'unthread)
1565              (error "Can't unthread folder"))
1566            (let ((msg-list ()))
1567              (goto-char (point-min))
1568              (while (not (eobp))
1569                (let ((index (mh-get-msg-num nil)))
1570                  (when index
1571                    (push index msg-list)))
1572                (forward-line))
1573              (mh-scan-folder mh-current-folder
1574                              (mapcar #'(lambda (x) (format "%s" x))
1575                                      (mh-coalesce-msg-list msg-list))
1576                              t))
1577            (when mh-index-data
1578              (mh-index-insert-folder-headers)
1579              (mh-notate-cur)))
1580           (t (mh-thread-folder)
1581              (push 'unthread mh-view-ops)))
1582     (when msg-at-point (mh-goto-msg msg-at-point t t))
1583     (set-buffer-modified-p old-buffer-modified-flag)
1584     (mh-recenter nil)))
1585
1586 ;;;###mh-autoload
1587 (defun mh-thread-forget-message (index)
1588   "Forget the message INDEX from the threading tables."
1589   (let* ((id (gethash index mh-thread-index-id-map))
1590          (id-index (gethash id mh-thread-id-index-map))
1591          (duplicates (gethash id mh-thread-duplicates)))
1592     (remhash index mh-thread-index-id-map)
1593     (remhash index mh-thread-scan-line-map)
1594     (cond ((and (eql index id-index) (null duplicates))
1595            (remhash id mh-thread-id-index-map))
1596           ((eql index id-index)
1597            (setf (gethash id mh-thread-id-index-map) (car duplicates))
1598            (setf (gethash (car duplicates) mh-thread-index-id-map) id)
1599            (setf (gethash id mh-thread-duplicates) (cdr duplicates)))
1600           (t
1601            (setf (gethash id mh-thread-duplicates)
1602                  (remove index duplicates))))))
1603
1604 \f
1605
1606 ;;; Operations on threads
1607
1608 (defun mh-thread-current-indentation-level ()
1609   "Find the number of spaces by which current message is indented."
1610   (save-excursion
1611     (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width
1612                                    mh-scan-date-width 1))
1613           (level 0))
1614       (beginning-of-line)
1615       (forward-char address-start-offset)
1616       (while (char-equal (char-after) ? )
1617         (incf level)
1618         (forward-char))
1619       level)))
1620
1621 ;;;###mh-autoload
1622 (defun mh-thread-next-sibling (&optional previous-flag)
1623   "Display next sibling.
1624
1625 With non-nil optional argument PREVIOUS-FLAG jump to the previous
1626 sibling."
1627   (interactive)
1628   (cond ((not (memq 'unthread mh-view-ops))
1629          (error "Folder isn't threaded"))
1630         ((eobp)
1631          (error "No message at point")))
1632   (beginning-of-line)
1633   (let ((point (point))
1634         (done nil)
1635         (my-level (mh-thread-current-indentation-level)))
1636     (while (and (not done)
1637                 (equal (forward-line (if previous-flag -1 1)) 0)
1638                 (not (eobp)))
1639       (let ((level (mh-thread-current-indentation-level)))
1640         (cond ((equal level my-level)
1641                (setq done 'success))
1642               ((< level my-level)
1643                (message "No %s sibling" (if previous-flag "previous" "next"))
1644                (setq done 'failure)))))
1645     (cond ((eq done 'success) (mh-maybe-show))
1646           ((eq done 'failure) (goto-char point))
1647           (t (message "No %s sibling" (if previous-flag "previous" "next"))
1648              (goto-char point)))))
1649
1650 ;;;###mh-autoload
1651 (defun mh-thread-previous-sibling ()
1652   "Display previous sibling."
1653   (interactive)
1654   (mh-thread-next-sibling t))
1655
1656 (defun mh-thread-immediate-ancestor ()
1657   "Jump to immediate ancestor in thread tree."
1658   (beginning-of-line)
1659   (let ((point (point))
1660         (ancestor-level (- (mh-thread-current-indentation-level) 2))
1661         (done nil))
1662     (if (< ancestor-level 0)
1663         nil
1664       (while (and (not done) (equal (forward-line -1) 0))
1665         (when (equal ancestor-level (mh-thread-current-indentation-level))
1666           (setq done t)))
1667       (unless done
1668         (goto-char point))
1669       done)))
1670
1671 ;;;###mh-autoload
1672 (defun mh-thread-ancestor (&optional thread-root-flag)
1673   "Display ancestor of current message.
1674
1675 If you do not care for the way a particular thread has turned,
1676 you can move up the chain of messages with this command. This
1677 command can also take a prefix argument THREAD-ROOT-FLAG to jump
1678 to the message that started everything."
1679   (interactive "P")
1680   (beginning-of-line)
1681   (cond ((not (memq 'unthread mh-view-ops))
1682          (error "Folder isn't threaded"))
1683         ((eobp)
1684          (error "No message at point")))
1685   (let ((current-level (mh-thread-current-indentation-level)))
1686     (cond (thread-root-flag
1687            (while (mh-thread-immediate-ancestor))
1688            (mh-maybe-show))
1689           ((equal current-level 1)
1690            (message "Message has no ancestor"))
1691           (t (mh-thread-immediate-ancestor)
1692              (mh-maybe-show)))))
1693
1694 (defun mh-thread-find-children ()
1695   "Return a region containing the current message and its children.
1696 The result is returned as a list of two elements. The first is
1697 the point at the start of the region and the second is the point
1698 at the end."
1699   (beginning-of-line)
1700   (if (eobp)
1701       nil
1702     (let ((address-start-offset (+ mh-cmd-note mh-scan-date-flag-width
1703                                    mh-scan-date-width 1))
1704           (level (mh-thread-current-indentation-level))
1705           spaces begin)
1706       (setq begin (point))
1707       (setq spaces (format (format "%%%ss" (1+ level)) ""))
1708       (forward-line)
1709       (block nil
1710         (while (not (eobp))
1711           (forward-char address-start-offset)
1712           (unless (equal (string-match spaces (buffer-substring-no-properties
1713                                                (point) (line-end-position)))
1714                          0)
1715             (beginning-of-line)
1716             (backward-char)
1717             (return))
1718           (forward-line)))
1719       (list begin (point)))))
1720
1721 ;;;###mh-autoload
1722 (defun mh-thread-delete ()
1723   "Delete thread."
1724   (interactive)
1725   (cond ((not (memq 'unthread mh-view-ops))
1726          (error "Folder isn't threaded"))
1727         ((eobp)
1728          (error "No message at point"))
1729         (t (let ((region (mh-thread-find-children)))
1730              (mh-iterate-on-messages-in-region () (car region) (cadr region)
1731                (mh-delete-a-msg nil))
1732              (mh-next-msg)))))
1733
1734 ;;;###mh-autoload
1735 (defun mh-thread-refile (folder)
1736   "Refile (output) thread into FOLDER."
1737   (interactive (list (intern (mh-prompt-for-refile-folder))))
1738   (cond ((not (memq 'unthread mh-view-ops))
1739          (error "Folder isn't threaded"))
1740         ((eobp)
1741          (error "No message at point"))
1742         (t (let ((region (mh-thread-find-children)))
1743              (mh-iterate-on-messages-in-region () (car region) (cadr region)
1744                (mh-refile-a-msg nil folder))
1745              (mh-next-msg)))))
1746
1747 \f
1748
1749 ;; Tick mark handling
1750
1751 ;;;###mh-autoload
1752 (defun mh-toggle-tick (range)
1753   "Toggle tick mark of RANGE.
1754
1755 This command adds messages to the \"tick\" sequence (which you can customize
1756 via the option `mh-tick-seq'). This sequence can be viewed later with the
1757 \\[mh-index-ticked-messages] command.
1758
1759 Check the documentation of `mh-interactive-range' to see how RANGE is read in
1760 interactive use."
1761   (interactive (list (mh-interactive-range "Tick")))
1762   (unless mh-tick-seq
1763     (error "Enable ticking by customizing `mh-tick-seq'"))
1764   (let* ((tick-seq (mh-find-seq mh-tick-seq))
1765          (tick-seq-msgs (mh-seq-msgs tick-seq))
1766          (ticked ())
1767          (unticked ()))
1768     (mh-iterate-on-range msg range
1769       (cond ((member msg tick-seq-msgs)
1770              (push msg unticked)
1771              (setcdr tick-seq (delq msg (cdr tick-seq)))
1772              (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))
1773              (mh-remove-sequence-notation msg (mh-colors-in-use-p)))
1774             (t
1775              (push msg ticked)
1776              (setq mh-last-seq-used mh-tick-seq)
1777              (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list)))
1778                (mh-add-sequence-notation msg (mh-colors-in-use-p))))))
1779     (mh-add-msgs-to-seq ticked mh-tick-seq nil t)
1780     (mh-undefine-sequence mh-tick-seq unticked)
1781     (when mh-index-data
1782       (mh-index-add-to-sequence mh-tick-seq ticked)
1783       (mh-index-delete-from-sequence mh-tick-seq unticked))))
1784
1785 ;;;###mh-autoload
1786 (defun mh-narrow-to-tick ()
1787   "Limit to ticked messages.
1788
1789 What this command does is show only those messages that are in
1790 the \"tick\" sequence (which you can customize via the
1791 `mh-tick-seq' option) in the MH-Folder buffer. In addition, it
1792 limits further MH-E searches to just those messages. When you
1793 want to widen the view to all your messages again, use
1794 \\[mh-widen]."
1795   (interactive)
1796   (cond ((not mh-tick-seq)
1797          (error "Enable ticking by customizing `mh-tick-seq'"))
1798         ((null (mh-seq-msgs (mh-find-seq mh-tick-seq)))
1799          (message "No messages in %s sequence" mh-tick-seq))
1800         (t (mh-narrow-to-seq mh-tick-seq))))
1801
1802 (provide 'mh-seq)
1803
1804 ;; Local Variables:
1805 ;; indent-tabs-mode: nil
1806 ;; sentence-end-double-space: nil
1807 ;; End:
1808
1809 ;; arch-tag: 8e952711-01a2-485b-bf21-c9e3ad4de942
1810 ;;; mh-seq.el ends here