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

   1 ;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs
   2
   3 ;; Copyright (C) 1985, 1988, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
   4 ;;   2007, 2008, 2009  Free Software Foundation, Inc.
   5
   6 ;; Maintainer: FSF
   7 ;; Keywords: mail
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (require 'rmail)
  29
  30 ;; Global to all RMAIL buffers.  It exists for the sake of completion.
  31 ;; It is better to use strings with the label functions and let them
  32 ;; worry about making the label.
  33 (defvar rmail-label-obarray (make-vector 47 0)
  34   "Obarray of labels used by Rmail.
  35 `rmail-read-label' uses this to offer completion.")
  36
  37 ;; Initialize with the standard labels.
  38 (mapc (lambda (s) (intern (cadr s) rmail-label-obarray))
  39       rmail-attr-array)
  40
  41 (defun rmail-make-label (s)
  42   "Intern string S as a downcased symbol in `rmail-label-obarray'."
  43   (intern (downcase s) rmail-label-obarray))
  44 \f
  45 ;;;###autoload
  46 (defun rmail-add-label (label)
  47   "Add LABEL to labels associated with current RMAIL message.
  48 Completes (see `rmail-read-label') over known labels when reading.
  49 LABEL may be a symbol or string."
  50   (interactive (list (rmail-read-label "Add label")))
  51   (rmail-set-label label t))
  52
  53 ;;;###autoload
  54 (defun rmail-kill-label (label)
  55   "Remove LABEL from labels associated with current RMAIL message.
  56 Completes (see `rmail-read-label') over known labels when reading.
  57 LABEL may be a symbol or string."
  58   (interactive (list (rmail-read-label "Remove label")))
  59   (rmail-set-label label nil))
  60
  61 ;;;###autoload
  62 (defun rmail-read-label (prompt)
  63   "Read a label with completion, prompting with PROMPT.
  64 Completions are chosen from `rmail-label-obarray'.  The default
  65 is `rmail-last-label', if that is non-nil.  Updates `rmail-last-label'
  66 according to the choice made, and returns a symbol."
  67   (let* ((old (rmail-get-keywords))
  68         (result
  69          (progn
  70            ;; Offer any existing labels as choices.
  71            (if old (mapc 'rmail-make-label (split-string old ", ")))
  72            (completing-read (concat prompt
  73                                     (if rmail-last-label
  74                                         (concat " (default "
  75                                                 (symbol-name rmail-last-label)
  76                                                 "): ")
  77                                       ": "))
  78                             rmail-label-obarray
  79                             nil
  80                             nil))))
  81     (if (string= result "")
  82         rmail-last-label
  83       (setq rmail-last-label (rmail-make-label result)))))
  84
  85 (declare-function rmail-summary-update-line "rmailsum" (n))
  86
  87 (defun rmail-set-label (label state &optional msg)
  88   "Set LABEL as present or absent according to STATE in message MSG.
  89 LABEL may be a symbol or string."
  90   (or (stringp label) (setq label (symbol-name label)))
  91   (with-current-buffer rmail-buffer
  92     (rmail-maybe-set-message-counters)
  93     (or msg (setq msg rmail-current-message))
  94     ;; Force recalculation of summary for this message.
  95     (aset rmail-summary-vector (1- msg) nil)
  96     (let (attr-index)
  97       ;; Is this label an attribute?
  98       (dotimes (i (length rmail-attr-array))
  99         (if (string= (cadr (aref rmail-attr-array i)) label)
 100             (setq attr-index i)))
 101       (if attr-index
 102           ;; If so, set it as an attribute.
 103           (rmail-set-attribute attr-index state msg)
 104         ;; Is this keyword already present in msg's keyword list?
 105         (let* ((header (rmail-get-header rmail-keyword-header msg))
 106                (regexp (concat ", " (regexp-quote label) ","))
 107                (present (string-match regexp (concat ", " header ","))))
 108           ;; If current state is not correct,
 109           (unless (eq present state)
 110             ;; either add it or delete it.
 111             (rmail-set-header
 112              rmail-keyword-header msg
 113              (if state
 114                  ;; Add this keyword at the end.
 115                  (if (and header (not (string= header "")))
 116                      (concat header ", " label)
 117                    label)
 118                ;; Delete this keyword.
 119                (let ((before (substring header 0
 120                                         (max 0 (- (match-beginning 0) 2))))
 121                      (after (substring header
 122                                        (min (length header)
 123                                             (- (match-end 0) 1)))))
 124                  (cond ((string= before "")
 125                         after)
 126                        ((string= after "")
 127                         before)
 128                        (t (concat before ", " after))))))))))
 129     (if (rmail-summary-exists)
 130         (rmail-select-summary (rmail-summary-update-line msg)))
 131     (if (= msg rmail-current-message)
 132         (rmail-display-labels))))
 133 \f
 134 ;; Motion on messages with keywords.
 135
 136 ;;;###autoload
 137 (defun rmail-previous-labeled-message (n labels)
 138   "Show previous message with one of the labels LABELS.
 139 LABELS should be a comma-separated list of label names.
 140 If LABELS is empty, the last set of labels specified is used.
 141 With prefix argument N moves backward N messages with these labels."
 142   (interactive "p\nsMove to previous msg with labels: ")
 143   (rmail-next-labeled-message (- n) labels))
 144
 145 (declare-function mail-comma-list-regexp "mail-utils" (labels))
 146
 147 ;;;###autoload
 148 (defun rmail-next-labeled-message (n labels)
 149   "Show next message with one of the labels LABELS.
 150 LABELS should be a comma-separated list of label names.
 151 If LABELS is empty, the last set of labels specified is used.
 152 With prefix argument N moves forward N messages with these labels."
 153   (interactive "p\nsMove to next msg with labels: ")
 154   (if (string= labels "")
 155       (setq labels rmail-last-multi-labels))
 156   (or labels
 157       (error "No labels to find have been specified previously"))
 158   (set-buffer rmail-buffer)
 159   (setq rmail-last-multi-labels labels)
 160   (rmail-maybe-set-message-counters)
 161   (let ((lastwin rmail-current-message)
 162         (current rmail-current-message)
 163         (regexp (concat " \\("
 164                         (mail-comma-list-regexp labels)
 165                         "\\)\\(,\\|\\'\\)")))
 166     (while (and (> n 0) (< current rmail-total-messages))
 167       (setq current (1+ current))
 168       (if (string-match regexp (rmail-get-labels current))
 169           (setq lastwin current n (1- n))))
 170     (while (and (< n 0) (> current 1))
 171       (setq current (1- current))
 172       (if (string-match regexp (rmail-get-labels current))
 173           (setq lastwin current n (1+ n))))
 174     (if (< n 0)
 175         (error "No previous message with labels %s" labels)
 176       (if (> n 0)
 177           (error "No following message with labels %s" labels)
 178         (rmail-show-message lastwin)))))
 179
 180 (provide 'rmailkwd)
 181
 182 ;; arch-tag: 1149979c-8e47-4333-9629-cf3dc887a6a7
 183 ;;; rmailkwd.el ends here