![[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] / 43BSDReno / contrib / emacs-18.55 / lisp|
Return to rmailkwd.el CVS log | Up to [CSRG BSD Unix] / 43BSDReno / contrib / emacs-18.55 / 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 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" "edited"))))
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: ; (while (re-search-forward "[ \t]*,[ \t]*" nil t)
100: ; (replace-match ","))
101: ; (goto-char start)
102: (if (re-search-forward
103: (concat ", " (rmail-quote-label-name label) ",")
104: bound
105: 'move)
106: (if (not state) (replace-match ","))
107: (if state (insert " " (symbol-name label) ",")))
108: (if (eq label rmail-deleted-label)
109: (rmail-set-message-deleted-p n state)))))
110: (narrow-to-region (- (buffer-size) omin) (- (buffer-size) omax))
111: (if (= n rmail-current-message) (rmail-display-labels)))))))
112:
113: ;; Commented functions aren't used by RMAIL but might be nice for user
114: ;; packages that do stuff with RMAIL. Note that rmail-message-labels-p
115: ;; is in rmailsum now.
116:
117: ;(defun rmail-message-attribute-p (attribute &optional n)
118: ; "Returns t if ATTRIBUTE on NTH or current message."
119: ; (rmail-message-labels-p (rmail-make-label attribute t) n))
120:
121: ;(defun rmail-message-keyword-p (keyword &optional n)
122: ; "Returns t if KEYWORD on NTH or current message."
123: ; (rmail-message-labels-p (rmail-make-label keyword t) n t))
124:
125: ;(defun rmail-message-label-p (label &optional n)
126: ; "Returns symbol if LABEL (attribute or keyword) on NTH or current message."
127: ; (rmail-message-labels-p (rmail-make-label label t) n 'all))
128:
129: ;; Not used by RMAIL but might be nice for user package.
130:
131: ;(defun rmail-parse-message-labels (&optional n)
132: ; "Returns labels associated with NTH or current RMAIL message.
133: ;Results is a list of two lists. The first is the message attributes
134: ;and the second is the message keywords. Labels are represented as symbols."
135: ; (let ((omin (- (buffer-size) (point-min)))
136: ; (omax (- (buffer-size) (point-max)))
137: ; (result))
138: ; (unwind-protect
139: ; (save-excursion
140: ; (let ((beg (rmail-msgbeg (or n rmail-current-message))))
141: ; (widen)
142: ; (goto-char beg)
143: ; (forward-line 1)
144: ; (if (looking-at "[01],")
145: ; (save-restriction
146: ; (narrow-to-region (point) (save-excursion (end-of-line) (point)))
147: ; (rmail-nuke-whitespace)
148: ; (goto-char (1+ (point-min)))
149: ; (list (mail-parse-comma-list) (mail-parse-comma-list))))))
150: ; (narrow-to-region (- (buffer-size) omin)
151: ; (- (buffer-size) omax))
152: ; nil)))
153:
154: (defun rmail-attribute-p (s)
155: (let ((symbol (rmail-make-label s)))
156: (if (memq symbol (cdr rmail-attributes)) symbol)))
157:
158: (defun rmail-keyword-p (s)
159: (let ((symbol (rmail-make-label s)))
160: (if (memq symbol (cdr (rmail-keywords))) symbol)))
161:
162: (defun rmail-make-label (s &optional forcep)
163: (cond ((symbolp s) s)
164: (forcep (intern (downcase s) rmail-label-obarray))
165: (t (intern-soft (downcase s) rmail-label-obarray))))
166:
167: (defun rmail-force-make-label (s)
168: (intern (downcase s) rmail-label-obarray))
169:
170: (defun rmail-quote-label-name (label)
171: (regexp-quote (symbol-name (rmail-make-label label t))))
172:
173: ;; Motion on messages with keywords.
174:
175: (defun rmail-previous-labeled-message (n label)
176: "Show previous message with LABEL. Defaults to last labels used.
177: With prefix argument N moves backward N messages with these labels."
178: (interactive "p\nsMove to previous msg with labels: ")
179: (rmail-next-labeled-message (- n) label))
180:
181: (defun rmail-next-labeled-message (n labels)
182: "Show next message with LABEL. Defaults to last labels used.
183: With prefix argument N moves forward N messages with these labels."
184: (interactive "p\nsMove to next msg with labels: ")
185: (if (string= labels "")
186: (setq labels rmail-last-multi-labels))
187: (or labels
188: (error "No labels to find have been specified previously"))
189: (setq rmail-last-multi-labels labels)
190: (rmail-maybe-set-message-counters)
191: (let ((lastwin rmail-current-message)
192: (current rmail-current-message)
193: (regexp (concat ", ?\\("
194: (mail-comma-list-regexp labels)
195: "\\),")))
196: (save-restriction
197: (widen)
198: (while (and (> n 0) (< current rmail-total-messages))
199: (setq current (1+ current))
200: (if (rmail-message-labels-p current regexp)
201: (setq lastwin current n (1- n))))
202: (while (and (< n 0) (> current 1))
203: (setq current (1- current))
204: (if (rmail-message-labels-p current regexp)
205: (setq lastwin current n (1+ n)))))
206: (rmail-show-message lastwin)
207: (if (< n 0)
208: (message "No previous message with labels %s" labels))
209: (if (> n 0)
210: (message "No following message with labels %s" labels))))
211:
212: ;;; Manipulate the file's Labels option.
213:
214: ;; Return a list of symbols for all
215: ;; the keywords (labels) recorded in this file's Labels option.
216: (defun rmail-keywords ()
217: (or rmail-keywords (rmail-parse-file-keywords)))
218:
219: ;; Set rmail-keywords to a list of symbols for all
220: ;; the keywords (labels) recorded in this file's Labels option.
221: (defun rmail-parse-file-keywords ()
222: (save-restriction
223: (save-excursion
224: (widen)
225: (goto-char 1)
226: (setq rmail-keywords
227: (if (search-forward "\nLabels:" (rmail-msgbeg 1) t)
228: (progn
229: (narrow-to-region (point) (progn (end-of-line) (point)))
230: (goto-char (point-min))
231: (cons 'rmail-keywords
232: (mapcar 'rmail-force-make-label
233: (mail-parse-comma-list)))))))))
234:
235: ;; Add WORD to the list in the file's Labels option.
236: ;; Any keyword used for the first time needs this done.
237: (defun rmail-install-keyword (word)
238: (let ((keyword (rmail-make-label word t))
239: (keywords (rmail-keywords)))
240: (if (not (or (rmail-attribute-p keyword)
241: (rmail-keyword-p keyword)))
242: (let ((omin (- (buffer-size) (point-min)))
243: (omax (- (buffer-size) (point-max))))
244: (unwind-protect
245: (save-excursion
246: (widen)
247: (goto-char 1)
248: (let ((case-fold-search t)
249: (buffer-read-only nil))
250: (or (search-forward "\nLabels:" nil t)
251: (progn
252: (end-of-line)
253: (insert "\nLabels:")))
254: (delete-region (point) (progn (end-of-line) (point)))
255: (setcdr keywords (cons keyword (cdr keywords)))
256: (while (setq keywords (cdr keywords))
257: (insert (symbol-name (car keywords)) ","))
258: (delete-char -1)))
259: (narrow-to-region (- (buffer-size) omin)
260: (- (buffer-size) omax)))))
261: keyword))
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.