1;;; mh-seq.el --- MH-E sequences support 2 3;; Copyright (C) 1993, 1995, 4;; 2001, 2002, 2003, 2004, 2005, 2006, 2007 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 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 74Check the documentation of `mh-interactive-range' to see how 75RANGE 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 84Check the documentation of `mh-interactive-range' to see how 85RANGE is read in interactive use. 86 87In a program, non-nil INTERNAL-FLAG means do not inform MH of the 88change." 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 117You are prompted for the sequence to delete. Note that this 118deletes only the sequence, not the messages in the sequence. If 119you 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 143The 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 186Use a prefix argument to display the sequences in which another 187MESSAGE 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 211You are prompted for the name of the sequence. What this command 212does is show only those messages that are in the selected 213sequence in the MH-Folder buffer. In addition, it limits further 214MH-E searches to just those messages. 215 216When 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 252What this command does is show only those messages that are in 253the \"tick\" sequence (which you can customize via the 254`mh-tick-seq' option) in the MH-Folder buffer. In addition, it 255limits further MH-E searches to just those messages. When you 256want 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 269Give this command a RANGE and you can add all the messages in a 270sequence to another sequence (for example, 271\"\\[universal-argument] \\[mh-put-msg-in-seq] SourceSequence RET 272DestSequence RET\"). Check the documentation of 273`mh-interactive-range' to see how RANGE is read in interactive 274use." 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 299This command adds messages to the \"tick\" sequence (which you can customize 300via the option `mh-tick-seq'). This sequence can be viewed later with the 301\\[mh-index-ticked-messages] command. 302 303Check the documentation of `mh-interactive-range' to see how RANGE is read in 304interactive 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 333Each limit or sequence restriction can be undone in turn with 334this command. Give this command a prefix argument ALL-FLAG to 335remove 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 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. 385PROMPT is the prompt to use when reading. If NOT-EMPTY is non-nil 386then 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. 393Prompt with PROMPT, raise an error if the sequence is empty and 394the NOT-EMPTY flag is non-nil, and supply an optional DEFAULT 395sequence. A reply of '%' defaults to the first sequence 396containing 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. 438If INCLUDE-INTERNAL-FLAG non-nil, include MH-E internal sequences 439in 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. 453Do not mark pseudo-sequences or empty sequences. 454Signals 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 474Remove duplicates and keep sequence sorted. If optional 475INTERNAL-FLAG is non-nil, do not mark the message in the scan 476listing or inform MH of the addition. 477 478If DONT-ANNOTATE-FLAG is non-nil then the annotations in the 479folder 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. 517If INTERNAL-FLAG is non-nil, then do not inform MH of the 518change." 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. 560OP is one of 'widen and 'unthread." 561 (cond ((eq (car mh-view-ops) op) 562 (pop mh-view-ops)) 563 (t nil))) 564 565 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. 577By convention, the name of this argument is RANGE. 578 579If variable `transient-mark-mode' is non-nil and the mark is active, 580then this function returns a cons-cell of the region. 581 582If optional prefix argument is provided, then prompt for message range 583with RANGE-PROMPT. A list of messages in that range is returned. 584 585If a MH range is given, say something like last:20, then a list 586containing the messages in that range is returned. 587 588If DEFAULT non-nil then it is returned. 589 590Otherwise, the message number at point is returned. 591 592This function is usually used with `mh-iterate-on-range' in order to 593provide 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 604If FOLDER is non-nil then a range is read from that folder, otherwise 605use `mh-current-folder'. 606 607If DEFAULT is a string then use that as default range to return. If 608DEFAULT is nil then ask user with default answer a range based on the 609sequences that seem relevant. Finally if DEFAULT is t, try to avoid 610prompting the user. Unseen messages, if present, are returned. If the 611folder has fewer than `mh-large-folder' messages then \"all\" messages 612are returned. Finally as a last resort prompt the user. 613 614If EXPAND-FLAG is non-nil then a list of message numbers corresponding 615to the input is returned. If this list is empty then an error is 616raised. If EXPAND-FLAG is nil just return the input string. In this 617case we don't check if the range is empty. 618 619If ASK-FLAG is non-nil, then the user is always queried for a range of 620messages. If ASK-FLAG is nil, then the function checks if the unseen 621sequence is non-empty. If that is the case, `mh-unseen-seq', or the 622list of messages in it depending on the value of EXPAND, is returned. 623Otherwise if the folder has fewer than `mh-large-folder' messages then 624the list of messages corresponding to \"all\" is returned. If neither 625of the above holds then as a last resort the user is queried for a 626range of messages. 627 628If NUMBER-AS-RANGE-FLAG is non-nil, then if a number, N is read as 629input, it is interpreted as the range \"last:N\". 630 631This function replaces the existing function `mh-read-msg-range'. 632Calls to: 633 634 (mh-read-msg-range folder flag) 635 636should 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 686Check the documentation of `mh-interactive-range' to see how 687RANGE 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. 709STRING is the user input that is to be completed. PREDICATE if non-nil is a 710function used to filter the possible choices and FLAG determines whether the 711completion 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. 768If CURRENT-FOLDER is non-nil then it contains the current folder 769name and it is used to avoid problems in corner cases involving 770folders 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. 796If SAVE-REFILES is non-nil, then keep the sequences 797that 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. 820Expands 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 843 844;;; Notation 845 846;;;###mh-autoload 847(defun mh-notate (msg notation offset) 848 "Mark MSG with the character NOTATION at position OFFSET. 849Null MSG means the message at cursor. 850If 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. 882In addition to notating the current message with `mh-note-cur' 883the function uses `overlay-arrow-position' to put a marker in the 884fringe." 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. 909Messages to be deleted are given by `mh-delete-list' while 910messages 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 928Check the documentation of `mh-interactive-range' to see how 929RANGE is read in interactive use; if nil all messages are 930notated." 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. 944If INTERNAL-SEQ-FLAG is non-nil, then refontify the scan line if 945font-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. 966If INTERNAL-SEQ-FLAG is non-nil, then `font-lock' was used to 967highlight the sequence. In that case, no notation needs to be removed. 968Otherwise the effect of inserting `mh-note-seq' needs to be reversed. 969If ALL is non-nil, then all sequence marks on the scan line are 970removed." 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 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 1022