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