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

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