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 2, 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 57;;;###autoload 58(defun rmail-add-label (string) 59 "Add LABEL to labels associated with current RMAIL message. 60Completion 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. 67Completion 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(defun rmail-set-label (l state &optional n) 90 (with-current-buffer rmail-buffer 91 (rmail-maybe-set-message-counters) 92 (if (not n) (setq n rmail-current-message)) 93 (aset rmail-summary-vector (1- n) nil) 94 (let* ((attribute (rmail-attribute-p l)) 95 (keyword (and (not attribute) 96 (or (rmail-keyword-p l) 97 (rmail-install-keyword l)))) 98 (label (or attribute keyword))) 99 (if label 100 (let ((omax (- (buffer-size) (point-max))) 101 (omin (- (buffer-size) (point-min))) 102 (buffer-read-only nil) 103 (case-fold-search t)) 104 (unwind-protect 105 (save-excursion 106 (widen) 107 (goto-char (rmail-msgbeg n)) 108 (forward-line 1) 109 (if (not (looking-at "[01],")) 110 nil 111 (let ((start (1+ (point))) 112 (bound)) 113 (narrow-to-region (point) (progn (end-of-line) (point))) 114 (setq bound (point-max)) 115 (search-backward ",," nil t) 116 (if attribute 117 (setq bound (1+ (point))) 118 (setq start (1+ (point)))) 119 (goto-char start) 120; (while (re-search-forward "[ \t]*,[ \t]*" nil t) 121; (replace-match ",")) 122; (goto-char start) 123 (if (re-search-forward 124 (concat ", " (rmail-quote-label-name label) ",") 125 bound 126 'move) 127 (if (not state) (replace-match ",")) 128 (if state (insert " " (symbol-name label) ","))) 129 (if (eq label rmail-deleted-label) 130 (rmail-set-message-deleted-p n state))))) 131 (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax)) 132 (if (= n rmail-current-message) (rmail-display-labels)))))))) 133 134;; Commented functions aren't used by RMAIL but might be nice for user 135;; packages that do stuff with RMAIL. Note that rmail-message-labels-p 136;; is in rmail.el now. 137 138;(defun rmail-message-label-p (label &optional n) 139; "Returns symbol if LABEL (attribute or keyword) on NTH or current message." 140; (rmail-message-labels-p (or n rmail-current-message) (regexp-quote label))) 141 142;(defun rmail-parse-message-labels (&optional n) 143; "Returns labels associated with NTH or current RMAIL message. 144;The result is a list of two lists of strings. The first is the 145;message attributes and the second is the message keywords." 146; (let (atts keys) 147; (save-restriction 148; (widen) 149; (goto-char (rmail-msgbeg (or n rmail-current-message))) 150; (forward-line 1) 151; (or (looking-at "[01],") (error "Malformed label line")) 152; (forward-char 2) 153; (while (looking-at "[ \t]*\\([^ \t\n,]+\\),") 154; (setq atts (cons (buffer-substring (match-beginning 1) (match-end 1)) 155; atts)) 156; (goto-char (match-end 0))) 157; (or (looking-at ",") (error "Malformed label line")) 158; (forward-char 1) 159; (while (looking-at "[ \t]*\\([^ \t\n,]+\\),") 160; (setq keys (cons (buffer-substring (match-beginning 1) (match-end 1)) 161; keys)) 162; (goto-char (match-end 0))) 163; (or (looking-at "[ \t]*$") (error "Malformed label line")) 164; (list (nreverse atts) (nreverse keys))))) 165 166(defun rmail-attribute-p (s) 167 (let ((symbol (rmail-make-label s))) 168 (if (memq symbol (cdr rmail-attributes)) symbol))) 169 170(defun rmail-keyword-p (s) 171 (let ((symbol (rmail-make-label s))) 172 (if (memq symbol (cdr (rmail-keywords))) symbol))) 173 174(defun rmail-make-label (s &optional forcep) 175 (cond ((symbolp s) s) 176 (forcep (intern (downcase s) rmail-label-obarray)) 177 (t (intern-soft (downcase s) rmail-label-obarray)))) 178 179(defun rmail-force-make-label (s) 180 (intern (downcase s) rmail-label-obarray)) 181 182(defun rmail-quote-label-name (label) 183 (regexp-quote (symbol-name (rmail-make-label label t)))) 184 185;; Motion on messages with keywords. 186 187;;;###autoload 188(defun rmail-previous-labeled-message (n labels) 189 "Show previous message with one of the labels LABELS. 190LABELS should be a comma-separated list of label names. 191If LABELS is empty, the last set of labels specified is used. 192With prefix argument N moves backward N messages with these labels." 193 (interactive "p\nsMove to previous msg with labels: ") 194 (rmail-next-labeled-message (- n) labels)) 195 196;;;###autoload 197(defun rmail-next-labeled-message (n labels) 198 "Show next message with one of the labels LABELS. 199LABELS should be a comma-separated list of label names. 200If LABELS is empty, the last set of labels specified is used. 201With prefix argument N moves forward N messages with these labels." 202 (interactive "p\nsMove to next msg with labels: ") 203 (if (string= labels "") 204 (setq labels rmail-last-multi-labels)) 205 (or labels 206 (error "No labels to find have been specified previously")) 207 (set-buffer rmail-buffer) 208 (setq rmail-last-multi-labels labels) 209 (rmail-maybe-set-message-counters) 210 (let ((lastwin rmail-current-message) 211 (current rmail-current-message) 212 (regexp (concat ", ?\\(" 213 (mail-comma-list-regexp labels) 214 "\\),"))) 215 (save-restriction 216 (widen) 217 (while (and (> n 0) (< current rmail-total-messages)) 218 (setq current (1+ current)) 219 (if (rmail-message-labels-p current regexp) 220 (setq lastwin current n (1- n)))) 221 (while (and (< n 0) (> current 1)) 222 (setq current (1- current)) 223 (if (rmail-message-labels-p current regexp) 224 (setq lastwin current n (1+ n))))) 225 (rmail-show-message lastwin) 226 (if (< n 0) 227 (message "No previous message with labels %s" labels)) 228 (if (> n 0) 229 (message "No following message with labels %s" labels)))) 230 231;;; Manipulate the file's Labels option. 232 233;; Return a list of symbols for all 234;; the keywords (labels) recorded in this file's Labels option. 235(defun rmail-keywords () 236 (or rmail-keywords (rmail-parse-file-keywords))) 237 238;; Set rmail-keywords to a list of symbols for all 239;; the keywords (labels) recorded in this file's Labels option. 240(defun rmail-parse-file-keywords () 241 (save-restriction 242 (save-excursion 243 (widen) 244 (goto-char 1) 245 (setq rmail-keywords 246 (if (search-forward "\nLabels:" (rmail-msgbeg 1) t) 247 (progn 248 (narrow-to-region (point) (progn (end-of-line) (point))) 249 (goto-char (point-min)) 250 (cons 'rmail-keywords 251 (mapcar 'rmail-force-make-label 252 (mail-parse-comma-list))))))))) 253 254;; Add WORD to the list in the file's Labels option. 255;; Any keyword used for the first time needs this done. 256(defun rmail-install-keyword (word) 257 (let ((keyword (rmail-make-label word t)) 258 (keywords (rmail-keywords))) 259 (if (not (or (rmail-attribute-p keyword) 260 (rmail-keyword-p keyword))) 261 (let ((omin (- (buffer-size) (point-min))) 262 (omax (- (buffer-size) (point-max)))) 263 (unwind-protect 264 (save-excursion 265 (widen) 266 (goto-char 1) 267 (let ((case-fold-search t) 268 (buffer-read-only nil)) 269 (or (search-forward "\nLabels:" nil t) 270 (progn 271 (end-of-line) 272 (insert "\nLabels:"))) 273 (delete-region (point) (progn (end-of-line) (point))) 274 (setcdr keywords (cons keyword (cdr keywords))) 275 (while (setq keywords (cdr keywords)) 276 (insert (symbol-name (car keywords)) ",")) 277 (delete-char -1))) 278 (narrow-to-region (- (buffer-size) omin) 279 (- (buffer-size) omax))))) 280 keyword)) 281 282;;; arch-tag: b26b3392-99ca-4e1d-933a-dab59b04e9a8 283;;; rmailkwd.el ends here 284