1;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs. 2 3;; Copyright (C) 1985, 1988, 1994 Free Software Foundation, Inc. 4 5;; Maintainer: FSF 6;; Keywords: mail 7 8;; This file is part of GNU Emacs. 9 10;; GNU Emacs is free software; you can redistribute it and/or modify 11;; it under the terms of the GNU General Public License as published by 12;; the Free Software Foundation; either version 2, or (at your option) 13;; any later version. 14 15;; GNU Emacs is distributed in the hope that it will be useful, 16;; but WITHOUT ANY WARRANTY; without even the implied warranty of 17;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 18;; GNU General Public License for more details. 19 20;; You should have received a copy of the GNU General Public License 21;; along with GNU Emacs; see the file COPYING. If not, write to 22;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 23 24;;; Code: 25 26;; Global to all RMAIL buffers. It exists primarily for the sake of 27;; completion. It is better to use strings with the label functions 28;; and let them worry about making the label. 29 30(defvar rmail-label-obarray (make-vector 47 0)) 31 32;; Named list of symbols representing valid message attributes in RMAIL. 33 34(defconst rmail-attributes 35 (cons 'rmail-keywords 36 (mapcar '(lambda (s) (intern s rmail-label-obarray)) 37 '("deleted" "answered" "filed" "forwarded" "unseen" "edited")))) 38 39(defconst rmail-deleted-label (intern "deleted" rmail-label-obarray)) 40 41;; Named list of symbols representing valid message keywords in RMAIL. 42 43(defvar rmail-keywords nil) 44 45(defun rmail-add-label (string) 46 "Add LABEL to labels associated with current RMAIL message. 47Completion is performed over known labels when reading." 48 (interactive (list (rmail-read-label "Add label"))) 49 (rmail-set-label string t)) 50 51(defun rmail-kill-label (string) 52 "Remove LABEL from labels associated with current RMAIL message. 53Completion is performed over known labels when reading." 54 (interactive (list (rmail-read-label "Remove label"))) 55 (rmail-set-label string nil)) 56 57(defun rmail-read-label (prompt) 58 (if (not rmail-keywords) (rmail-parse-file-keywords)) 59 (let ((result 60 (completing-read (concat prompt 61 (if rmail-last-label 62 (concat " (default " 63 (symbol-name rmail-last-label) 64 "): ") 65 ": ")) 66 rmail-label-obarray 67 nil 68 nil))) 69 (if (string= result "") 70 rmail-last-label 71 (setq rmail-last-label (rmail-make-label result t))))) 72 73(defun rmail-set-label (l state &optional n) 74 (rmail-maybe-set-message-counters) 75 (if (not n) (setq n rmail-current-message)) 76 (aset rmail-summary-vector (1- n) nil) 77 (let* ((attribute (rmail-attribute-p l)) 78 (keyword (and (not attribute) 79 (or (rmail-keyword-p l) 80 (rmail-install-keyword l)))) 81 (label (or attribute keyword))) 82 (if label 83 (let ((omax (- (buffer-size) (point-max))) 84 (omin (- (buffer-size) (point-min))) 85 (buffer-read-only nil) 86 (case-fold-search t)) 87 (unwind-protect 88 (save-excursion 89 (widen) 90 (goto-char (rmail-msgbeg n)) 91 (forward-line 1) 92 (if (not (looking-at "[01],")) 93 nil 94 (let ((start (1+ (point))) 95 (bound)) 96 (narrow-to-region (point) (progn (end-of-line) (point))) 97 (setq bound (point-max)) 98 (search-backward ",," nil t) 99 (if attribute 100 (setq bound (1+ (point))) 101 (setq start (1+ (point)))) 102 (goto-char start) 103; (while (re-search-forward "[ \t]*,[ \t]*" nil t) 104; (replace-match ",")) 105; (goto-char start) 106 (if (re-search-forward 107 (concat ", " (rmail-quote-label-name label) ",") 108 bound 109 'move) 110 (if (not state) (replace-match ",")) 111 (if state (insert " " (symbol-name label) ","))) 112 (if (eq label rmail-deleted-label) 113 (rmail-set-message-deleted-p n state))))) 114 (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax)) 115 (if (= n rmail-current-message) (rmail-display-labels))))))) 116 117;; Commented functions aren't used by RMAIL but might be nice for user 118;; packages that do stuff with RMAIL. Note that rmail-message-labels-p 119;; is in rmail.el now. 120 121;(defun rmail-message-label-p (label &optional n) 122; "Returns symbol if LABEL (attribute or keyword) on NTH or current message." 123; (rmail-message-labels-p (or n rmail-current-message) (regexp-quote label))) 124 125;(defun rmail-parse-message-labels (&optional n) 126; "Returns labels associated with NTH or current RMAIL message. 127;The result is a list of two lists of strings. The first is the 128;message attributes and the second is the message keywords." 129; (let (atts keys) 130; (save-restriction 131; (widen) 132; (goto-char (rmail-msgbeg (or n rmail-current-message))) 133; (forward-line 1) 134; (or (looking-at "[01],") (error "Malformed label line")) 135; (forward-char 2) 136; (while (looking-at "[ \t]*\\([^ \t\n,]+\\),") 137; (setq atts (cons (buffer-substring (match-beginning 1) (match-end 1)) 138; atts)) 139; (goto-char (match-end 0))) 140; (or (looking-at ",") (error "Malformed label line")) 141; (forward-char 1) 142; (while (looking-at "[ \t]*\\([^ \t\n,]+\\),") 143; (setq keys (cons (buffer-substring (match-beginning 1) (match-end 1)) 144; keys)) 145; (goto-char (match-end 0))) 146; (or (looking-at "[ \t]*$") (error "Malformed label line")) 147; (list (nreverse atts) (nreverse keys))))) 148 149(defun rmail-attribute-p (s) 150 (let ((symbol (rmail-make-label s))) 151 (if (memq symbol (cdr rmail-attributes)) symbol))) 152 153(defun rmail-keyword-p (s) 154 (let ((symbol (rmail-make-label s))) 155 (if (memq symbol (cdr (rmail-keywords))) symbol))) 156 157(defun rmail-make-label (s &optional forcep) 158 (cond ((symbolp s) s) 159 (forcep (intern (downcase s) rmail-label-obarray)) 160 (t (intern-soft (downcase s) rmail-label-obarray)))) 161 162(defun rmail-force-make-label (s) 163 (intern (downcase s) rmail-label-obarray)) 164 165(defun rmail-quote-label-name (label) 166 (regexp-quote (symbol-name (rmail-make-label label t)))) 167 168;; Motion on messages with keywords. 169 170(defun rmail-previous-labeled-message (n labels) 171 "Show previous message with one of the labels LABELS. 172LABELS should be a comma-separated list of label names. 173If LABELS is empty, the last set of labels specified is used. 174With prefix argument N moves backward N messages with these labels." 175 (interactive "p\nsMove to previous msg with labels: ") 176 (rmail-next-labeled-message (- n) labels)) 177 178(defun rmail-next-labeled-message (n labels) 179 "Show next message with one of the labels LABELS. 180LABELS should be a comma-separated list of label names. 181If LABELS is empty, the last set of labels specified is used. 182With prefix argument N moves forward N messages with these labels." 183 (interactive "p\nsMove to next msg with labels: ") 184 (if (string= labels "") 185 (setq labels rmail-last-multi-labels)) 186 (or labels 187 (error "No labels to find have been specified previously")) 188 (setq rmail-last-multi-labels labels) 189 (rmail-maybe-set-message-counters) 190 (let ((lastwin rmail-current-message) 191 (current rmail-current-message) 192 (regexp (concat ", ?\\(" 193 (mail-comma-list-regexp labels) 194 "\\),"))) 195 (save-restriction 196 (widen) 197 (while (and (> n 0) (< current rmail-total-messages)) 198 (setq current (1+ current)) 199 (if (rmail-message-labels-p current regexp) 200 (setq lastwin current n (1- n)))) 201 (while (and (< n 0) (> current 1)) 202 (setq current (1- current)) 203 (if (rmail-message-labels-p current regexp) 204 (setq lastwin current n (1+ n))))) 205 (rmail-show-message lastwin) 206 (if (< n 0) 207 (message "No previous message with labels %s" labels)) 208 (if (> n 0) 209 (message "No following message with labels %s" labels)))) 210 211;;; Manipulate the file's Labels option. 212 213;; Return a list of symbols for all 214;; the keywords (labels) recorded in this file's Labels option. 215(defun rmail-keywords () 216 (or rmail-keywords (rmail-parse-file-keywords))) 217 218;; Set rmail-keywords to a list of symbols for all 219;; the keywords (labels) recorded in this file's Labels option. 220(defun rmail-parse-file-keywords () 221 (save-restriction 222 (save-excursion 223 (widen) 224 (goto-char 1) 225 (setq rmail-keywords 226 (if (search-forward "\nLabels:" (rmail-msgbeg 1) t) 227 (progn 228 (narrow-to-region (point) (progn (end-of-line) (point))) 229 (goto-char (point-min)) 230 (cons 'rmail-keywords 231 (mapcar 'rmail-force-make-label 232 (mail-parse-comma-list))))))))) 233 234;; Add WORD to the list in the file's Labels option. 235;; Any keyword used for the first time needs this done. 236(defun rmail-install-keyword (word) 237 (let ((keyword (rmail-make-label word t)) 238 (keywords (rmail-keywords))) 239 (if (not (or (rmail-attribute-p keyword) 240 (rmail-keyword-p keyword))) 241 (let ((omin (- (buffer-size) (point-min))) 242 (omax (- (buffer-size) (point-max)))) 243 (unwind-protect 244 (save-excursion 245 (widen) 246 (goto-char 1) 247 (let ((case-fold-search t) 248 (buffer-read-only nil)) 249 (or (search-forward "\nLabels:" nil t) 250 (progn 251 (end-of-line) 252 (insert "\nLabels:"))) 253 (delete-region (point) (progn (end-of-line) (point))) 254 (setcdr keywords (cons keyword (cdr keywords))) 255 (while (setq keywords (cdr keywords)) 256 (insert (symbol-name (car keywords)) ",")) 257 (delete-char -1))) 258 (narrow-to-region (- (buffer-size) omin) 259 (- (buffer-size) omax))))) 260 keyword)) 261 262;;; rmailkwd.el ends here 263