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,
   4 ;;   2005, 2006, 2007 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, or (at your option)
  14 ;; 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; see the file COPYING.  If not, write to the
  23 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  24 ;; Boston, MA 02110-1301, USA.
  25
  26 ;;; Commentary:
  27
  28 ;;; Code:
  29
  30 (defvar rmail-buffer)
  31 (defvar rmail-current-message)
  32 (defvar rmail-last-label)
  33 (defvar rmail-last-multi-labels)
  34 (defvar rmail-summary-vector)
  35 (defvar rmail-total-messages)
  36
  37 ;; Global to all RMAIL buffers.  It exists primarily for the sake of
  38 ;; completion.  It is better to use strings with the label functions
  39 ;; and let them worry about making the label.
  40
  41 (defvar rmail-label-obarray (make-vector 47 0))
  42
  43 ;; Named list of symbols representing valid message attributes in RMAIL.
  44
  45 (defconst rmail-attributes
  46   (cons 'rmail-keywords
  47         (mapcar (function (lambda (s) (intern s rmail-label-obarray)))
  48                 '("deleted" "answered" "filed" "forwarded" "unseen" "edited"
  49                   "resent"))))
  50
  51 (defconst rmail-deleted-label (intern "deleted" rmail-label-obarray))
  52
  53 ;; Named list of symbols representing valid message keywords in RMAIL.
  54
  55 (defvar rmail-keywords)
  56 \f
  57 ;;;###autoload
  58 (defun rmail-add-label (string)
  59   "Add LABEL to labels associated with current RMAIL message.
  60 Completion is performed over known labels when reading."
  61   (interactive (list (rmail-read-label "Add label")))
  62   (rmail-set-label string t))
  63
  64 ;;;###autoload
  65 (defun rmail-kill-label (string)
  66   "Remove LABEL from labels associated with current RMAIL message.
  67 Completion is performed over known labels when reading."
  68   (interactive (list (rmail-read-label "Remove label")))
  69   (rmail-set-label string nil))
  70
  71 ;;;###autoload
  72 (defun rmail-read-label (prompt)
  73   (with-current-buffer rmail-buffer
  74     (if (not rmail-keywords) (rmail-parse-file-keywords))
  75     (let ((result
  76            (completing-read (concat prompt
  77                                     (if rmail-last-label
  78                                         (concat " (default "
  79                                                 (symbol-name rmail-last-label)
  80                                                 "): ")
  81                                       ": "))
  82                             rmail-label-obarray
  83                             nil
  84                             nil)))
  85       (if (string= result "")
  86           rmail-last-label
  87         (setq rmail-last-label (rmail-make-label result t))))))
  88
  89 (declare-function rmail-maybe-set-message-counters "rmail" ())
  90 (declare-function rmail-display-labels "rmail" ())
  91 (declare-function rmail-msgbeg "rmail" (n))
  92 (declare-function rmail-set-message-deleted-p "rmail" (n state))
  93 (declare-function rmail-message-labels-p "rmail" (msg labels))
  94 (declare-function rmail-show-message "rmail" (&optional n no-summary))
  95 (declare-function mail-comma-list-regexp "mail-utils" (labels))
  96 (declare-function mail-parse-comma-list "mail-utils.el" ())
  97
  98 (defun rmail-set-label (l state &optional n)
  99   (with-current-buffer rmail-buffer
 100     (rmail-maybe-set-message-counters)
 101     (if (not n) (setq n rmail-current-message))
 102     (aset rmail-summary-vector (1- n) nil)
 103     (let* ((attribute (rmail-attribute-p l))
 104            (keyword (and (not attribute)
 105                          (or (rmail-keyword-p l)
 106                              (rmail-install-keyword l))))
 107            (label (or attribute keyword)))
 108       (if label
 109           (let ((omax (- (buffer-size) (point-max)))
 110                 (omin (- (buffer-size) (point-min)))
 111                 (buffer-read-only nil)
 112                 (case-fold-search t))
 113             (unwind-protect
 114                 (save-excursion
 115                   (widen)
 116                   (goto-char (rmail-msgbeg n))
 117                   (forward-line 1)
 118                   (if (not (looking-at "[01],"))
 119                       nil
 120                     (let ((start (1+ (point)))
 121                           (bound))
 122                       (narrow-to-region (point) (progn (end-of-line) (point)))
 123                       (setq bound (point-max))
 124                       (search-backward ",," nil t)
 125                       (if attribute
 126                           (setq bound (1+ (point)))
 127                         (setq start (1+ (point))))
 128                       (goto-char start)
 129 ;                     (while (re-search-forward "[ \t]*,[ \t]*" nil t)
 130 ;                       (replace-match ","))
 131 ;                     (goto-char start)
 132                       (if (re-search-forward
 133                            (concat ", " (rmail-quote-label-name label) ",")
 134                            bound
 135                            'move)
 136                           (if (not state) (replace-match ","))
 137                         (if state (insert " " (symbol-name label) ",")))
 138                       (if (eq label rmail-deleted-label)
 139                           (rmail-set-message-deleted-p n state)))))
 140               (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
 141               (if (= n rmail-current-message) (rmail-display-labels))))))))
 142 \f
 143 ;; Commented functions aren't used by RMAIL but might be nice for user
 144 ;; packages that do stuff with RMAIL.  Note that rmail-message-labels-p
 145 ;; is in rmail.el now.
 146
 147 ;(defun rmail-message-label-p (label &optional n)
 148 ;  "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
 149 ;  (rmail-message-labels-p (or n rmail-current-message) (regexp-quote label)))
 150
 151 ;(defun rmail-parse-message-labels (&optional n)
 152 ;  "Returns labels associated with NTH or current RMAIL message.
 153 ;The result is a list of two lists of strings.  The first is the
 154 ;message attributes and the second is the message keywords."
 155 ;  (let (atts keys)
 156 ;    (save-restriction
 157 ;      (widen)
 158 ;      (goto-char (rmail-msgbeg (or n rmail-current-message)))
 159 ;      (forward-line 1)
 160 ;      (or (looking-at "[01],") (error "Malformed label line"))
 161 ;      (forward-char 2)
 162 ;      (while (looking-at "[ \t]*\\([^ \t\n,]+\\),")
 163 ;       (setq atts (cons (buffer-substring (match-beginning 1) (match-end 1))
 164 ;                         atts))
 165 ;       (goto-char (match-end 0)))
 166 ;      (or (looking-at ",") (error "Malformed label line"))
 167 ;      (forward-char 1)
 168 ;      (while (looking-at "[ \t]*\\([^ \t\n,]+\\),")
 169 ;       (setq keys (cons (buffer-substring (match-beginning 1) (match-end 1))
 170 ;                        keys))
 171 ;       (goto-char (match-end 0)))
 172 ;      (or (looking-at "[ \t]*$") (error "Malformed label line"))
 173 ;      (list (nreverse atts) (nreverse keys)))))
 174
 175 (defun rmail-attribute-p (s)
 176   (let ((symbol (rmail-make-label s)))
 177     (if (memq symbol (cdr rmail-attributes)) symbol)))
 178
 179 (defun rmail-keyword-p (s)
 180   (let ((symbol (rmail-make-label s)))
 181     (if (memq symbol (cdr (rmail-keywords))) symbol)))
 182
 183 (defun rmail-make-label (s &optional forcep)
 184   (cond ((symbolp s) s)
 185         (forcep (intern (downcase s) rmail-label-obarray))
 186         (t  (intern-soft (downcase s) rmail-label-obarray))))
 187
 188 (defun rmail-force-make-label (s)
 189   (intern (downcase s) rmail-label-obarray))
 190
 191 (defun rmail-quote-label-name (label)
 192   (regexp-quote (symbol-name (rmail-make-label label t))))
 193 \f
 194 ;; Motion on messages with keywords.
 195
 196 ;;;###autoload
 197 (defun rmail-previous-labeled-message (n labels)
 198   "Show previous message with one of the labels LABELS.
 199 LABELS should be a comma-separated list of label names.
 200 If LABELS is empty, the last set of labels specified is used.
 201 With prefix argument N moves backward N messages with these labels."
 202   (interactive "p\nsMove to previous msg with labels: ")
 203   (rmail-next-labeled-message (- n) labels))
 204
 205 ;;;###autoload
 206 (defun rmail-next-labeled-message (n labels)
 207   "Show next message with one of the labels LABELS.
 208 LABELS should be a comma-separated list of label names.
 209 If LABELS is empty, the last set of labels specified is used.
 210 With prefix argument N moves forward N messages with these labels."
 211   (interactive "p\nsMove to next msg with labels: ")
 212   (if (string= labels "")
 213       (setq labels rmail-last-multi-labels))
 214   (or labels
 215       (error "No labels to find have been specified previously"))
 216   (set-buffer rmail-buffer)
 217   (setq rmail-last-multi-labels labels)
 218   (rmail-maybe-set-message-counters)
 219   (let ((lastwin rmail-current-message)
 220         (current rmail-current-message)
 221         (regexp (concat ", ?\\("
 222                         (mail-comma-list-regexp labels)
 223                         "\\),")))
 224     (save-restriction
 225       (widen)
 226       (while (and (> n 0) (< current rmail-total-messages))
 227         (setq current (1+ current))
 228         (if (rmail-message-labels-p current regexp)
 229             (setq lastwin current n (1- n))))
 230       (while (and (< n 0) (> current 1))
 231         (setq current (1- current))
 232         (if (rmail-message-labels-p current regexp)
 233             (setq lastwin current n (1+ n)))))
 234     (rmail-show-message lastwin)
 235     (if (< n 0)
 236         (message "No previous message with labels %s" labels))
 237     (if (> n 0)
 238         (message "No following message with labels %s" labels))))
 239 \f
 240 ;;; Manipulate the file's Labels option.
 241
 242 ;; Return a list of symbols for all
 243 ;; the keywords (labels) recorded in this file's Labels option.
 244 (defun rmail-keywords ()
 245   (or rmail-keywords (rmail-parse-file-keywords)))
 246
 247 ;; Set rmail-keywords to a list of symbols for all
 248 ;; the keywords (labels) recorded in this file's Labels option.
 249 (defun rmail-parse-file-keywords ()
 250   (save-restriction
 251     (save-excursion
 252       (widen)
 253       (goto-char 1)
 254       (setq rmail-keywords
 255             (if (search-forward "\nLabels:" (rmail-msgbeg 1) t)
 256                 (progn
 257                   (narrow-to-region (point) (progn (end-of-line) (point)))
 258                   (goto-char (point-min))
 259                   (cons 'rmail-keywords
 260                         (mapcar 'rmail-force-make-label
 261                                 (mail-parse-comma-list)))))))))
 262
 263 ;; Add WORD to the list in the file's Labels option.
 264 ;; Any keyword used for the first time needs this done.
 265 (defun rmail-install-keyword (word)
 266   (let ((keyword (rmail-make-label word t))
 267         (keywords (rmail-keywords)))
 268     (if (not (or (rmail-attribute-p keyword)
 269                  (rmail-keyword-p keyword)))
 270         (let ((omin (- (buffer-size) (point-min)))
 271               (omax (- (buffer-size) (point-max))))
 272           (unwind-protect
 273               (save-excursion
 274                 (widen)
 275                 (goto-char 1)
 276                 (let ((case-fold-search t)
 277                       (buffer-read-only nil))
 278                   (or (search-forward "\nLabels:" nil t)
 279                       (progn
 280                         (end-of-line)
 281                         (insert "\nLabels:")))
 282                   (delete-region (point) (progn (end-of-line) (point)))
 283                   (setcdr keywords (cons keyword (cdr keywords)))
 284                   (while (setq keywords (cdr keywords))
 285                     (insert (symbol-name (car keywords)) ","))
 286                   (delete-char -1)))
 287             (narrow-to-region (- (buffer-size) omin)
 288                               (- (buffer-size) omax)))))
 289     keyword))
 290
 291 ;;; arch-tag: b26b3392-99ca-4e1d-933a-dab59b04e9a8
 292 ;;; rmailkwd.el ends here