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 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 3, 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 (defsubst mh-make-seq (name msgs)
  57   "Create sequence NAME with the given MSGS."
  58   (cons name msgs))
  59
  60 (defsubst mh-seq-name (sequence)
  61   "Extract sequence name from the given SEQUENCE."
  62   (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 (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         (mh-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 (defvar tool-bar-mode)                  ; XEmacs
 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                  (with-current-buffer mh-show-buffer
 242                    (set (make-local-variable 'tool-bar-map)
 243                         mh-show-seq-tool-bar-map))))
 244              (push 'widen mh-view-ops)))
 245           (t
 246            (error "No messages in sequence %s" (symbol-name sequence))))))
 247
 248 ;;;###mh-autoload
 249 (defun mh-narrow-to-tick ()
 250   "Limit to ticked messages.
 251
 252 What this command does is show only those messages that are in
 253 the \"tick\" sequence (which you can customize via the
 254 `mh-tick-seq' option) in the MH-Folder buffer. In addition, it
 255 limits further MH-E searches to just those messages. When you
 256 want to widen the view to all your messages again, use
 257 \\[mh-widen]."
 258   (interactive)
 259   (cond ((not mh-tick-seq)
 260          (error "Enable ticking by customizing `mh-tick-seq'"))
 261         ((null (mh-seq-msgs (mh-find-seq mh-tick-seq)))
 262          (message "No messages in %s sequence" mh-tick-seq))
 263         (t (mh-narrow-to-seq mh-tick-seq))))
 264
 265 ;;;###mh-autoload
 266 (defun mh-put-msg-in-seq (range sequence)
 267   "Add RANGE to SEQUENCE\\<mh-folder-mode-map>.
 268
 269 Give this command a RANGE and you can add all the messages in a
 270 sequence to another sequence (for example,
 271 \"\\[universal-argument] \\[mh-put-msg-in-seq] SourceSequence RET
 272 DestSequence RET\"). Check the documentation of
 273 `mh-interactive-range' to see how RANGE is read in interactive
 274 use."
 275   (interactive (list (mh-interactive-range "Add messages from")
 276                      (mh-read-seq-default "Add to" nil)))
 277   (unless (mh-valid-seq-p sequence)
 278     (error "Can't put message in invalid sequence %s" sequence))
 279   (let* ((internal-seq-flag (mh-internal-seq sequence))
 280          (original-msgs (mh-seq-msgs (mh-find-seq sequence)))
 281          (folders (list mh-current-folder))
 282          (msg-list (mh-range-to-msg-list range)))
 283     (mh-add-msgs-to-seq msg-list sequence nil t)
 284     (mh-iterate-on-range m range
 285       (unless (memq m original-msgs)
 286         (mh-add-sequence-notation m internal-seq-flag)))
 287     (if (not internal-seq-flag)
 288         (setq mh-last-seq-used sequence))
 289     (when mh-index-data
 290       (setq folders
 291             (append folders (mh-index-add-to-sequence sequence msg-list))))
 292     (when (and (eq sequence mh-unseen-seq) (mh-speed-flists-active-p))
 293       (apply #'mh-speed-flists t folders))))
 294
 295 ;;;###mh-autoload
 296 (defun mh-toggle-tick (range)
 297   "Toggle tick mark of RANGE.
 298
 299 This command adds messages to the \"tick\" sequence (which you can customize
 300 via the option `mh-tick-seq'). This sequence can be viewed later with the
 301 \\[mh-index-ticked-messages] command.
 302
 303 Check the documentation of `mh-interactive-range' to see how RANGE is read in
 304 interactive use."
 305   (interactive (list (mh-interactive-range "Tick")))
 306   (unless mh-tick-seq
 307     (error "Enable ticking by customizing `mh-tick-seq'"))
 308   (let* ((tick-seq (mh-find-seq mh-tick-seq))
 309          (tick-seq-msgs (mh-seq-msgs tick-seq))
 310          (ticked ())
 311          (unticked ()))
 312     (mh-iterate-on-range msg range
 313       (cond ((member msg tick-seq-msgs)
 314              (push msg unticked)
 315              (setcdr tick-seq (delq msg (cdr tick-seq)))
 316              (when (null (cdr tick-seq)) (setq mh-last-seq-used nil))
 317              (mh-remove-sequence-notation msg (mh-colors-in-use-p)))
 318             (t
 319              (push msg ticked)
 320              (setq mh-last-seq-used mh-tick-seq)
 321              (let ((mh-seq-list (cons `(,mh-tick-seq ,msg) mh-seq-list)))
 322                (mh-add-sequence-notation msg (mh-colors-in-use-p))))))
 323     (mh-add-msgs-to-seq ticked mh-tick-seq nil t)
 324     (mh-undefine-sequence mh-tick-seq unticked)
 325     (when mh-index-data
 326       (mh-index-add-to-sequence mh-tick-seq ticked)
 327       (mh-index-delete-from-sequence mh-tick-seq unticked))))
 328
 329 ;;;###mh-autoload
 330 (defun mh-widen (&optional all-flag)
 331   "Remove last restriction.
 332
 333 Each limit or sequence restriction can be undone in turn with
 334 this command. Give this command a prefix argument ALL-FLAG to
 335 remove all limits and sequence restrictions."
 336   (interactive "P")
 337   (let ((msg (mh-get-msg-num nil)))
 338     (when mh-folder-view-stack
 339       (cond (all-flag
 340              (while (cdr mh-view-ops)
 341                (setq mh-view-ops (cdr mh-view-ops)))
 342              (when (eq (car mh-view-ops) 'widen)
 343                (setq mh-view-ops (cdr mh-view-ops))))
 344             ((mh-valid-view-change-operation-p 'widen) nil)
 345             ((memq 'widen mh-view-ops)
 346              (while (not (eq (car mh-view-ops) 'widen))
 347                (setq mh-view-ops (cdr mh-view-ops)))
 348              (setq mh-view-ops (cdr mh-view-ops)))
 349             (t (error "Widening is not applicable")))
 350       ;; If ALL-FLAG is non-nil then rewind stacks
 351       (when all-flag
 352         (while (cdr mh-thread-scan-line-map-stack)
 353           (setq mh-thread-scan-line-map-stack
 354                 (cdr mh-thread-scan-line-map-stack)))
 355         (while (cdr mh-folder-view-stack)
 356           (setq mh-folder-view-stack (cdr mh-folder-view-stack))))
 357       (setq mh-thread-scan-line-map (pop mh-thread-scan-line-map-stack))
 358       (with-mh-folder-updating (t)
 359         (delete-region (point-min) (point-max))
 360         (insert (pop mh-folder-view-stack))
 361         (mh-remove-all-notation)
 362         (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation)
 363         (mh-make-folder-mode-line))
 364       (if msg
 365           (mh-goto-msg msg t t))
 366       (mh-notate-deleted-and-refiled)
 367       (mh-notate-user-sequences)
 368       (mh-notate-cur)
 369       (mh-recenter nil)))
 370   (when (and (null mh-folder-view-stack) (boundp 'tool-bar-mode) tool-bar-mode)
 371     (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map)
 372     (when (buffer-live-p (get-buffer mh-show-buffer))
 373       (with-current-buffer mh-show-buffer
 374         (set (make-local-variable 'tool-bar-map) mh-show-tool-bar-map)))))
 375
 376 \f
 377
 378 ;;; Support Routines
 379
 380 (defvar mh-sequence-history ())
 381
 382 ;;;###mh-autoload
 383 (defun mh-read-seq-default (prompt not-empty)
 384   "Read and return sequence name with default narrowed or previous sequence.
 385 PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil
 386 then a non-empty sequence is read."
 387   (mh-read-seq prompt not-empty
 388                (or mh-last-seq-used
 389                    (car (mh-seq-containing-msg (mh-get-msg-num nil) nil)))))
 390
 391 (defun mh-read-seq (prompt not-empty &optional default)
 392   "Read and return a sequence name.
 393 Prompt with PROMPT, raise an error if the sequence is empty and
 394 the NOT-EMPTY flag is non-nil, and supply an optional DEFAULT
 395 sequence. A reply of '%' defaults to the first sequence
 396 containing the current message."
 397   (let* ((input (completing-read (format "%s sequence%s: " prompt
 398                                          (if default
 399                                              (format " (default %s)" default)
 400                                            ""))
 401                                  (mh-seq-names mh-seq-list)
 402                                  nil nil nil 'mh-sequence-history))
 403          (seq (cond ((equal input "%")
 404                      (car (mh-seq-containing-msg (mh-get-msg-num t) nil)))
 405                     ((equal input "") default)
 406                     (t (intern input))))
 407          (msgs (mh-seq-to-msgs seq)))
 408     (if (and (null msgs) not-empty)
 409         (error "No messages in sequence %s" seq))
 410     seq))
 411
 412 (defun mh-internal-seq (name)
 413   "Return non-nil if NAME is the name of an internal MH-E sequence."
 414   (or (memq name mh-internal-seqs)
 415       (eq name mh-unseen-seq)
 416       (and (mh-colors-in-use-p) mh-tick-seq (eq name mh-tick-seq))
 417       (eq name mh-previous-seq)
 418       (mh-folder-name-p name)))
 419
 420 ;;;###mh-autoload
 421 (defun mh-valid-seq-p (name)
 422   "Return non-nil if NAME is a valid MH sequence name."
 423   (and (symbolp name)
 424        (string-match "^[a-zA-Z][a-zA-Z0-9]*$" (symbol-name name))))
 425
 426 ;;;###mh-autoload
 427 (defun mh-find-seq (name)
 428   "Return sequence NAME."
 429   (assoc name mh-seq-list))
 430
 431 ;;;###mh-autoload
 432 (defun mh-seq-to-msgs (seq)
 433   "Return a list of the messages in SEQ."
 434   (mh-seq-msgs (mh-find-seq seq)))
 435
 436 (defun mh-seq-containing-msg (msg &optional include-internal-flag)
 437   "Return a list of the sequences containing MSG.
 438 If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences
 439 in list."
 440   (let ((l mh-seq-list)
 441         (seqs ()))
 442     (while l
 443       (and (memq msg (mh-seq-msgs (car l)))
 444            (or include-internal-flag
 445                (not (mh-internal-seq (mh-seq-name (car l)))))
 446            (setq seqs (cons (mh-seq-name (car l)) seqs)))
 447       (setq l (cdr l)))
 448     seqs))
 449
 450 ;;;###mh-autoload
 451 (defun mh-define-sequence (seq msgs)
 452   "Define the SEQ to contain the list of MSGS.
 453 Do not mark pseudo-sequences or empty sequences.
 454 Signals an error if SEQ is an invalid name."
 455   (if (and msgs
 456            (mh-valid-seq-p seq)
 457            (not (mh-folder-name-p seq)))
 458       (save-excursion
 459         (mh-exec-cmd-error nil "mark" mh-current-folder "-add" "-zero"
 460                            "-sequence" (symbol-name seq)
 461                            (mh-coalesce-msg-list msgs)))))
 462
 463 ;;;###mh-autoload
 464 (defun mh-undefine-sequence (seq msgs)
 465   "Remove from the SEQ the list of MSGS."
 466   (when (and (mh-valid-seq-p seq) msgs)
 467     (apply #'mh-exec-cmd "mark" mh-current-folder "-delete"
 468            "-sequence" (symbol-name seq) (mh-coalesce-msg-list msgs))))
 469
 470 ;;;###mh-autoload
 471 (defun mh-add-msgs-to-seq (msgs seq &optional internal-flag dont-annotate-flag)
 472   "Add MSGS to SEQ.
 473
 474 Remove duplicates and keep sequence sorted. If optional
 475 INTERNAL-FLAG is non-nil, do not mark the message in the scan
 476 listing or inform MH of the addition.
 477
 478 If DONT-ANNOTATE-FLAG is non-nil then the annotations in the
 479 folder buffer are not updated."
 480   (let ((entry (mh-find-seq seq))
 481         (internal-seq-flag (mh-internal-seq seq)))
 482     (if (and msgs (atom msgs)) (setq msgs (list msgs)))
 483     (if (null entry)
 484         (setq mh-seq-list
 485               (cons (mh-make-seq seq (mh-canonicalize-sequence msgs))
 486                     mh-seq-list))
 487       (if msgs (setcdr entry (mh-canonicalize-sequence
 488                               (append msgs (mh-seq-msgs entry))))))
 489     (unless internal-flag
 490       (mh-add-to-sequence seq msgs)
 491       (when (not dont-annotate-flag)
 492         (mh-iterate-on-range msg msgs
 493           (unless (memq msg (cdr entry))
 494             (mh-add-sequence-notation msg internal-seq-flag)))))))
 495
 496 (defun mh-add-to-sequence (seq msgs)
 497   "The sequence SEQ is augmented with the messages in MSGS."
 498   ;; Add to a SEQUENCE each message the list of MSGS.
 499   (if (and (mh-valid-seq-p seq) (not (mh-folder-name-p seq)))
 500       (if msgs
 501           (apply 'mh-exec-cmd "mark" mh-current-folder "-add"
 502                  "-sequence" (symbol-name seq)
 503                  (mh-coalesce-msg-list msgs)))))
 504
 505 (defun mh-canonicalize-sequence (msgs)
 506   "Sort MSGS in decreasing order and remove duplicates."
 507   (let* ((sorted-msgs (sort (copy-sequence msgs) '>))
 508          (head sorted-msgs))
 509     (while (cdr head)
 510       (if (= (car head) (cadr head))
 511           (setcdr head (cddr head))
 512         (setq head (cdr head))))
 513     sorted-msgs))
 514
 515 (defun mh-delete-a-msg-from-seq (msg sequence internal-flag)
 516   "Delete MSG from SEQUENCE.
 517 If INTERNAL-FLAG is non-nil, then do not inform MH of the
 518 change."
 519   (let ((entry (mh-find-seq sequence)))
 520     (when (and entry (memq msg (mh-seq-msgs entry)))
 521       (if (not internal-flag)
 522           (mh-undefine-sequence sequence (list msg)))
 523       (setcdr entry (delq msg (mh-seq-msgs entry))))))
 524
 525 (defun mh-delete-seq-locally (seq)
 526   "Remove MH-E's record of SEQ."
 527   (let ((entry (mh-find-seq seq)))
 528     (setq mh-seq-list (delq entry mh-seq-list))))
 529
 530 (defun mh-copy-seq-to-eob (seq)
 531   "Copy SEQ to the end of the buffer."
 532   ;; It is quite involved to write something which will work at any place in
 533   ;; the buffer, so we will write something which works only at the end of
 534   ;; the buffer. If we ever need to insert sequences in the middle of the
 535   ;; buffer, this will need to be fixed.
 536   (save-excursion
 537     (let* ((msgs (mh-seq-to-msgs seq))
 538            (coalesced-msgs (mh-coalesce-msg-list msgs)))
 539       (goto-char (point-max))
 540       (save-restriction
 541         (narrow-to-region (point) (point))
 542         (mh-regenerate-headers coalesced-msgs t)
 543         (cond ((memq 'unthread mh-view-ops)
 544                ;; Populate restricted scan-line map
 545                (mh-remove-all-notation)
 546                (mh-iterate-on-range msg (cons (point-min) (point-max))
 547                  (setf (gethash msg mh-thread-scan-line-map)
 548                        (mh-thread-parse-scan-line)))
 549                ;; Remove scan lines and read results from pre-computed tree
 550                (delete-region (point-min) (point-max))
 551                (mh-thread-print-scan-lines
 552                 (mh-thread-generate mh-current-folder ()))
 553                (mh-notate-user-sequences))
 554               (mh-index-data
 555                (mh-index-insert-folder-headers)))))))
 556
 557 ;;;###mh-autoload
 558 (defun mh-valid-view-change-operation-p (op)
 559   "Check if the view change operation can be performed.
 560 OP is one of 'widen and 'unthread."
 561   (cond ((eq (car mh-view-ops) op)
 562          (pop mh-view-ops))
 563         (t nil)))
 564
 565 \f
 566
 567 ;;; Ranges
 568
 569 (defvar mh-range-seq-names)
 570 (defvar mh-range-history ())
 571 (defvar mh-range-completion-map (copy-keymap minibuffer-local-completion-map))
 572 (define-key mh-range-completion-map " " 'self-insert-command)
 573
 574 ;;;###mh-autoload
 575 (defun mh-interactive-range (range-prompt &optional default)
 576   "Return interactive specification for message, sequence, range or region.
 577 By convention, the name of this argument is RANGE.
 578
 579 If variable `transient-mark-mode' is non-nil and the mark is active,
 580 then this function returns a cons-cell of the region.
 581
 582 If optional prefix argument is provided, then prompt for message range
 583 with RANGE-PROMPT. A list of messages in that range is returned.
 584
 585 If a MH range is given, say something like last:20, then a list
 586 containing the messages in that range is returned.
 587
 588 If DEFAULT non-nil then it is returned.
 589
 590 Otherwise, the message number at point is returned.
 591
 592 This function is usually used with `mh-iterate-on-range' in order to
 593 provide a uniform interface to MH-E functions."
 594   (cond ((mh-mark-active-p t) (cons (region-beginning) (region-end)))
 595         (current-prefix-arg (mh-read-range range-prompt nil nil t t))
 596         (default default)
 597         (t (mh-get-msg-num t))))
 598
 599 ;;;###mh-autoload
 600 (defun mh-read-range (prompt &optional folder default
 601                              expand-flag ask-flag number-as-range-flag)
 602   "Read a message range with PROMPT.
 603
 604 If FOLDER is non-nil then a range is read from that folder, otherwise
 605 use `mh-current-folder'.
 606
 607 If DEFAULT is a string then use that as default range to return. If
 608 DEFAULT is nil then ask user with default answer a range based on the
 609 sequences that seem relevant. Finally if DEFAULT is t, try to avoid
 610 prompting the user. Unseen messages, if present, are returned. If the
 611 folder has fewer than `mh-large-folder' messages then \"all\" messages
 612 are returned. Finally as a last resort prompt the user.
 613
 614 If EXPAND-FLAG is non-nil then a list of message numbers corresponding
 615 to the input is returned. If this list is empty then an error is
 616 raised. If EXPAND-FLAG is nil just return the input string. In this
 617 case we don't check if the range is empty.
 618
 619 If ASK-FLAG is non-nil, then the user is always queried for a range of
 620 messages. If ASK-FLAG is nil, then the function checks if the unseen
 621 sequence is non-empty. If that is the case, `mh-unseen-seq', or the
 622 list of messages in it depending on the value of EXPAND, is returned.
 623 Otherwise if the folder has fewer than `mh-large-folder' messages then
 624 the list of messages corresponding to \"all\" is returned. If neither
 625 of the above holds then as a last resort the user is queried for a
 626 range of messages.
 627
 628 If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as
 629 input, it is interpreted as the range \"last:N\".
 630
 631 This function replaces the existing function `mh-read-msg-range'.
 632 Calls to:
 633
 634   (mh-read-msg-range folder flag)
 635
 636 should be replaced with:
 637
 638   (mh-read-range \"Suitable prompt\" folder t nil flag
 639                  mh-interpret-number-as-range-flag)"
 640   (setq default (or default mh-last-seq-used
 641                     (car (mh-seq-containing-msg (mh-get-msg-num nil) t)))
 642         prompt (format "%s range" prompt))
 643   (let* ((folder (or folder mh-current-folder))
 644          (guess (eq default t))
 645          (counts (and guess (mh-folder-size folder)))
 646          (unseen (and counts (> (cadr counts) 0)))
 647          (large (and counts mh-large-folder (> (car counts) mh-large-folder)))
 648          (default (cond ((and guess large) (format "last:%s" mh-large-folder))
 649                         ((and guess (not large)) "all")
 650                         ((stringp default) default)
 651                         ((symbolp default) (symbol-name default))))
 652          (prompt (cond ((and guess large default)
 653                         (format "%s (folder has %s messages, default %s)"
 654                                 prompt (car counts) default))
 655                        ((and guess large)
 656                         (format "%s (folder has %s messages)"
 657                                 prompt (car counts)))
 658                        (default
 659                          (format "%s (default %s)" prompt default))))
 660          (minibuffer-local-completion-map mh-range-completion-map)
 661          (seq-list (if (eq folder mh-current-folder)
 662                        mh-seq-list
 663                      (mh-read-folder-sequences folder nil)))
 664          (mh-range-seq-names
 665           (append '(("first") ("last") ("all") ("prev") ("next"))
 666                   (mh-seq-names seq-list)))
 667          (input (cond ((and (not ask-flag) unseen) (symbol-name mh-unseen-seq))
 668                       ((and (not ask-flag) (not large)) "all")
 669                       (t (completing-read (format "%s: " prompt)
 670                                           'mh-range-completion-function nil nil
 671                                           nil 'mh-range-history default))))
 672          msg-list)
 673     (when (and number-as-range-flag
 674                (string-match "^[ \t]*\\([0-9]+\\)[ \t]*$" input))
 675       (setq input (concat "last:" (match-string 1 input))))
 676     (cond ((not expand-flag) input)
 677           ((assoc (intern input) seq-list)
 678            (cdr (assoc (intern input) seq-list)))
 679           ((setq msg-list (mh-translate-range folder input)) msg-list)
 680           (t (error "No messages in range %s" input)))))
 681
 682 ;;;###mh-autoload
 683 (defun mh-range-to-msg-list (range)
 684   "Return a list of messages for RANGE.
 685
 686 Check the documentation of `mh-interactive-range' to see how
 687 RANGE is read in interactive use."
 688   (let (msg-list)
 689     (mh-iterate-on-range msg range
 690       (push msg msg-list))
 691     (nreverse msg-list)))
 692
 693 ;;;###mh-autoload
 694 (defun mh-translate-range (folder expr)
 695   "In FOLDER, translate the string EXPR to a list of messages numbers."
 696   (save-excursion
 697     (let ((strings (delete "" (split-string expr "[ \t\n]")))
 698           (result ()))
 699       (ignore-errors
 700         (apply #'mh-exec-cmd-quiet nil "mhpath" folder strings)
 701         (set-buffer mh-temp-buffer)
 702         (goto-char (point-min))
 703         (while (re-search-forward "/\\([0-9]*\\)$" nil t)
 704           (push (string-to-number (match-string 1)) result))
 705         (nreverse result)))))
 706
 707 (defun mh-range-completion-function (string predicate flag)
 708   "Programmable completion of message ranges.
 709 STRING is the user input that is to be completed. PREDICATE if non-nil is a
 710 function used to filter the possible choices and FLAG determines whether the
 711 completion is over."
 712   (let* ((candidates mh-range-seq-names)
 713          (last-char (and (not (equal string ""))
 714                          (aref string (1- (length string)))))
 715          (last-word (cond ((null last-char) "")
 716                           ((memq last-char '(?  ?- ?:)) "")
 717                           (t (car (last (split-string string "[ -:]+"))))))
 718          (prefix (substring string 0 (- (length string) (length last-word)))))
 719     (cond ((eq flag nil)
 720            (let ((res (try-completion last-word candidates predicate)))
 721              (cond ((null res) nil)
 722                    ((eq res t) t)
 723                    (t (concat prefix res)))))
 724           ((eq flag t)
 725            (all-completions last-word candidates predicate))
 726           ((eq flag 'lambda)
 727            (loop for x in candidates
 728                  when (equal x last-word) return t
 729                  finally return nil)))))
 730
 731 (defun mh-seq-names (seq-list)
 732   "Return an alist containing the names of the SEQ-LIST."
 733   (mapcar (lambda (entry) (list (symbol-name (mh-seq-name entry))))
 734           seq-list))
 735
 736 (defun mh-folder-size (folder)
 737   "Find size of FOLDER."
 738   (if mh-flists-present-flag
 739       (mh-folder-size-flist folder)
 740     (mh-folder-size-folder folder)))
 741
 742 (defun mh-folder-size-flist (folder)
 743   "Find size of FOLDER using \"flist\"."
 744   (with-temp-buffer
 745     (call-process (expand-file-name "flist" mh-progs) nil t nil "-showzero"
 746                   "-norecurse" folder "-sequence" (symbol-name mh-unseen-seq))
 747     (goto-char (point-min))
 748     (multiple-value-bind (folder unseen total)
 749         (mh-parse-flist-output-line
 750          (buffer-substring (point) (mh-line-end-position)))
 751       (values 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           (values (string-to-number (match-string 1)) u folder)
 763         (values 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             (values (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