lisp/mh-e/mh-seq.el

   1 ;;; mh-seq.el --- MH-E sequences support
   2
   3 ;; Copyright (C) 1993, 1995, 2001-2013 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 3 of the License, or
  15 ;; (at your option) 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.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; Sequences are stored in the alist `mh-seq-list' in the form:
  28 ;;     ((seq-name msgs ...) (seq-name msgs ...) ...)
  29
  30 ;;; Change Log:
  31
  32 ;;; Code:
  33
  34 (require 'mh-e)
  35 (mh-require-cl)
  36 (require 'mh-scan)
  37
  38 (require 'font-lock)
  39
  40 ;;; Variables
  41
  42 (defvar mh-last-seq-used nil
  43   "Name of seq to which a msg was last added.")
  44
  45 (defvar mh-non-seq-mode-line-annotation nil
  46   "Saved value of `mh-mode-line-annotation' when narrowed to a seq.")
  47 (make-variable-buffer-local 'mh-non-seq-mode-line-annotation)
  48
  49 (defvar mh-internal-seqs '(answered cur deleted forwarded printed))
  50
  51 ;;; Macros
  52
  53 (defsubst mh-make-seq (name msgs)
  54   "Create sequence NAME with the given MSGS."
  55   (cons name msgs))
  56
  57 (defsubst mh-seq-name (sequence)
  58   "Extract sequence name from the given SEQUENCE."
  59   (car sequence))
  60
  61 \f
  62
  63 ;;; MH-Folder Commands
  64
  65 ;; Alphabetical.
  66
  67 ;;;###mh-autoload
  68 (defun mh-catchup (range)
  69   "Delete RANGE from the \"unseen\" sequence.
  70
  71 Check the documentation of `mh-interactive-range' to see how
  72 RANGE is read in interactive use."
  73   (interactive (list (mh-interactive-range "Catchup"
  74                                            (cons (point-min) (point-max)))))
  75   (mh-delete-msg-from-seq range mh-unseen-seq))
  76
  77 ;;;###mh-autoload
  78 (defun mh-delete-msg-from-seq (range sequence &optional internal-flag)
  79   "Delete RANGE from SEQUENCE.
  80
  81 Check the documentation of `mh-interactive-range' to see how
  82 RANGE is read in interactive use.
  83
  84 In a program, non-nil INTERNAL-FLAG means do not inform MH of the
  85 change."
  86   (interactive (list (mh-interactive-range "Delete")
  87                      (mh-read-seq-default "Delete from" t)
  88                      nil))
  89   (let ((entry (mh-find-seq sequence))
  90         (user-sequence-flag (not (mh-internal-seq sequence)))
  91         (folders-changed (list mh-current-folder))
  92         (msg-list ()))
  93     (when entry
  94       (mh-iterate-on-range msg range
  95         (push msg msg-list)
  96         ;; Calling "mark" repeatedly takes too long. So we will pretend here
  97         ;; that we are just modifying an internal sequence...
  98         (when (memq msg (cdr entry))
  99           (mh-remove-sequence-notation msg (not user-sequence-flag)))
 100         (mh-delete-a-msg-from-seq msg sequence t))
 101       ;; ... and here we will "mark" all the messages at one go.
 102       (unless internal-flag (mh-undefine-sequence sequence msg-list))
 103       (when (and mh-index-data (not internal-flag))
 104         (setq folders-changed
 105               (append folders-changed
 106                       (mh-index-delete-from-sequence sequence msg-list))))
 107       (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
 108         (apply #'mh-speed-flists t folders-changed)))))
 109
 110 ;;;###mh-autoload
 111 (defun mh-delete-seq (sequence)
 112   "Delete SEQUENCE.
 113
 114 You are prompted for the sequence to delete. Note that this
 115 deletes only the sequence, not the messages in the sequence. If
 116 you want to delete the messages, use \"\\[universal-argument]
 117 \\[mh-delete-msg]\"."
 118   (interactive (list (mh-read-seq-default "Delete" t)))
 119   (let ((msg-list (mh-seq-to-msgs sequence))
 120         (internal-flag (mh-internal-seq sequence))
 121         (folders-changed (list mh-current-folder)))
 122     (mh-iterate-on-range msg sequence
 123       (mh-remove-sequence-notation msg internal-flag))
 124     (mh-undefine-sequence sequence '("all"))
 125     (mh-delete-seq-locally sequence)
 126     (when mh-index-data
 127       (setq folders-changed
 128             (append folders-changed
 129                     (mh-index-delete-from-sequence sequence msg-list))))
 130     (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
 131       (apply #'mh-speed-flists t folders-changed))))
 132
 133 ;; Shush compiler.
 134 (defvar view-exit-action)
 135
 136 ;;;###mh-autoload
 137 (defun mh-list-sequences ()
 138   "List all sequences in folder.
 139
 140 The list appears in a buffer named \"*MH-E Sequences*\"."
 141   (interactive)
 142   (let ((folder mh-current-folder)
 143         (temp-buffer mh-sequences-buffer)
 144         (seq-list mh-seq-list)
 145         (max-len 0))
 146     (with-output-to-temp-buffer temp-buffer
 147       (with-current-buffer temp-buffer
 148         (erase-buffer)
 149         (message "Listing sequences ...")
 150         (insert "Sequences in folder " folder ":\n")
 151         (let ((seq-list seq-list))
 152           (while seq-list
 153             (setq max-len
 154                   (max (length (symbol-name (mh-seq-name (pop seq-list))))
 155                        max-len)))
 156           (setq max-len (+ 2 max-len)))
 157         (while seq-list
 158           (let ((name (mh-seq-name (car seq-list)))
 159                 (sorted-seq-msgs
 160                  (mh-coalesce-msg-list
 161                   (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<)))
 162                 name-spec)
 163             (insert (setq name-spec (format (format "%%%ss:" max-len) name)))
 164             (while sorted-seq-msgs
 165               (let ((next-element (format " %s" (pop sorted-seq-msgs))))
 166                 (when (>= (+ (current-column) (length next-element))
 167                           (window-width))
 168                   (insert "\n")
 169                   (insert (format (format "%%%ss" (length name-spec)) "")))
 170                 (insert next-element)))
 171             (insert "\n"))
 172           (setq seq-list (cdr seq-list)))
 173         (goto-char (point-min))
 174         (mh-view-mode-enter)
 175         (setq view-exit-action 'kill-buffer)
 176         (message "Listing sequences...done")))))
 177
 178 ;;;###mh-autoload
 179 (defun mh-msg-is-in-seq (message)
 180   "Display the sequences in which the current message appears.
 181
 182 Use a prefix argument to display the sequences in which another
 183 MESSAGE appears."
 184   (interactive "P")
 185   (if (not message)
 186       (setq message (mh-get-msg-num t)))
 187   (let* ((dest-folder (loop for seq in mh-refile-list
 188                             when (member message (cdr seq)) return (car seq)
 189                             finally return nil))
 190          (deleted-flag (unless dest-folder (member message mh-delete-list))))
 191     (message "Message %d%s is in sequences: %s"
 192              message
 193              (cond (dest-folder (format " (to be refiled to %s)" dest-folder))
 194                    (deleted-flag (format " (to be deleted)"))
 195                    (t ""))
 196              (mapconcat 'concat
 197                         (mh-list-to-string (mh-seq-containing-msg message t))
 198                         " "))))
 199
 200 ;; Shush compiler.
 201 (mh-do-in-xemacs
 202   (defvar tool-bar-mode))
 203 (defvar tool-bar-map)
 204
 205 ;;;###mh-autoload
 206 (defun mh-narrow-to-seq (sequence)
 207   "Restrict display to messages in SEQUENCE.
 208
 209 You are prompted for the name of the sequence. What this command
 210 does is show only those messages that are in the selected
 211 sequence in the MH-Folder buffer. In addition, it limits further
 212 MH-E searches to just those messages.
 213
 214 When you want to widen the view to all your messages again, use
 215 \\[mh-widen]."
 216   (interactive (list (mh-read-seq "Narrow to" t)))
 217   (with-mh-folder-updating (t)
 218     (cond ((mh-seq-to-msgs sequence)
 219            (mh-remove-all-notation)
 220            (let ((eob (point-max))
 221                  (msg-at-cursor (mh-get-msg-num nil)))
 222              (push mh-thread-scan-line-map mh-thread-scan-line-map-stack)
 223              (setq mh-thread-scan-line-map (make-hash-table :test #'eql))
 224              (mh-copy-seq-to-eob sequence)
 225              (push (buffer-substring-no-properties (point-min) eob)
 226                    mh-folder-view-stack)
 227              (delete-region (point-min) eob)
 228              (mh-notate-deleted-and-refiled)
 229              (mh-notate-cur)
 230              (when msg-at-cursor (mh-goto-msg msg-at-cursor t t))
 231              (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation)
 232              (setq mh-mode-line-annotation (symbol-name sequence))
 233              (mh-make-folder-mode-line)
 234              (mh-recenter nil)
 235              (when (and (boundp 'tool-bar-mode) tool-bar-mode)
 236                (set (make-local-variable 'tool-bar-map)
 237                     mh-folder-seq-tool-bar-map)
 238                (when (buffer-live-p (get-buffer mh-show-buffer))
 239                  (with-current-buffer mh-show-buffer
 240                    (set (make-local-variable 'tool-bar-map)
 241                         mh-show-seq-tool-bar-map))))
 242              (push 'widen mh-view-ops)))
 243           (t
 244            (error "No messages in sequence %s" (symbol-name sequence))))))
 245
 246 ;;;###mh-autoload
 247 (defun mh-narrow-to-tick ()
 248   "Limit to ticked messages.
 249
 250 What this command does is show only those messages that are in
 251 the \"tick\" sequence (which you can customize via the
 252 `mh-tick-seq' option) in the MH-Folder buffer. In addition, it
 253 limits further MH-E searches to just those messages. When you
 254 want to widen the view to all your messages again, use
 255 \\[mh-widen]."
 256   (interactive)
 257   (cond ((not mh-tick-seq)
 258          (error "Enable ticking by customizing `mh-tick-seq'"))
 259         ((null (mh-seq-msgs (mh-find-seq mh-tick-seq)))
 260          (message "No messages in %s sequence" mh-tick-seq))
 261         (t (mh-narrow-to-seq mh-tick-seq))))
 262
 263 ;;;###mh-autoload
 264 (defun mh-put-msg-in-seq (range sequence)
 265   "Add RANGE to SEQUENCE\\<mh-folder-mode-map>.
 266
 267 Give this command a RANGE and you can add all the messages in a
 268 sequence to another sequence (for example,
 269 \"\\[universal-argument] \\[mh-put-msg-in-seq] SourceSequence RET
 270 DestSequence RET\"). Check the documentation of
 271 `mh-interactive-range' to see how RANGE is read in interactive
 272 use."
 273   (interactive (list (mh-interactive-range "Add messages from")
 274                      (mh-read-seq-default "Add to" nil)))
 275   (unless (mh-valid-seq-p sequence)
 276     (error "Can't put message in invalid sequence %s" sequence))
 277   (let* ((internal-seq-flag (mh-internal-seq sequence))
 278          (original-msgs (mh-seq-msgs (mh-find-seq sequence)))
 279          (folders (list mh-current-folder))
 280          (msg-list (mh-range-to-msg-list range)))
 281     (mh-add-msgs-to-seq msg-list sequence nil t)
 282     (mh-iterate-on-range m range
 283       (unless (memq m original-msgs)
 284         (mh-add-sequence-notation m internal-seq-flag)))
 285     (if (not internal-seq-flag)
 286         (setq mh-last-seq-used sequence))
 287     (when mh-index-data
 288       (setq folders
 289             (append folders (mh-index-add-to-sequence sequence msg-list))))
 290     (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
 291       (apply #'mh-speed-flists t folders))))
 292
 293 ;;;###mh-autoload
 294 (defun mh-toggle-tick (range)
 295   "Toggle tick mark of RANGE.
 296
 297 This command adds messages to the \"tick\" sequence (which you can customize
 298 via the option `mh-tick-seq'). This sequence can be viewed later with the
 299 \\[mh-index-ticked-messages] command.
 300
 301 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 302 interactive use."
 303   (interactive (list (mh-interactive-range "Tick")))
 304   (unless mh-tick-seq
 305     (error "Enable ticking by customizing `mh-tick-seq'"))
 306   (let* ((tick-seq (mh-find-seq mh-tick-seq))
 307          (tick-seq-msgs (mh-seq-msgs tick-seq))
 308          (ticked ())
 309          (unticked ()))
 310     (mh-iterate-on-range msg range
 311       (cond ((member msg tick-seq-msgs)
 312              (push msg unticked)
 313              (setcdr tick-seq (delq msg (cdr tick-seq)))
 314              (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))
 315              (mh-remove-sequence-notation msg (mh-colors-in-use-p)))
 316             (t
 317              (push msg ticked)
 318              (setq mh-last-seq-used mh-tick-seq)
 319              (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list)))
 320                (mh-add-sequence-notation msg (mh-colors-in-use-p))))))
 321     (mh-add-msgs-to-seq ticked mh-tick-seq nil t)
 322     (mh-undefine-sequence mh-tick-seq unticked)
 323     (when mh-index-data
 324       (mh-index-add-to-sequence mh-tick-seq ticked)
 325       (mh-index-delete-from-sequence mh-tick-seq unticked))))
 326
 327 ;;;###mh-autoload
 328 (defun mh-widen (&optional all-flag)
 329   "Remove last restriction.
 330
 331 Each limit or sequence restriction can be undone in turn with
 332 this command. Give this command a prefix argument ALL-FLAG to
 333 remove all limits and sequence restrictions."
 334   (interactive "P")
 335   (let ((msg (mh-get-msg-num nil)))
 336     (when mh-folder-view-stack
 337       (cond (all-flag
 338              (while (cdr mh-view-ops)
 339                (setq mh-view-ops (cdr mh-view-ops)))
 340              (when (eq (car mh-view-ops) 'widen)
 341                (setq mh-view-ops (cdr mh-view-ops))))
 342             ((mh-valid-view-change-operation-p 'widen) nil)
 343             ((memq 'widen mh-view-ops)
 344              (while (not (eq (car mh-view-ops) 'widen))
 345                (setq mh-view-ops (cdr mh-view-ops)))
 346              (setq mh-view-ops (cdr mh-view-ops)))
 347             (t (error "Widening is not applicable")))
 348       ;; If ALL-FLAG is non-nil then rewind stacks
 349       (when all-flag
 350         (while (cdr mh-thread-scan-line-map-stack)
 351           (setq mh-thread-scan-line-map-stack
 352                 (cdr mh-thread-scan-line-map-stack)))
 353         (while (cdr mh-folder-view-stack)
 354           (setq mh-folder-view-stack (cdr mh-folder-view-stack))))
 355       (setq mh-thread-scan-line-map (pop mh-thread-scan-line-map-stack))
 356       (with-mh-folder-updating (t)
 357         (delete-region (point-min) (point-max))
 358         (insert (pop mh-folder-view-stack))
 359         (mh-remove-all-notation)
 360         (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation)
 361         (mh-make-folder-mode-line))
 362       (if msg
 363           (mh-goto-msg msg t t))
 364       (mh-notate-deleted-and-refiled)
 365       (mh-notate-user-sequences)
 366       (mh-notate-cur)
 367       (mh-recenter nil)))
 368   (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode)
 369     (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)
 370     (when (buffer-live-p (get-buffer mh-show-buffer))
 371       (with-current-buffer mh-show-buffer
 372         (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)))))
 373
 374 \f
 375
 376 ;;; Support Routines
 377
 378 (defvar mh-sequence-history ())
 379
 380 ;;;###mh-autoload
 381 (defun mh-read-seq-default (prompt not-empty)
 382   "Read and return sequence name with default narrowed or previous sequence.
 383 PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil
 384 then a non-empty sequence is read."
 385   (mh-read-seq prompt not-empty
 386                (or mh-last-seq-used
 387                    (car (mh-seq-containing-msg (mh-get-msg-num nil) nil)))))
 388
 389 (defun mh-read-seq (prompt not-empty &optional default)
 390   "Read and return a sequence name.
 391 Prompt with PROMPT, raise an error if the sequence is empty and
 392 the NOT-EMPTY flag is non-nil, and supply an optional DEFAULT
 393 sequence. A reply of '%' defaults to the first sequence
 394 containing the current message."
 395   (let* ((input (completing-read (format "%s sequence%s: " prompt
 396                                          (if default
 397                                              (format " (default %s)" default)
 398                                            ""))
 399                                  (mh-seq-names mh-seq-list)
 400                                  nil nil nil 'mh-sequence-history))
 401          (seq (cond ((equal input "%")
 402                      (car (mh-seq-containing-msg (mh-get-msg-num t) nil)))
 403                     ((equal input "") default)
 404                     (t (intern input))))
 405          (msgs (mh-seq-to-msgs seq)))
 406     (if (and (null msgs) not-empty)
 407         (error "No messages in sequence %s" seq))
 408     seq))
 409
 410 (defun mh-internal-seq (name)
 411   "Return non-nil if NAME is the name of an internal MH-E sequence."
 412   (or (memq name mh-internal-seqs)
 413       (eq name mh-unseen-seq)
 414       (and (mh-colors-in-use-p) mh-tick-seq (eq name mh-tick-seq))
 415       (eq name mh-previous-seq)
 416       (mh-folder-name-p name)))
 417
 418 ;;;###mh-autoload
 419 (defun mh-valid-seq-p (name)
 420   "Return non-nil if NAME is a valid MH sequence name."
 421   (and (symbolp name)
 422        (string-match "^[a-zA-Z][a-zA-Z0-9]*$" (symbol-name name))))
 423
 424 ;;;###mh-autoload
 425 (defun mh-find-seq (name)
 426   "Return sequence NAME."
 427   (assoc name mh-seq-list))
 428
 429 ;;;###mh-autoload
 430 (defun mh-seq-to-msgs (seq)
 431   "Return a list of the messages in SEQ."
 432   (mh-seq-msgs (mh-find-seq seq)))
 433
 434 (defun mh-seq-containing-msg (msg &optional include-internal-flag)
 435   "Return a list of the sequences containing MSG.
 436 If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences
 437 in list."
 438   (let ((l mh-seq-list)
 439         (seqs ()))
 440     (while l
 441       (and (memq msg (mh-seq-msgs (car l)))
 442            (or include-internal-flag
 443                (not (mh-internal-seq (mh-seq-name (car l)))))
 444            (setq seqs (cons (mh-seq-name (car l)) seqs)))
 445       (setq l (cdr l)))
 446     seqs))
 447
 448 ;;;###mh-autoload
 449 (defun mh-define-sequence (seq msgs)
 450   "Define the SEQ to contain the list of MSGS.
 451 Do not mark pseudo-sequences or empty sequences.
 452 Signals an error if SEQ is an invalid name."
 453   (if (and msgs
 454            (mh-valid-seq-p seq)
 455            (not (mh-folder-name-p seq)))
 456       (save-excursion
 457         (mh-exec-cmd-error nil "mark" mh-current-folder "-add" "-zero"
 458                            "-sequence" (symbol-name seq)
 459                            (mh-coalesce-msg-list msgs)))))
 460
 461 ;;;###mh-autoload
 462 (defun mh-undefine-sequence (seq msgs)
 463   "Remove from the SEQ the list of MSGS."
 464   (when (and (mh-valid-seq-p seq) msgs)
 465     (apply #'mh-exec-cmd "mark" mh-current-folder "-delete"
 466            "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs))))
 467
 468 ;;;###mh-autoload
 469 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag)
 470   "Add MSGS to SEQ.
 471
 472 Remove duplicates and keep sequence sorted. If optional
 473 INTERNAL-FLAG is non-nil, do not mark the message in the scan
 474 listing or inform MH of the addition.
 475
 476 If DONT-ANNOTATE-FLAG is non-nil then the annotations in the
 477 folder buffer are not updated."
 478   (let ((entry (mh-find-seq seq))
 479         (internal-seq-flag (mh-internal-seq seq)))
 480     (if (and msgs (atom msgs)) (setq msgs (list msgs)))
 481     (if (null entry)
 482         (setq mh-seq-list
 483               (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))
 484                     mh-seq-list))
 485       (if msgs (setcdr entry (mh-canonicalize-sequence
 486                               (append msgs (mh-seq-msgs entry))))))
 487     (unless internal-flag
 488       (mh-add-to-sequence seq msgs)
 489       (when (not dont-annotate-flag)
 490         (mh-iterate-on-range msg msgs
 491           (unless (memq msg (cdr entry))
 492             (mh-add-sequence-notation msg internal-seq-flag)))))))
 493
 494 (defun mh-add-to-sequence (seq msgs)
 495   "The sequence SEQ is augmented with the messages in MSGS."
 496   ;; Add to a SEQUENCE each message the list of MSGS.
 497   (if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq)))
 498       (if msgs
 499           (apply 'mh-exec-cmd "mark" mh-current-folder "-add"
 500                  "-sequence" (symbol-name seq)
 501                  (mh-coalesce-msg-list msgs)))))
 502
 503 (defun mh-canonicalize-sequence (msgs)
 504   "Sort MSGS in decreasing order and remove duplicates."
 505   (let* ((sorted-msgs (sort (copy-sequence msgs) '>))
 506          (head sorted-msgs))
 507     (while (cdr head)
 508       (if (= (car head) (cadr head))
 509           (setcdr head (cddr head))
 510         (setq head (cdr head))))
 511     sorted-msgs))
 512
 513 (defun mh-delete-a-msg-from-seq (msg sequence internal-flag)
 514   "Delete MSG from SEQUENCE.
 515 If INTERNAL-FLAG is non-nil, then do not inform MH of the
 516 change."
 517   (let ((entry (mh-find-seq sequence)))
 518     (when (and entry (memq msg (mh-seq-msgs entry)))
 519       (if (not internal-flag)
 520           (mh-undefine-sequence sequence (list msg)))
 521       (setcdr entry (delq msg (mh-seq-msgs entry))))))
 522
 523 (defun mh-delete-seq-locally (seq)
 524   "Remove MH-E's record of SEQ."
 525   (let ((entry (mh-find-seq seq)))
 526     (setq mh-seq-list (delq entry mh-seq-list))))
 527
 528 (defun mh-copy-seq-to-eob (seq)
 529   "Copy SEQ to the end of the buffer."
 530   ;; It is quite involved to write something which will work at any place in
 531   ;; the buffer, so we will write something which works only at the end of
 532   ;; the buffer. If we ever need to insert sequences in the middle of the
 533   ;; buffer, this will need to be fixed.
 534   (save-excursion
 535     (let* ((msgs (mh-seq-to-msgs seq))
 536            (coalesced-msgs (mh-coalesce-msg-list msgs)))
 537       (goto-char (point-max))
 538       (save-restriction
 539         (narrow-to-region (point) (point))
 540         (mh-regenerate-headers coalesced-msgs t)
 541         (cond ((memq 'unthread mh-view-ops)
 542                ;; Populate restricted scan-line map
 543                (mh-remove-all-notation)
 544                (mh-iterate-on-range msg (cons (point-min) (point-max))
 545                  (setf (gethash msg mh-thread-scan-line-map)
 546                        (mh-thread-parse-scan-line)))
 547                ;; Remove scan lines and read results from pre-computed tree
 548                (delete-region (point-min) (point-max))
 549                (mh-thread-print-scan-lines
 550                 (mh-thread-generate mh-current-folder ()))
 551                (mh-notate-user-sequences))
 552               (mh-index-data
 553                (mh-index-insert-folder-headers)))))))
 554
 555 ;;;###mh-autoload
 556 (defun mh-valid-view-change-operation-p (op)
 557   "Check if the view change operation can be performed.
 558 OP is one of 'widen and 'unthread."
 559   (cond ((eq (car mh-view-ops) op)
 560          (pop mh-view-ops))
 561         (t nil)))
 562
 563 \f
 564
 565 ;;; Ranges
 566
 567 (defvar mh-range-seq-names)
 568 (defvar mh-range-history ())
 569 (defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map))
 570 (define-key mh-range-completion-map " " 'self-insert-command)
 571
 572 ;;;###mh-autoload
 573 (defun mh-interactive-range (range-prompt &optional default)
 574   "Return interactive specification for message, sequence, range or region.
 575 By convention, the name of this argument is RANGE.
 576
 577 If variable `transient-mark-mode' is non-nil and the mark is active,
 578 then this function returns a cons-cell of the region.
 579
 580 If optional prefix argument is provided, then prompt for message range
 581 with RANGE-PROMPT. A list of messages in that range is returned.
 582
 583 If a MH range is given, say something like last:20, then a list
 584 containing the messages in that range is returned.
 585
 586 If DEFAULT non-nil then it is returned.
 587
 588 Otherwise, the message number at point is returned.
 589
 590 This function is usually used with `mh-iterate-on-range' in order to
 591 provide a uniform interface to MH-E functions."
 592   (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))
 593         (current-prefix-arg (mh-read-range range-prompt nil nil t t))
 594         (default default)
 595         (t (mh-get-msg-num t))))
 596
 597 ;;;###mh-autoload
 598 (defun mh-read-range (prompt &optional folder default
 599                              expand-flag ask-flag number-as-range-flag)
 600   "Read a message range with PROMPT.
 601
 602 If FOLDER is non-nil then a range is read from that folder, otherwise
 603 use `mh-current-folder'.
 604
 605 If DEFAULT is a string then use that as default range to return. If
 606 DEFAULT is nil then ask user with default answer a range based on the
 607 sequences that seem relevant. Finally if DEFAULT is t, try to avoid
 608 prompting the user. Unseen messages, if present, are returned. If the
 609 folder has fewer than `mh-large-folder' messages then \"all\" messages
 610 are returned. Finally as a last resort prompt the user.
 611
 612 If EXPAND-FLAG is non-nil then a list of message numbers corresponding
 613 to the input is returned. If this list is empty then an error is
 614 raised. If EXPAND-FLAG is nil just return the input string. In this
 615 case we don't check if the range is empty.
 616
 617 If ASK-FLAG is non-nil, then the user is always queried for a range of
 618 messages. If ASK-FLAG is nil, then the function checks if the unseen
 619 sequence is non-empty. If that is the case, `mh-unseen-seq', or the
 620 list of messages in it depending on the value of EXPAND, is returned.
 621 Otherwise if the folder has fewer than `mh-large-folder' messages then
 622 the list of messages corresponding to \"all\" is returned. If neither
 623 of the above holds then as a last resort the user is queried for a
 624 range of messages.
 625
 626 If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as
 627 input, it is interpreted as the range \"last:N\".
 628
 629 This function replaces the existing function `mh-read-msg-range'.
 630 Calls to:
 631
 632   (mh-read-msg-range folder flag)
 633
 634 should be replaced with:
 635
 636   (mh-read-range \"Suitable prompt\" folder t nil flag
 637                  mh-interpret-number-as-range-flag)"
 638   (setq default (or default mh-last-seq-used
 639                     (car (mh-seq-containing-msg (mh-get-msg-num nil) t)))
 640         prompt (format "%s range" prompt))
 641   (let* ((folder (or folder mh-current-folder))
 642          (guess (eq default t))
 643          (counts (and guess (mh-folder-size folder)))
 644          (unseen (and counts (> (cadr counts) 0)))
 645          (large (and counts mh-large-folder (> (car counts) mh-large-folder)))
 646          (default (cond ((and guess large) (format "last:%s" mh-large-folder))
 647                         ((and guess (not large)) "all")
 648                         ((stringp default) default)
 649                         ((symbolp default) (symbol-name default))))
 650          (prompt (cond ((and guess large default)
 651                         (format "%s (folder has %s messages, default %s)"
 652                                 prompt (car counts) default))
 653                        ((and guess large)
 654                         (format "%s (folder has %s messages)"
 655                                 prompt (car counts)))
 656                        (default
 657                          (format "%s (default %s)" prompt default))))
 658          (minibuffer-local-completion-map mh-range-completion-map)
 659          (seq-list (if (eq folder mh-current-folder)
 660                        mh-seq-list
 661                      (mh-read-folder-sequences folder nil)))
 662          (mh-range-seq-names
 663           (append '(("first") ("last") ("all") ("prev") ("next"))
 664                   (mh-seq-names seq-list)))
 665          (input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq))
 666                       ((and (not ask-flag) (not large)) "all")
 667                       (t (completing-read (format "%s: " prompt)
 668                                           'mh-range-completion-function nil nil
 669                                           nil 'mh-range-history default))))
 670          msg-list)
 671     (when (and number-as-range-flag
 672                (string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input))
 673       (setq input (concat "last:" (match-string 1 input))))
 674     (cond ((not expand-flag) input)
 675           ((assoc (intern input) seq-list)
 676            (cdr (assoc (intern input) seq-list)))
 677           ((setq msg-list (mh-translate-range folder input)) msg-list)
 678           (t (error "No messages in range %s" input)))))
 679
 680 ;;;###mh-autoload
 681 (defun mh-range-to-msg-list (range)
 682   "Return a list of messages for RANGE.
 683
 684 Check the documentation of `mh-interactive-range' to see how
 685 RANGE is read in interactive use."
 686   (let (msg-list)
 687     (mh-iterate-on-range msg range
 688       (push msg msg-list))
 689     (nreverse msg-list)))
 690
 691 ;;;###mh-autoload
 692 (defun mh-translate-range (folder expr)
 693   "In FOLDER, translate the string EXPR to a list of messages numbers."
 694   (save-excursion
 695     (let ((strings (delete "" (split-string expr "[ \t\n]")))
 696           (result ()))
 697       (ignore-errors
 698         (apply #'mh-exec-cmd-quiet nil "mhpath" folder strings)
 699         (set-buffer mh-temp-buffer)
 700         (goto-char (point-min))
 701         (while (re-search-forward "/\\([0-9]*\\)$" nil t)
 702           (push (string-to-number (match-string 1)) result))
 703         (nreverse result)))))
 704
 705 (defun mh-range-completion-function (string predicate flag)
 706   "Programmable completion of message ranges.
 707 STRING is the user input that is to be completed. PREDICATE if non-nil is a
 708 function used to filter the possible choices and FLAG determines whether the
 709 completion is over."
 710   (let* ((candidates mh-range-seq-names)
 711          (last-char (and (not (equal string ""))
 712                          (aref string (1- (length string)))))
 713          (last-word (cond ((null last-char) "")
 714                           ((memq last-char '(?  ?- ?:)) "")
 715                           (t (car (last (split-string string "[ -:]+"))))))
 716          (prefix (substring string 0 (- (length string) (length last-word)))))
 717     (cond ((eq flag nil)
 718            (let ((res (try-completion last-word candidates predicate)))
 719              (cond ((null res) nil)
 720                    ((eq res t) t)
 721                    (t (concat prefix res)))))
 722           ((eq flag t)
 723            (all-completions last-word candidates predicate))
 724           ((eq flag 'lambda)
 725            (loop for x in candidates
 726                  when (equal x last-word) return t
 727                  finally return nil)))))
 728
 729 (defun mh-seq-names (seq-list)
 730   "Return an alist containing the names of the SEQ-LIST."
 731   (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry))))
 732           seq-list))
 733
 734 (defun mh-folder-size (folder)
 735   "Find size of FOLDER."
 736   (if mh-flists-present-flag
 737       (mh-folder-size-flist folder)
 738     (mh-folder-size-folder folder)))
 739
 740 (defun mh-folder-size-flist (folder)
 741   "Find size of FOLDER using \"flist\"."
 742   (with-temp-buffer
 743     (call-process (expand-file-name "flist" mh-progs) nil t nil "-showzero"
 744                   "-norecurse" folder "-sequence" (symbol-name mh-unseen-seq))
 745     (goto-char (point-min))
 746     (multiple-value-bind (folder unseen total)
 747         (values-list
 748          (mh-parse-flist-output-line
 749           (buffer-substring (point) (mh-line-end-position))))
 750       (list total unseen folder))))
 751
 752 (defun mh-folder-size-folder (folder)
 753   "Find size of FOLDER using \"folder\"."
 754   (with-temp-buffer
 755     (let ((u (length (cdr (assoc mh-unseen-seq
 756                                  (mh-read-folder-sequences folder nil))))))
 757       (call-process (expand-file-name "folder" mh-progs) nil t nil
 758                     "-norecurse" folder)
 759       (goto-char (point-min))
 760       (if (re-search-forward " has \\([0-9]+\\) " nil t)
 761           (list (string-to-number (match-string 1)) u folder)
 762         (list 0 u folder)))))
 763
 764 ;;;###mh-autoload
 765 (defun mh-parse-flist-output-line (line &optional current-folder)
 766   "Parse LINE to generate folder name, unseen messages and total messages.
 767 If CURRENT-FOLDER is non-nil then it contains the current folder
 768 name and it is used to avoid problems in corner cases involving
 769 folders whose names end with a '+' character."
 770   (with-temp-buffer
 771     (insert line)
 772     (goto-char (point-max))
 773     (let (folder unseen total p)
 774       (when (search-backward " out of " (point-min) t)
 775         (setq total (string-to-number
 776                      (buffer-substring-no-properties
 777                       (match-end 0) (mh-line-end-position))))
 778         (when (search-backward " in sequence " (point-min) t)
 779           (setq p (point))
 780           (when (search-backward " has " (point-min) t)
 781             (setq unseen (string-to-number (buffer-substring-no-properties
 782                                             (match-end 0) p)))
 783             (while (eq (char-after) ? )
 784               (backward-char))
 785             (setq folder (buffer-substring-no-properties
 786                           (point-min) (1+ (point))))
 787             (when (and (equal (aref folder (1- (length folder))) ?+)
 788                        (equal current-folder folder))
 789               (setq folder (substring folder 0 (1- (length folder)))))
 790             (list (format "+%s" folder) unseen total)))))))
 791
 792 ;;;###mh-autoload
 793 (defun mh-read-folder-sequences (folder save-refiles)
 794   "Read and return the predefined sequences for a FOLDER.
 795 If SAVE-REFILES is non-nil, then keep the sequences
 796 that note messages to be refiled."
 797   (let ((seqs ()))
 798     (cond (save-refiles
 799            (mh-mapc (function (lambda (seq) ; Save the refiling sequences
 800                                 (if (mh-folder-name-p (mh-seq-name seq))
 801                                     (setq seqs (cons seq seqs)))))
 802                     mh-seq-list)))
 803     (save-excursion
 804       (if (eq 0 (mh-exec-cmd-quiet nil "mark" folder "-list"))
 805           (progn
 806             ;; look for name in line of form "cur: 4" or "myseq (private): 23"
 807             (while (re-search-forward "^[^: ]+" nil t)
 808               (setq seqs (cons (mh-make-seq (intern (buffer-substring
 809                                                      (match-beginning 0)
 810                                                      (match-end 0)))
 811                                             (mh-read-msg-list))
 812                                seqs)))
 813             (delete-region (point-min) (point))))) ; avoid race with
 814                                         ; mh-process-daemon
 815     seqs))
 816
 817 (defun mh-read-msg-list ()
 818   "Return a list of message numbers from point to the end of the line.
 819 Expands ranges into set of individual numbers."
 820   (let ((msgs ())
 821         (end-of-line (point-at-eol))
 822         num)
 823     (while (re-search-forward "[0-9]+" end-of-line t)
 824       (setq num (string-to-number (buffer-substring (match-beginning 0)
 825                                                     (match-end 0))))
 826       (cond ((looking-at "-")           ; Message range
 827              (forward-char 1)
 828              (re-search-forward "[0-9]+" end-of-line t)
 829              (let ((num2 (string-to-number
 830                           (buffer-substring (match-beginning 0)
 831                                             (match-end 0)))))
 832                (if (< num2 num)
 833                    (error "Bad message range: %d-%d" num num2))
 834                (while (<= num num2)
 835                  (setq msgs (cons num msgs))
 836                  (setq num (1+ num)))))
 837             ((not (zerop num))          ;"pick" outputs "0" to mean no match
 838              (setq msgs (cons num msgs)))))
 839     msgs))
 840
 841 \f
 842
 843 ;;; Notation
 844
 845 ;;;###mh-autoload
 846 (defun mh-notate (msg notation offset)
 847   "Mark MSG with the character NOTATION at position OFFSET.
 848 Null MSG means the message at cursor.
 849 If NOTATION is nil then no change in the buffer occurs."
 850   (save-excursion
 851     (if (or (null msg)
 852             (mh-goto-msg msg t t))
 853         (with-mh-folder-updating (t)
 854           (beginning-of-line)
 855           (forward-char offset)
 856           (let* ((change-stack-flag
 857                   (and (equal offset
 858                               (+ mh-cmd-note mh-scan-field-destination-offset))
 859                        (not (eq notation mh-note-seq))))
 860                  (msg (and change-stack-flag (or msg (mh-get-msg-num nil))))
 861                  (stack (and msg (gethash msg mh-sequence-notation-history)))
 862                  (notation (or notation (char-after))))
 863             (if stack
 864                 ;; The presence of the stack tells us that we don't need to
 865                 ;; notate the message, since the notation would be replaced
 866                 ;; by a sequence notation. So we will just put the notation
 867                 ;; at the bottom of the stack. If the sequence is deleted,
 868                 ;; the correct notation will be shown.
 869                 (setf (gethash msg mh-sequence-notation-history)
 870                       (reverse (cons notation (cdr (reverse stack)))))
 871               ;; Since we don't have any sequence notations in the way, just
 872               ;; notate the scan line.
 873               (delete-char 1)
 874               (insert notation))
 875             (when change-stack-flag
 876               (mh-thread-update-scan-line-map msg notation offset)))))))
 877
 878 ;;;###mh-autoload
 879 (defun mh-notate-cur ()
 880   "Mark the MH sequence cur.
 881 In addition to notating the current message with `mh-note-cur'
 882 the function uses `overlay-arrow-position' to put a marker in the
 883 fringe."
 884   (let ((cur (car (mh-seq-to-msgs 'cur))))
 885     (when (and cur (mh-goto-msg cur t t))
 886       (beginning-of-line)
 887       (when (looking-at mh-scan-good-msg-regexp)
 888         (mh-notate nil mh-note-cur mh-cmd-note))
 889       (setq mh-arrow-marker (set-marker mh-arrow-marker (point)))
 890       (setq overlay-arrow-position mh-arrow-marker))))
 891
 892 ;;;###mh-autoload
 893 (defun mh-remove-cur-notation ()
 894   "Remove old cur notation."
 895   (let ((cur-msg (car (mh-seq-to-msgs 'cur))))
 896     (save-excursion
 897       (when (and cur-msg
 898                  (mh-goto-msg cur-msg t t)
 899                  (looking-at mh-scan-cur-msg-number-regexp))
 900         (mh-notate nil ?  mh-cmd-note)
 901         (setq overlay-arrow-position nil)))))
 902
 903 ;; FIXME?  We may want to clear all notations and add one for current-message
 904 ;;         and process user sequences.
 905 ;;;###mh-autoload
 906 (defun mh-notate-deleted-and-refiled ()
 907   "Notate messages marked for deletion or refiling.
 908 Messages to be deleted are given by `mh-delete-list' while
 909 messages to be refiled are present in `mh-refile-list'."
 910   (let ((refiled-hash (make-hash-table))
 911         (deleted-hash (make-hash-table)))
 912     (dolist (msg mh-delete-list)
 913       (setf (gethash msg deleted-hash) t))
 914     (dolist (dest-msg-list mh-refile-list)
 915       (dolist (msg (cdr dest-msg-list))
 916         (setf (gethash msg refiled-hash) t)))
 917     (mh-iterate-on-messages-in-region msg (point-min) (point-max)
 918       (cond ((gethash msg refiled-hash)
 919              (mh-notate nil mh-note-refiled mh-cmd-note))
 920             ((gethash msg deleted-hash)
 921              (mh-notate nil mh-note-deleted mh-cmd-note))))))
 922
 923 ;;;###mh-autoload
 924 (defun mh-notate-user-sequences (&optional range)
 925   "Mark user-defined sequences in RANGE.
 926
 927 Check the documentation of `mh-interactive-range' to see how
 928 RANGE is read in interactive use; if nil all messages are
 929 notated."
 930   (unless range
 931     (setq range (cons (point-min) (point-max))))
 932   (let ((seqs mh-seq-list)
 933         (msg-hash (make-hash-table)))
 934     (dolist (seq seqs)
 935       (dolist (msg (mh-seq-msgs seq))
 936         (push (car seq) (gethash msg msg-hash))))
 937     (mh-iterate-on-range msg range
 938       (loop for seq in (gethash msg msg-hash)
 939             do (mh-add-sequence-notation msg (mh-internal-seq seq))))))
 940
 941 (defun mh-add-sequence-notation (msg internal-seq-flag)
 942   "Add sequence notation to the MSG on the current line.
 943 If INTERNAL-SEQ-FLAG is non-nil, then refontify the scan line if
 944 font-lock is turned on."
 945   (with-mh-folder-updating (t)
 946     (save-excursion
 947       (beginning-of-line)
 948       (if internal-seq-flag
 949           (progn
 950             ;; Change the buffer so that if transient-mark-mode is active
 951             ;; and there is an active region it will get deactivated as in
 952             ;; the case of user sequences.
 953             (mh-notate nil nil mh-cmd-note)
 954             (when font-lock-mode
 955               (font-lock-fontify-region (point) (mh-line-end-position))))
 956         (forward-char (+ mh-cmd-note mh-scan-field-destination-offset))
 957         (let ((stack (gethash msg mh-sequence-notation-history)))
 958           (setf (gethash msg mh-sequence-notation-history)
 959                 (cons (char-after) stack)))
 960         (mh-notate nil mh-note-seq
 961                    (+ mh-cmd-note mh-scan-field-destination-offset))))))
 962
 963 (defun mh-remove-sequence-notation (msg internal-seq-flag &optional all)
 964   "Remove sequence notation from the MSG on the current line.
 965 If INTERNAL-SEQ-FLAG is non-nil, then `font-lock' was used to
 966 highlight the sequence. In that case, no notation needs to be removed.
 967 Otherwise the effect of inserting `mh-note-seq' needs to be reversed.
 968 If ALL is non-nil, then all sequence marks on the scan line are
 969 removed."
 970   (with-mh-folder-updating (t)
 971     ;; This takes care of internal sequences...
 972     (mh-notate nil nil mh-cmd-note)
 973     (unless internal-seq-flag
 974       ;; ... and this takes care of user sequences.
 975       (let ((stack (gethash msg mh-sequence-notation-history)))
 976         (while (and all (cdr stack))
 977           (setq stack (cdr stack)))
 978         (when stack
 979           (save-excursion
 980             (beginning-of-line)
 981             (forward-char (+ mh-cmd-note mh-scan-field-destination-offset))
 982             (delete-char 1)
 983             (insert (car stack))))
 984         (setf (gethash msg mh-sequence-notation-history) (cdr stack))))))
 985
 986 ;;;###mh-autoload
 987 (defun mh-remove-all-notation ()
 988   "Remove all notations on all scan lines that MH-E introduces."
 989   (save-excursion
 990     (setq overlay-arrow-position nil)
 991     (goto-char (point-min))
 992     (mh-iterate-on-range msg (cons (point-min) (point-max))
 993       (mh-notate nil ?  mh-cmd-note)
 994       (mh-remove-sequence-notation msg nil t))
 995     (clrhash mh-sequence-notation-history)))
 996
 997 \f
 998
 999 ;; XXX Unused, delete, or create bind key?
1000 (defun mh-rename-seq (sequence new-name)
1001   "Rename SEQUENCE to have NEW-NAME."
1002   (interactive (list (mh-read-seq "Old" t)
1003                      (intern (read-string "New sequence name: "))))
1004   (let ((old-seq (mh-find-seq sequence)))
1005     (or old-seq
1006         (error "Sequence %s does not exist" sequence))
1007     ;; Create new sequence first, since it might raise an error.
1008     (mh-define-sequence new-name (mh-seq-msgs old-seq))
1009     (mh-undefine-sequence sequence (mh-seq-msgs old-seq))
1010     (rplaca old-seq new-name)))
1011
1012 (provide 'mh-seq)
1013
1014 ;; Local Variables:
1015 ;; indent-tabs-mode: nil
1016 ;; sentence-end-double-space: nil
1017 ;; End:
1018
1019 ;;; mh-seq.el ends here