lisp/mh-e/mh-seq.el

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