![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to rmailkwd.el CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Apple XNU] / GNUtools / emacs / lisp|
Return to rmailkwd.el CVS log | Up to [Apple XNU] / GNUtools / emacs / lisp |
1.1 root 1: ;; "RMAIL" mail reader for Emacs.
2: ;; Copyright (C) 1985, 1988 Free Software Foundation, Inc.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is free software; you can redistribute it and/or modify
7: ;; it under the terms of the GNU General Public License as published by
8: ;; the Free Software Foundation; either version 1, or (at your option)
9: ;; any later version.
10:
11: ;; GNU Emacs is distributed in the hope that it will be useful,
12: ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13: ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14: ;; GNU General Public License for more details.
15:
16: ;; You should have received a copy of the GNU General Public License
17: ;; along with GNU Emacs; see the file COPYING. If not, write to
18: ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
19:
20:
21: ;; Global to all RMAIL buffers. It exists primarily for the sake of
22: ;; completion. It is better to use strings with the label functions
23: ;; and let them worry about making the label.
24:
25: (defvar rmail-label-obarray (make-vector 47 0))
26:
27: ;; Named list of symbols representing valid message attributes in RMAIL.
28:
29: (defconst rmail-attributes
30: (cons 'rmail-keywords
31: (mapcar '(lambda (s) (intern s rmail-label-obarray))
32: '("deleted" "answered" "filed" "forwarded" "unseen" "edited"))))
33:
34: (defconst rmail-deleted-label (intern "deleted" rmail-label-obarray))
35:
36: ;; Named list of symbols representing valid message keywords in RMAIL.
37:
38: (defvar rmail-keywords nil)
39:
40: (defun rmail-add-label (string)
41: "Add LABEL to labels associated with current RMAIL message.
42: Completion is performed over known labels when reading."
43: (interactive (list (rmail-read-label "Add label")))
44: (rmail-set-label string t))
45:
46: (defun rmail-kill-label (string)
47: "Remove LABEL from labels associated with current RMAIL message.
48: Completion is performed over known labels when reading."
49: (interactive (list (rmail-read-label "Remove label")))
50: (rmail-set-label string nil))
51:
52: (defun rmail-read-label (prompt)
53: (if (not rmail-keywords) (rmail-parse-file-keywords))
54: (let ((result
55: (completing-read (concat prompt
56: (if rmail-last-label
57: (concat " (default "
58: (symbol-name rmail-last-label)
59: "): ")
60: ": "))
61: rmail-label-obarray
62: nil
63: nil)))
64: (if (string= result "")
65: rmail-last-label
66: (setq rmail-last-label (rmail-make-label result t)))))
67:
68: (defun rmail-set-label (l state &optional n)
69: (rmail-maybe-set-message-counters)
70: (if (not n) (setq n rmail-current-message))
71: (aset rmail-summary-vector (1- n) nil)
72: (let* ((attribute (rmail-attribute-p l))
73: (keyword (and (not attribute)
74: (or (rmail-keyword-p l)
75: (rmail-install-keyword l))))
76: (label (or attribute keyword)))
77: (if label
78: (let ((omax (- (buffer-size) (point-max)))
79: (omin (- (buffer-size) (point-min)))
80: (buffer-read-only nil)
81: (case-fold-search t))
82: (unwind-protect
83: (save-excursion
84: (widen)
85: (goto-char (rmail-msgbeg n))
86: (forward-line 1)
87: (if (not (looking-at "[01],"))
88: nil
89: (let ((start (1+ (point)))
90: (bound))
91: (narrow-to-region (point) (progn (end-of-line) (point)))
92: (setq bound (point-max))
93: (search-backward ",," nil t)
94: (if attribute
95: (setq bound (1+ (point)))
96: (setq start (1+ (point))))
97: (goto-char start)
98: ; (while (re-search-forward "[ \t]*,[ \t]*" nil t)
99: ; (replace-match ","))
100: ; (goto-char start)
101: (if (re-search-forward
102: (concat ", " (rmail-quote-label-name label) ",")
103: bound
104: 'move)
105: (if (not state) (replace-match ","))
106: (if state (insert " " (symbol-name label) ",")))
107: (if (eq label rmail-deleted-label)
108: (rmail-set-message-deleted-p n state)))))
109: (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
110: (if (= n rmail-current-message) (rmail-display-labels)))))))
111:
112: ;; Commented functions aren't used by RMAIL but might be nice for user
113: ;; packages that do stuff with RMAIL. Note that rmail-message-labels-p
114: ;; is in rmailsum now.
115:
116: ;(defun rmail-message-attribute-p (attribute &optional n)
117: ; "Returns t if ATTRIBUTE on NTH or current message."
118: ; (rmail-message-labels-p (rmail-make-label attribute t) n))
119:
120: ;(defun rmail-message-keyword-p (keyword &optional n)
121: ; "Returns t if KEYWORD on NTH or current message."
122: ; (rmail-message-labels-p (rmail-make-label keyword t) n t))
123:
124: ;(defun rmail-message-label-p (label &optional n)
125: ; "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
126: ; (rmail-message-labels-p (rmail-make-label label t) n 'all))
127:
128: ;; Not used by RMAIL but might be nice for user package.
129:
130: ;(defun rmail-parse-message-labels (&optional n)
131: ; "Returns labels associated with NTH or current RMAIL message.
132: ;Results is a list of two lists. The first is the message attributes
133: ;and the second is the message keywords. Labels are represented as symbols."
134: ; (let ((omin (- (buffer-size) (point-min)))
135: ; (omax (- (buffer-size) (point-max)))
136: ; (result))
137: ; (unwind-protect
138: ; (save-excursion
139: ; (let ((beg (rmail-msgbeg (or n rmail-current-message))))
140: ; (widen)
141: ; (goto-char beg)
142: ; (forward-line 1)
143: ; (if (looking-at "[01],")
144: ; (save-restriction
145: ; (narrow-to-region (point) (save-excursion (end-of-line) (point)))
146: ; (rmail-nuke-whitespace)
147: ; (goto-char (1+ (point-min)))
148: ; (list (mail-parse-comma-list) (mail-parse-comma-list))))))
149: ; (narrow-to-region (- (buffer-size) omin)
150: ; (- (buffer-size) omax))
151: ; nil)))
152:
153: (defun rmail-attribute-p (s)
154: (let ((symbol (rmail-make-label s)))
155: (if (memq symbol (cdr rmail-attributes)) symbol)))
156:
157: (defun rmail-keyword-p (s)
158: (let ((symbol (rmail-make-label s)))
159: (if (memq symbol (cdr (rmail-keywords))) symbol)))
160:
161: (defun rmail-make-label (s &optional forcep)
162: (cond ((symbolp s) s)
163: (forcep (intern (downcase s) rmail-label-obarray))
164: (t (intern-soft (downcase s) rmail-label-obarray))))
165:
166: (defun rmail-force-make-label (s)
167: (intern (downcase s) rmail-label-obarray))
168:
169: (defun rmail-quote-label-name (label)
170: (regexp-quote (symbol-name (rmail-make-label label t))))
171:
172: ;; Motion on messages with keywords.
173:
174: (defun rmail-previous-labeled-message (n label)
175: "Show previous message with LABEL. Defaults to last labels used.
176: With prefix argument N moves backward N messages with these labels."
177: (interactive "p\nsMove to previous msg with labels: ")
178: (rmail-next-labeled-message (- n) label))
179:
180: (defun rmail-next-labeled-message (n labels)
181: "Show next message with LABEL. Defaults to last labels used.
182: With 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))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.