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

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