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

   1 ;;; mh-seq.el --- mh-e sequences support
   2
   3 ;; Copyright (C) 1993, 1995, 2001, 2002 Free Software Foundation, Inc.
   4
   5 ;; Author: Bill Wohler <wohler@newt.com>
   6 ;; Maintainer: Bill Wohler <wohler@newt.com>
   7 ;; Keywords: mail
   8 ;; See: mh-e.el
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26
  27 ;;; Commentary:
  28
  29 ;; Internal support for mh-e package.
  30
  31 ;;; Change Log:
  32
  33 ;; $Id: mh-seq.el,v 1.14 2002/04/07 19:20:56 wohler Exp $
  34
  35 ;;; Code:
  36
  37 (provide 'mh-seq)
  38 (require 'mh-e)
  39
  40 ;;; Internal variables:
  41
  42 (defvar mh-last-seq-used nil)           ;Name of seq to which a msg was last added.
  43
  44 (defvar mh-non-seq-mode-line-annotation nil) ;Saved value of mh-mode-line-annotation when narrowed to a seq.
  45
  46
  47 (defun mh-delete-seq (sequence)
  48   "Delete the SEQUENCE."
  49   (interactive (list (mh-read-seq-default "Delete" t)))
  50   (mh-map-to-seq-msgs 'mh-notate-if-in-one-seq sequence ?  (1+ mh-cmd-note)
  51                       sequence)
  52   (mh-undefine-sequence sequence '("all"))
  53   (mh-delete-seq-locally sequence))
  54
  55
  56 (defun mh-list-sequences (folder)
  57   "List the sequences defined in FOLDER."
  58   (interactive (list (mh-prompt-for-folder "List sequences in"
  59                                            mh-current-folder t)))
  60   (let ((temp-buffer mh-temp-sequences-buffer)
  61         (seq-list mh-seq-list))
  62     (with-output-to-temp-buffer temp-buffer
  63       (save-excursion
  64         (set-buffer temp-buffer)
  65         (erase-buffer)
  66         (message "Listing sequences ...")
  67         (insert "Sequences in folder " folder ":\n")
  68         (while seq-list
  69           (let ((name (mh-seq-name (car seq-list)))
  70                 (sorted-seq-msgs
  71                  (sort (copy-sequence (mh-seq-msgs (car seq-list))) '<))
  72                 (last-col (- (window-width) 4))
  73                 name-spec)
  74             (insert (setq name-spec (format "%20s:" name)))
  75             (while sorted-seq-msgs
  76               (if (> (current-column) last-col)
  77                   (progn
  78                     (insert "\n")
  79                     (move-to-column (length name-spec))))
  80               (insert (format " %s" (car sorted-seq-msgs)))
  81               (setq sorted-seq-msgs (cdr sorted-seq-msgs)))
  82             (insert "\n"))
  83           (setq seq-list (cdr seq-list)))
  84         (goto-char (point-min))
  85         (view-mode 1)
  86         (setq view-exit-action 'kill-buffer)
  87         (message "Listing sequences...done")))))
  88
  89
  90 (defun mh-msg-is-in-seq (message)
  91   "Display the sequences that contain MESSAGE (default: current message)."
  92   (interactive (list (mh-get-msg-num t)))
  93   (message "Message %d is in sequences: %s"
  94            message
  95            (mapconcat 'concat
  96                       (mh-list-to-string (mh-seq-containing-msg message t))
  97                       " ")))
  98
  99
 100 (defun mh-narrow-to-seq (sequence)
 101   "Restrict display of this folder to just messages in SEQUENCE.
 102 Use \\<mh-folder-mode-map>\\[mh-widen] to undo this command."
 103   (interactive (list (mh-read-seq "Narrow to" t)))
 104   (with-mh-folder-updating (t)
 105     (cond ((mh-seq-to-msgs sequence)
 106            (mh-widen)
 107            (let ((eob (point-max)))
 108              (mh-copy-seq-to-point sequence eob)
 109              (narrow-to-region eob (point-max))
 110              (make-variable-buffer-local 'mh-non-seq-mode-line-annotation)
 111              (setq mh-non-seq-mode-line-annotation mh-mode-line-annotation)
 112              (setq mh-mode-line-annotation (symbol-name sequence))
 113              (mh-make-folder-mode-line)
 114              (mh-recenter nil)
 115              (if (and (boundp 'tool-bar-mode) tool-bar-mode)
 116                  (set (make-local-variable 'tool-bar-map)
 117                       mh-folder-seq-tool-bar-map))
 118              (setq mh-narrowed-to-seq sequence)))
 119           (t
 120            (error "No messages in sequence `%s'" (symbol-name sequence))))))
 121
 122
 123 (defun mh-put-msg-in-seq (msg-or-seq sequence)
 124   "Add MSG-OR-SEQ (default: displayed message) to SEQUENCE.
 125 If optional prefix argument provided, then prompt for the message sequence."
 126   (interactive (list (if current-prefix-arg
 127                          (mh-read-seq-default "Add messages from" t)
 128                          (mh-get-msg-num t))
 129                      (mh-read-seq-default "Add to" nil)))
 130   (if (not (mh-internal-seq sequence))
 131       (setq mh-last-seq-used sequence))
 132   (mh-add-msgs-to-seq (if (numberp msg-or-seq)
 133                           msg-or-seq
 134                           (mh-seq-to-msgs msg-or-seq))
 135                       sequence))
 136
 137
 138 (defun mh-widen ()
 139   "Remove restrictions from current folder, thereby showing all messages."
 140   (interactive)
 141   (let ((msg (mh-get-msg-num nil)))
 142     (when mh-narrowed-to-seq
 143       (with-mh-folder-updating (t)
 144         (delete-region (point-min) (point-max))
 145         (widen)
 146         (setq mh-mode-line-annotation mh-non-seq-mode-line-annotation)
 147         (mh-make-folder-mode-line))
 148       (if msg
 149           (mh-goto-msg msg t nil))))
 150   (mh-notate-deleted-and-refiled)
 151   (if (and (boundp 'tool-bar-mode) tool-bar-mode)
 152       (set (make-local-variable 'tool-bar-map) mh-folder-tool-bar-map))
 153   (setq mh-narrowed-to-seq nil))
 154
 155
 156 ;; FIXME?  We may want to clear all notations and add one for current-message
 157 ;;         and process user sequences.
 158 (defun mh-notate-deleted-and-refiled ()
 159   ;; notate the sequence 'deleted as well as all the sequences in
 160   ;; mh-refile-list.
 161   ;;
 162   ;; First, the 'deleted sequence is straightforward
 163   (mh-notate-seq 'deleted mh-note-deleted mh-cmd-note)
 164   ;; Second, refiles are stored in multiple sequences, one for each folder
 165   ;; name to refile to.  This list of buffer names is stored in
 166   ;; mh-refile-list
 167   (mh-mapc
 168    (function
 169     (lambda (dest)
 170       ;; foreach folder name, get the keyed sequence from mh-seq-list
 171       (let ((msg-list (cdr (assoc dest mh-seq-list))))
 172         (mapcar (lambda (msg)
 173                   ;; foreach msg in a sequence, do the mh-notate
 174                   (mh-notate msg mh-note-refiled mh-cmd-note))
 175                 msg-list))))
 176    mh-refile-list))
 177 \f
 178
 179 ;;; Commands to manipulate sequences.  Sequences are stored in an alist
 180 ;;; of the form:
 181 ;;;     ((seq-name msgs ...) (seq-name msgs ...) ...)
 182
 183
 184 (defun mh-read-seq-default (prompt not-empty)
 185   ;; Read and return sequence name with default narrowed or previous sequence.
 186   (mh-read-seq prompt not-empty
 187                (or mh-narrowed-to-seq
 188                    mh-last-seq-used
 189                    (car (mh-seq-containing-msg (mh-get-msg-num nil) nil)))))
 190
 191
 192 (defun mh-read-seq (prompt not-empty &optional default)
 193   ;; Read and return a sequence name.  Prompt with PROMPT, raise an error
 194   ;; if the sequence is empty and the NOT-EMPTY flag is non-nil, and supply
 195   ;; an optional DEFAULT sequence.
 196   ;; A reply of '%' defaults to the first sequence containing the current
 197   ;; message.
 198   (let* ((input (completing-read (format "%s %s %s" prompt "sequence:"
 199                                          (if default
 200                                              (format "[%s] " default)
 201                                              ""))
 202                                  (mh-seq-names mh-seq-list)))
 203          (seq (cond ((equal input "%")
 204                      (car (mh-seq-containing-msg (mh-get-msg-num t) nil)))
 205                     ((equal input "") default)
 206                     (t (intern input))))
 207          (msgs (mh-seq-to-msgs seq)))
 208     (if (and (null msgs) not-empty)
 209         (error "No messages in sequence `%s'" seq))
 210     seq))
 211
 212
 213 (defun mh-seq-names (seq-list)
 214   ;; Return an alist containing the names of the SEQUENCES.
 215   (mapcar (function (lambda (entry) (list (symbol-name (mh-seq-name entry)))))
 216           seq-list))
 217
 218
 219 (defun mh-rename-seq (sequence new-name)
 220   "Rename SEQUENCE to have NEW-NAME."
 221   (interactive (list (mh-read-seq "Old" t)
 222                      (intern (read-string "New sequence name: "))))
 223   (let ((old-seq (mh-find-seq sequence)))
 224     (or old-seq
 225         (error "Sequence %s does not exist" sequence))
 226     ;; create new sequence first, since it might raise an error.
 227     (mh-define-sequence new-name (mh-seq-msgs old-seq))
 228     (mh-undefine-sequence sequence (mh-seq-msgs old-seq))
 229     (rplaca old-seq new-name)))
 230
 231
 232 (defun mh-map-to-seq-msgs (func seq &rest args)
 233   ;; Invoke the FUNCTION at each message in the SEQUENCE, passing the
 234   ;; remaining ARGS as arguments.
 235   (save-excursion
 236     (let ((msgs (mh-seq-to-msgs seq)))
 237       (while msgs
 238         (if (mh-goto-msg (car msgs) t t)
 239             (apply func (car msgs) args))
 240         (setq msgs (cdr msgs))))))
 241
 242
 243 (defun mh-notate-seq (seq notation offset)
 244   ;; Mark the scan listing of all messages in the SEQUENCE with the CHARACTER
 245   ;; at the given OFFSET from the beginning of the listing line.
 246   (mh-map-to-seq-msgs 'mh-notate seq notation offset))
 247
 248
 249 (defun mh-add-to-sequence (seq msgs)
 250   ;; Add to a SEQUENCE each message the list of MSGS.
 251   (if (not (mh-folder-name-p seq))
 252       (if msgs
 253           (apply 'mh-exec-cmd "mark" mh-current-folder "-add"
 254                  "-sequence" (symbol-name seq)
 255                  (mh-coalesce-msg-list msgs)))))
 256
 257
 258 (defun mh-copy-seq-to-point (seq location)
 259   ;; Copy the scan listing of the messages in SEQUENCE to after the point
 260   ;; LOCATION in the current buffer.
 261   (mh-map-to-seq-msgs 'mh-copy-line-to-point seq location))
 262
 263
 264 (defun mh-copy-line-to-point (msg location)
 265   ;; Copy the current line to the LOCATION in the current buffer.
 266   (beginning-of-line)
 267   (save-excursion
 268     (let ((beginning-of-line (point))
 269           end)
 270       (forward-line 1)
 271       (setq end (point))
 272       (goto-char location)
 273       (insert-buffer-substring (current-buffer) beginning-of-line end))))
 274
 275 (defun mh-region-to-sequence (begin end)
 276   "Define sequence 'region as the messages between point and mark.
 277 When called programmatically, use arguments BEGIN and END to define region."
 278   (interactive "r")
 279   (mh-delete-seq-locally 'region)
 280   (save-excursion
 281     (goto-char begin)
 282     (while (<= (point) end)
 283       (mh-add-msgs-to-seq (mh-get-msg-num t) 'region t)
 284       (forward-line 1))))
 285
 286 \f
 287 ;;; Commands to handle new 'subject sequence.
 288 ;;; Or "Poor man's threading" by psg.
 289 (defun mh-subject-thread-to-sequence (all)
 290   "Put all following messages with same subject in sequence 'subject.
 291 If arg ALL is t, move to beginning of folder buffer to collect all messages.
 292 If arg ALL is nil, collect only messages fron current one on forward.
 293 Return number of messages put in the sequence:
 294  nil -> there was no subject line.
 295  0   -> there were no later messages with the same subject (sequence not made)
 296  >1  -> the total number of messages including current one."
 297   (if (not (eq major-mode 'mh-folder-mode))
 298       (error "Not in a folder buffer"))
 299   (save-excursion
 300     (beginning-of-line)
 301     (if (or (not (looking-at mh-scan-subject-regexp))
 302             (not (match-string 2))
 303             (string-equal "" (match-string 2)))
 304         (progn (message "No subject line.")
 305                nil)
 306       (let ((subject (match-string-no-properties 2))
 307             (end (point-max))
 308             (list))
 309         (if (> (length subject) 41)
 310             (setq subject (substring subject 0 41)))
 311         (save-excursion
 312           (if all
 313               (goto-char (point-min)))
 314           (while (re-search-forward mh-scan-subject-regexp nil t)
 315             (let ((this-subject (match-string-no-properties 2)))
 316               (if (> (length this-subject) 41)
 317                   (setq this-subject (substring this-subject 0 41)))
 318               (if (string-equal this-subject subject)
 319                   (setq list (cons (mh-get-msg-num t) list))))))
 320         (cond
 321          (list
 322           ;; If we created a new sequence, add the initial message to it too.
 323           (if (not (member (mh-get-msg-num t) list))
 324               (setq list (cons (mh-get-msg-num t) list)))
 325           (mh-delete-seq-locally 'subject)
 326           ;; sort the result into a sequence
 327           (let ((sorted-list (sort (copy-sequence list) 'mh-lessp))
 328                 (msg))
 329             (while sorted-list
 330               (mh-add-msgs-to-seq (car sorted-list) 'subject t)
 331               (setq sorted-list (cdr sorted-list)))
 332             (safe-length list)))
 333          (t
 334           0))))))
 335
 336 (defun mh-narrow-to-subject-thread ()
 337   "Narrow to a sequence containing all following messages with same subject."
 338   (interactive)
 339   (let ((num (mh-get-msg-num nil))
 340         (count (mh-subject-thread-to-sequence t)))
 341     (cond
 342      ((not count)                       ; No subject line, delete msg anyway
 343       nil)
 344      ((= 0 count)                       ; No other msgs, delete msg anyway.
 345       (message "No other messages with same Subject following this one.")
 346       nil)
 347      (t                                 ; We have a subject sequence.
 348       (message "Found %d messages for subject sequence." count)
 349       (mh-narrow-to-seq 'subject)
 350       (if (numberp num)
 351           (mh-goto-msg num t t))))))
 352
 353 (defun mh-toggle-subject-thread ()
 354   "Narrow to or widen from a sequence containing current subject sequence."
 355   (interactive)
 356   (if (and (stringp mh-mode-line-annotation)
 357            (string-equal mh-mode-line-annotation "subject"))
 358       (progn
 359         (goto-char (point-min))
 360         (mh-widen))
 361     (mh-narrow-to-subject-thread)))
 362
 363 (defun mh-delete-subject-thread ()
 364   "Mark all following messages with same subject to be deleted."
 365   (interactive)
 366   (let ((count (mh-subject-thread-to-sequence nil)))
 367     (cond
 368      ((not count)                       ; No subject line, delete msg anyway
 369       (mh-delete-msg (mh-get-msg-num t)))
 370      ((= 0 count)                       ; No other msgs, delete msg anyway.
 371       (message "No other messages with same Subject following this one.")
 372       (mh-delete-msg (mh-get-msg-num t)))
 373      (t                                 ; We have a subject sequence.
 374       (message "Marked %d messages for deletion" count)
 375       (mh-delete-msg 'subject)))))
 376
 377 (defun mh-next-unseen-subject-thread ()
 378   "Get the next unseen subject thread."
 379   (interactive)
 380   (if (and mh-mode-line-annotation
 381            (string-equal mh-mode-line-annotation "subject"))
 382       (goto-char (point-min)))
 383   (if (or (not mh-mode-line-annotation)
 384           (not (string-equal mh-mode-line-annotation "unseen")))
 385       (mh-narrow-to-seq 'unseen))
 386   (mh-next-undeleted-msg)
 387   (mh-narrow-to-subject-thread))
 388
 389 ;;; mh-seq.el ends here