lisp/mail/rmailkwd.el

   1 ;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs
   2
   3 ;; Copyright (C) 1985, 1988, 1994, 2001-2018 Free Software Foundation,
   4 ;; Inc.
   5
   6 ;; Maintainer: emacs-devel@gnu.org
   7 ;; Keywords: mail
   8 ;; Package: rmail
   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 3 of the License, or
  15 ;; (at your option) 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.  If not, see <https://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;;; Code:
  28
  29 (require 'rmail)
  30
  31 ;; Global to all RMAIL buffers.  It exists for the sake of completion.
  32 ;; It is better to use strings with the label functions and let them
  33 ;; worry about making the label.
  34 (defvar rmail-label-obarray (make-vector 47 0)
  35   "Obarray of labels used by Rmail.
  36 `rmail-read-label' uses this to offer completion.")
  37
  38 ;; Initialize with the standard labels.
  39 (mapc (lambda (s) (intern (cadr s) rmail-label-obarray))
  40       rmail-attr-array)
  41
  42 (defun rmail-make-label (s)
  43   "Intern string S as a downcased symbol in `rmail-label-obarray'."
  44   (intern (downcase s) rmail-label-obarray))
  45 \f
  46 ;;;###autoload
  47 (defun rmail-add-label (label)
  48   "Add LABEL to labels associated with current RMAIL message.
  49 Completes (see `rmail-read-label') over known labels when reading.
  50 LABEL may be a symbol or string.  Only one label is allowed."
  51   (interactive (list (rmail-read-label "Add label")))
  52   (rmail-set-label label t))
  53
  54 ;;;###autoload
  55 (defun rmail-kill-label (label)
  56   "Remove LABEL from labels associated with current RMAIL message.
  57 Completes (see `rmail-read-label') over known labels when reading.
  58 LABEL may be a symbol or string.  Only one label is allowed."
  59   (interactive (list (rmail-read-label "Remove label")))
  60   (rmail-set-label label nil))
  61
  62 ;;;###autoload
  63 (defun rmail-read-label (prompt)
  64   "Read a label with completion, prompting with PROMPT.
  65 Completions are chosen from `rmail-label-obarray'.  The default
  66 is `rmail-last-label', if that is non-nil.  Updates `rmail-last-label'
  67 according to the choice made, and returns a symbol."
  68   (let* ((old nil)
  69          (result
  70           (progn
  71             ;; If the summary exists, we've already read all the
  72             ;; existing labels.  If not, read the ones in this message.
  73             (or (eq major-mode 'rmail-summary-mode)
  74                 (rmail-summary-exists)
  75                 (and (setq old (rmail-get-keywords))
  76                      (mapc 'rmail-make-label (split-string old ", "))))
  77             (completing-read (concat prompt
  78                                      (if rmail-last-label
  79                                          (concat " (default "
  80                                                  (symbol-name rmail-last-label)
  81                                                  "): ")
  82                                        ": "))
  83                              rmail-label-obarray
  84                              nil
  85                              nil))))
  86     (if (string= result "")
  87         rmail-last-label
  88       (setq rmail-last-label (rmail-make-label result)))))
  89
  90 (declare-function rmail-summary-update-line "rmailsum" (n))
  91
  92 (defun rmail-set-label (label state &optional msg)
  93   "Set LABEL as present or absent according to STATE in message MSG.
  94 LABEL may be a symbol or string."
  95   (or (stringp label) (setq label (symbol-name label)))
  96   (if (string-match "," label)
  97       (error "More than one label specified"))
  98   (with-current-buffer rmail-buffer
  99     (rmail-maybe-set-message-counters)
 100     (if (zerop (or msg (setq msg rmail-current-message)))
 101         (error "No message"))
 102     ;; Force recalculation of summary for this message.
 103     (aset rmail-summary-vector (1- msg) nil)
 104     (let (attr-index)
 105       ;; Is this label an attribute?
 106       (dotimes (i (length rmail-attr-array))
 107         (if (string= (cadr (aref rmail-attr-array i)) label)
 108             (setq attr-index i)))
 109       (if attr-index
 110           ;; If so, set it as an attribute.
 111           (rmail-set-attribute attr-index state msg)
 112         ;; Is this keyword already present in msg's keyword list?
 113         (let* ((header (rmail-get-keywords msg))
 114                (regexp (concat ", " (regexp-quote label) ","))
 115                (present (not (null
 116                               (string-match regexp (concat ", " header ","))))))
 117           ;; If current state is not correct,
 118           (unless (eq present state)
 119             ;; either add it or delete it.
 120             (rmail-set-header
 121              rmail-keyword-header msg
 122              (if state
 123                  ;; Add this keyword at the end.
 124                  (if (and header (not (string= header "")))
 125                      (concat header ", " label)
 126                    label)
 127                ;; Delete this keyword.
 128                (let ((before (substring header 0
 129                                         (max 0 (- (match-beginning 0) 2))))
 130                      (after (substring header
 131                                        (min (length header)
 132                                             (- (match-end 0) 1)))))
 133                  (cond ((string= before "")
 134                         ;; If before and after both empty, delete the header.
 135                         (unless (string= after "")
 136                           after))
 137                        ((string= after "")
 138                         before)
 139                        (t (concat before ", " after))))))))))
 140     (if (rmail-summary-exists)
 141         (rmail-select-summary (rmail-summary-update-line msg)))
 142     (if (= msg rmail-current-message)
 143         (rmail-display-labels))))
 144 \f
 145 ;; Motion on messages with keywords.
 146
 147 ;;;###autoload
 148 (defun rmail-previous-labeled-message (n labels)
 149   "Show previous 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 backward N messages with these labels."
 153   (interactive "p\nsMove to previous msg with labels: ")
 154   (rmail-next-labeled-message (- n) labels))
 155
 156 (declare-function mail-comma-list-regexp "mail-utils" (labels))
 157
 158 ;;;###autoload
 159 (defun rmail-next-labeled-message (n labels)
 160   "Show next message with one of the labels LABELS.
 161 LABELS should be a comma-separated list of label names.
 162 If LABELS is empty, the last set of labels specified is used.
 163 With prefix argument N moves forward N messages with these labels."
 164   ;; FIXME show the default in the prompt.
 165   (interactive "p\nsMove to next msg with labels: ")
 166   (if (string= labels "")
 167       (setq labels rmail-last-multi-labels))
 168   (or labels
 169       (error "No labels to find have been specified previously"))
 170   (set-buffer rmail-buffer)
 171   (setq rmail-last-multi-labels labels)
 172   (rmail-maybe-set-message-counters)
 173   (let ((lastwin rmail-current-message)
 174         (current rmail-current-message)
 175         (regexp (concat " \\("
 176                         (mail-comma-list-regexp labels)
 177                         "\\)\\(,\\|\\'\\)")))
 178     (while (and (> n 0) (< current rmail-total-messages))
 179       (setq current (1+ current))
 180       (if (string-match regexp (rmail-get-labels current))
 181           (setq lastwin current n (1- n))))
 182     (while (and (< n 0) (> current 1))
 183       (setq current (1- current))
 184       (if (string-match regexp (rmail-get-labels current))
 185           (setq lastwin current n (1+ n))))
 186     (if (< n 0)
 187         (error "No previous message with labels %s" labels)
 188       (if (> n 0)
 189           (error "No following message with labels %s" labels)
 190         (rmail-show-message-1 lastwin)))))
 191
 192 (provide 'rmailkwd)
 193
 194 ;; Local Variables:
 195 ;; generated-autoload-file: "rmail-loaddefs.el"
 196 ;; End:
 197
 198 ;;; rmailkwd.el ends here