![[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 [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp|
Return to rmailkwd.el CVS log | Up to [CSRG BSD Unix] / 43BSD / contrib / emacs / lisp |
1.1 root 1: ;; "RMAIL" mail reader for Emacs.
2: ;; Copyright (C) 1985 Richard M. Stallman.
3:
4: ;; This file is part of GNU Emacs.
5:
6: ;; GNU Emacs is distributed in the hope that it will be useful,
7: ;; but WITHOUT ANY WARRANTY. No author or distributor
8: ;; accepts responsibility to anyone for the consequences of using it
9: ;; or for whether it serves any particular purpose or works at all,
10: ;; unless he says so in writing. Refer to the GNU Emacs General Public
11: ;; License for full details.
12:
13: ;; Everyone is granted permission to copy, modify and redistribute
14: ;; GNU Emacs, but only under the conditions described in the
15: ;; GNU Emacs General Public License. A copy of this license is
16: ;; supposed to have been given to you along with GNU Emacs so you
17: ;; can know your rights and responsibilities. It should be in a
18: ;; file named COPYING. Among other things, the copyright notice
19: ;; and this notice must be preserved on all copies.
20:
21:
22: ;; Global to all RMAIL buffers. It exists primarily for the sake of
23: ;; completion. It is better to use strings with the label functions
24: ;; and let them worry about making the label.
25:
26: (defvar rmail-label-obarray (make-vector 47 0))
27:
28: ;; Named list of symbols representing valid message attributes in RMAIL.
29:
30: (defconst rmail-attributes
31: (cons 'rmail-keywords
32: (mapcar '(lambda (s) (intern s rmail-label-obarray))
33: '("deleted" "answered" "filed" "forwarded" "unseen"))))
34:
35: (defconst rmail-deleted-label (intern "deleted" rmail-label-obarray))
36:
37: ;; Named list of symbols representing valid message keywords in RMAIL.
38:
39: (defvar rmail-keywords nil)
40:
41: (defun rmail-add-label (string)
42: "Add LABEL to labels associated with current RMAIL message.
43: Completion is performed over known labels when reading."
44: (interactive (list (rmail-read-label "Add label")))
45: (rmail-set-label string t))
46:
47: (defun rmail-kill-label (string)
48: "Remove LABEL from labels associated with current RMAIL message.
49: Completion is performed over known labels when reading."
50: (interactive (list (rmail-read-label "Remove label")))
51: (rmail-set-label string nil))
52:
53: (defun rmail-read-label (prompt)
54: (if (not rmail-keywords) (rmail-parse-file-keywords))
55: (let ((result
56: (completing-read (concat prompt
57: (if rmail-last-label
58: (concat " (default "
59: (symbol-name rmail-last-label)
60: "): ")
61: ": "))
62: rmail-label-obarray
63: nil
64: nil)))
65: (if (string= result "")
66: rmail-last-label
67: (setq rmail-last-label (rmail-make-label result t)))))
68:
69: (defun rmail-set-label (l state &optional n)
70: (rmail-maybe-set-message-counters)
71: (if (not n) (setq n rmail-current-message))
72: (aset rmail-summary-vector (1- n) nil)
73: (let* ((attribute (rmail-attribute-p l))
74: (keyword (and (not attribute)
75: (or (rmail-keyword-p l)
76: (rmail-install-keyword l))))
77: (label (or attribute keyword)))
78: (if label
79: (let ((omax (- (buffer-size) (point-max)))
80: (omin (- (buffer-size) (point-min)))
81: (buffer-read-only nil)
82: (case-fold-search t))
83: (unwind-protect
84: (save-excursion
85: (widen)
86: (goto-char (rmail-msgbeg n))
87: (forward-line 1)
88: (if (not (looking-at "[01],"))
89: nil
90: (let ((start (1+ (point)))
91: (bound))
92: (narrow-to-region (point) (progn (end-of-line) (point)))
93: (setq bound (point-max))
94: (search-backward ",," nil t)
95: (if attribute
96: (setq bound (1+ (point)))
97: (setq start (1+ (point))))
98: (goto-char start)
99: (rmail-nuke-whitespace)
100: (if (re-search-forward
101: (concat "," (rmail-quote-label-name label) ",")
102: bound
103: 'move)
104: (if (not state) (replace-match ","))
105: (if state (insert (symbol-name label) ",")))
106: (if (eq label rmail-deleted-label)
107: (rmail-set-message-deleted-p n state)))))
108: (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
109: (if (= n rmail-current-message) (rmail-display-labels)))))))
110:
111: ;; Commented functions aren't used by RMAIL but might be nice for user
112: ;; packages that do stuff with RMAIL. Note that rmail-message-labels-p
113: ;; is in rmailsum now.
114:
115: ;(defun rmail-message-attribute-p (attribute &optional n)
116: ; "Returns t if ATTRIBUTE on NTH or current message."
117: ; (rmail-message-labels-p (rmail-make-label attribute t) n))
118:
119: ;(defun rmail-message-keyword-p (keyword &optional n)
120: ; "Returns t if KEYWORD on NTH or current message."
121: ; (rmail-message-labels-p (rmail-make-label keyword t) n t))
122:
123: ;(defun rmail-message-label-p (label &optional n)
124: ; "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
125: ; (rmail-message-labels-p (rmail-make-label label t) n 'all))
126:
127: ;; Not used by RMAIL but might be nice for user package.
128:
129: ;(defun rmail-parse-message-labels (&optional n)
130: ; "Returns labels associated with NTH or current RMAIL message.
131: ;Results is a list of two lists. The first is the message attributes
132: ;and the second is the message keywords. Labels are represented as symbols."
133: ; (let ((omin (- (buffer-size) (point-min)))
134: ; (omax (- (buffer-size) (point-max)))
135: ; (result))
136: ; (unwind-protect
137: ; (save-excursion
138: ; (let ((beg (rmail-msgbeg (or n rmail-current-message))))
139: ; (widen)
140: ; (goto-char beg)
141: ; (forward-line 1)
142: ; (if (looking-at "[01],")
143: ; (save-restriction
144: ; (narrow-to-region (point) (save-excursion (end-of-line) (point)))
145: ; (rmail-nuke-whitespace)
146: ; (goto-char (1+ (point-min)))
147: ; (list (mail-parse-comma-list) (mail-parse-comma-list))))))
148: ; (narrow-to-region (- (buffer-size) omin)
149: ; (- (buffer-size) omax))
150: ; nil)))
151:
152: (defun rmail-attribute-p (s)
153: (let ((symbol (rmail-make-label s)))
154: (if (memq symbol (cdr rmail-attributes)) symbol)))
155:
156: (defun rmail-keyword-p (s)
157: (let ((symbol (rmail-make-label s)))
158: (if (memq symbol (cdr (rmail-keywords))) symbol)))
159:
160: (defun rmail-make-label (s &optional forcep)
161: (cond ((symbolp s) s)
162: (forcep (intern (downcase s) rmail-label-obarray))
163: (t (intern-soft (downcase s) rmail-label-obarray))))
164:
165: (defun rmail-force-make-label (s)
166: (intern (downcase s) rmail-label-obarray))
167:
168: (defun rmail-quote-label-name (label)
169: (regexp-quote (symbol-name (rmail-make-label label t))))
170:
171: ;; Delete all whitespace in the visible part of the buffer.
172: ;; The use of this function is unclean, and it should be flushed.
173: (defun rmail-nuke-whitespace ()
174: (save-excursion
175: (let ((buffer-read-only nil))
176: (goto-char (point-min))
177: (while (re-search-forward "[ \t]+" nil t)
178: (replace-match "")))))
179:
180:
181: ;; Motion on messages with keywords.
182:
183: (defun rmail-previous-labeled-message (n label)
184: "Show previous message with LABEL. Defaults to last labels used.
185: With prefix argument N moves backward N messages with these labels."
186: (interactive "p\nsMove to previous msg with labels: ")
187: (rmail-next-labeled-message (- n) label))
188:
189: (defun rmail-next-labeled-message (n labels)
190: "Show next message with LABEL. Defaults to last labels used.
191: With prefix argument N moves forward N messages with these labels."
192: (interactive "p\nsMove to next msg with labels: ")
193: (if (string= labels "")
194: (setq labels rmail-last-multi-labels))
195: (or labels
196: (error "No labels to find have been specified previously"))
197: (setq rmail-last-multi-labels labels)
198: (rmail-maybe-set-message-counters)
199: (let ((lastwin rmail-current-message)
200: (current rmail-current-message)
201: (regexp (concat ",\\("
202: (mail-comma-list-regexp labels)
203: "\\),")))
204: (save-restriction
205: (widen)
206: (while (and (> n 0) (< current rmail-total-messages))
207: (setq current (1+ current))
208: (if (rmail-message-labels-p current regexp)
209: (setq lastwin current n (1- n))))
210: (while (and (< n 0) (> current 1))
211: (setq current (1- current))
212: (if (rmail-message-labels-p current regexp)
213: (setq lastwin current n (1+ n)))))
214: (rmail-show-message lastwin)
215: (if (< n 0)
216: (message "No previous message with labels %s" labels))
217: (if (> n 0)
218: (message "No following message with labels %s" labels))))
219:
220: ;;; Manipulate the file's Labels option.
221:
222: ;; Return a list of symbols for all
223: ;; the keywords (labels) recorded in this file's Labels option.
224: (defun rmail-keywords ()
225: (or rmail-keywords (rmail-parse-file-keywords)))
226:
227: ;; Set rmail-keywords to a list of symbols for all
228: ;; the keywords (labels) recorded in this file's Labels option.
229: (defun rmail-parse-file-keywords ()
230: (save-restriction
231: (save-excursion
232: (widen)
233: (goto-char 1)
234: (setq rmail-keywords
235: (if (search-forward "\nLabels:" (rmail-msgbeg 1) t)
236: (progn
237: (narrow-to-region (point) (progn (end-of-line) (point)))
238: (goto-char (point-min))
239: (cons 'rmail-keywords
240: (mapcar 'rmail-force-make-label
241: (mail-parse-comma-list)))))))))
242:
243: ;; Add WORD to the list in the file's Labels option.
244: ;; Any keyword used for the first time needs this done.
245: (defun rmail-install-keyword (word)
246: (let ((keyword (rmail-make-label word t))
247: (keywords (rmail-keywords)))
248: (if (not (or (rmail-attribute-p keyword)
249: (rmail-keyword-p keyword)))
250: (let ((omin (- (buffer-size) (point-min)))
251: (omax (- (buffer-size) (point-max))))
252: (unwind-protect
253: (save-excursion
254: (widen)
255: (goto-char 1)
256: (let ((case-fold-search t)
257: (buffer-read-only nil))
258: (or (search-forward "\nLabels:" nil t)
259: (progn
260: (end-of-line)
261: (insert "\nLabels:")))
262: (delete-region (point) (progn (end-of-line) (point)))
263: (setcdr keywords (cons keyword (cdr keywords)))
264: (while (setq keywords (cdr keywords))
265: (insert (symbol-name (car keywords)) ","))
266: (delete-char -1)))
267: (narrow-to-region (- (buffer-size) omin)
268: (- (buffer-size) omax)))))
269: keyword))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.