Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-mark.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 859a2309aef8
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; Commands for handling messages marks
2 ;;; Copyright (C) 1990, 1993, 1994 Kyle E. Jones
3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program; if not, write to the Free Software
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
17
18 (provide 'vm-mark)
19
20 (defun vm-clear-all-marks ()
21 "Removes all message marks in the current folder."
22 (interactive)
23 (vm-select-folder-buffer)
24 (vm-check-for-killed-summary)
25 (vm-error-if-folder-empty)
26 (let ((mp vm-message-list))
27 (while mp
28 (if (vm-mark-of (car mp))
29 (progn
30 (vm-set-mark-of (car mp) nil)
31 (vm-mark-for-summary-update (car mp) t)))
32 (setq mp (cdr mp))))
33 (vm-display nil nil '(vm-clear-all-marks)
34 '(vm-clear-all-marks marking-message))
35 (vm-update-summary-and-mode-line))
36
37 (defun vm-mark-all-messages ()
38 "Mark all messages in the current folder."
39 (interactive)
40 (vm-select-folder-buffer)
41 (vm-check-for-killed-summary)
42 (vm-error-if-folder-empty)
43 (let ((mp vm-message-list))
44 (while mp
45 (vm-set-mark-of (car mp) t)
46 (vm-mark-for-summary-update (car mp) t)
47 (setq mp (cdr mp))))
48 (vm-display nil nil '(vm-mark-all-messages)
49 '(vm-mark-all-messages marking-message))
50 (vm-update-summary-and-mode-line))
51
52 (defun vm-mark-message (count)
53 "Mark the current message.
54 Numeric prefix argument N means mark the current message and the next
55 N-1 messages. A negative N means mark the current message and the
56 previous N-1 messages."
57 (interactive "p")
58 (if (interactive-p)
59 (vm-follow-summary-cursor))
60 (vm-select-folder-buffer)
61 (vm-check-for-killed-summary)
62 (vm-error-if-folder-empty)
63 (let ((direction (if (< count 0) 'backward 'forward))
64 (count (vm-abs count))
65 (oldmp vm-message-pointer)
66 (vm-message-pointer vm-message-pointer))
67 (while (not (zerop count))
68 (if (not (vm-mark-of (car vm-message-pointer)))
69 (progn
70 (vm-set-mark-of (car vm-message-pointer) t)
71 (vm-mark-for-summary-update (car vm-message-pointer) t)))
72 (vm-decrement count)
73 (if (not (zerop count))
74 (vm-move-message-pointer direction))))
75 (vm-display nil nil '(vm-mark-message)
76 '(vm-mark-message marking-message))
77 (vm-update-summary-and-mode-line))
78
79 (defun vm-unmark-message (count)
80 "Remove the mark from the current message.
81 Numeric prefix argument N means unmark the current message and the next
82 N-1 messages. A negative N means unmark the current message and the
83 previous N-1 messages."
84 (interactive "p")
85 (if (interactive-p)
86 (vm-follow-summary-cursor))
87 (vm-select-folder-buffer)
88 (vm-check-for-killed-summary)
89 (vm-error-if-folder-empty)
90 (let ((mlist (vm-select-marked-or-prefixed-messages count)))
91 (while mlist
92 (if (vm-mark-of (car mlist))
93 (progn
94 (vm-set-mark-of (car mlist) nil)
95 (vm-mark-for-summary-update (car mlist) t)))
96 (setq mlist (cdr mlist))))
97 (vm-display nil nil '(vm-unmark-message)
98 '(vm-unmark-message marking-message))
99 (vm-update-summary-and-mode-line))
100
101 (defun vm-mark-or-unmark-messages-with-selector (val selector arg)
102 (let ((mlist vm-message-list)
103 (virtual (eq major-mode 'vm-virtual-mode))
104 (arglist (if arg (list arg) nil))
105 (count 0))
106 (setq selector (intern (concat "vm-vs-" (symbol-name selector))))
107 (while mlist
108 (if (if virtual
109 (save-excursion
110 (set-buffer
111 (vm-buffer-of
112 (vm-real-message-of
113 (car mlist))))
114 (apply selector (vm-real-message-of (car mlist)) arglist))
115 (apply selector (car mlist) arglist))
116 (progn
117 (vm-set-mark-of (car mlist) val)
118 (vm-mark-for-summary-update (car mlist) t)
119 (vm-increment count)))
120 (setq mlist (cdr mlist)))
121 (vm-display nil nil
122 '(vm-mark-matching-messages vm-unmark-matching-messages)
123 (list this-command 'marking-message))
124 (vm-update-summary-and-mode-line)
125 (message "%d message%s %smarked"
126 count
127 (if (= 1 count) "" "s")
128 (if val "" "un"))))
129
130 (defun vm-mark-matching-messages (selector &optional arg)
131 "Mark messages matching some criterion.
132 You can use any of the virtual folder selectors, except for the
133 `and', `or' and `not' selectors. See the documentation for the
134 variable vm-virtual-folder-alist for more information."
135 (interactive
136 (let ((last-command last-command)
137 (this-command this-command))
138 (vm-select-folder-buffer)
139 (vm-read-virtual-selector "Mark messages: ")))
140 (vm-select-folder-buffer)
141 (vm-check-for-killed-summary)
142 (vm-error-if-folder-empty)
143 (vm-mark-or-unmark-messages-with-selector t selector arg))
144
145 (defun vm-unmark-matching-messages (selector &optional arg)
146 "Unmark messages matching some criterion.
147 You can use any of the virtual folder selectors, except for the
148 `and', `or' and `not' selectors. See the documentation for the
149 variable vm-virtual-folder-alist for more information."
150 (interactive
151 (let ((last-command last-command)
152 (this-command this-command))
153 (vm-select-folder-buffer)
154 (vm-read-virtual-selector "Unmark messages: ")))
155 (vm-select-folder-buffer)
156 (vm-check-for-killed-summary)
157 (vm-error-if-folder-empty)
158 (vm-mark-or-unmark-messages-with-selector nil selector arg))
159
160 (defun vm-mark-thread-subtree ()
161 "Mark all messages in the thread tree rooted at the current message."
162 (interactive)
163 (vm-follow-summary-cursor)
164 (vm-select-folder-buffer)
165 (vm-check-for-killed-summary)
166 (vm-error-if-folder-empty)
167 (vm-mark-or-unmark-thread-subtree t))
168
169 (defun vm-unmark-thread-subtree ()
170 "Unmark all messages in the thread tree rooted at the current message."
171 (interactive)
172 (vm-follow-summary-cursor)
173 (vm-select-folder-buffer)
174 (vm-check-for-killed-summary)
175 (vm-error-if-folder-empty)
176 (vm-mark-or-unmark-thread-subtree nil))
177
178 (defun vm-mark-or-unmark-thread-subtree (mark)
179 (vm-build-threads-if-unbuilt)
180 (let ((list (list (car vm-message-pointer)))
181 (loop-obarray (make-vector 29 0))
182 subject-sym id-sym)
183 (while list
184 (if (not (eq (vm-mark-of (car list)) mark))
185 (progn
186 (vm-set-mark-of (car list) mark)
187 (vm-mark-for-summary-update (car list))))
188 (setq id-sym (car (vm-last (vm-th-thread-list (car list)))))
189 (if (null (intern-soft (symbol-name id-sym) loop-obarray))
190 (progn
191 (intern (symbol-name id-sym) loop-obarray)
192 (nconc list (copy-sequence (get id-sym 'children)))
193 (setq subject-sym (intern (vm-so-sortable-subject (car list))
194 vm-thread-subject-obarray))
195 (if (and (boundp subject-sym)
196 (eq id-sym (aref (symbol-value subject-sym) 0)))
197 (nconc list (copy-sequence
198 (aref (symbol-value subject-sym) 2))))))
199 (setq list (cdr list))))
200 (vm-display nil nil
201 '(vm-mark-thread-subtree vm-unmark-thread-subtree)
202 (list this-command 'marking-message))
203 (vm-update-summary-and-mode-line))
204
205 (defun vm-mark-messages-same-subject ()
206 "Mark all messages with the same subject as the current message."
207 (interactive)
208 (vm-follow-summary-cursor)
209 (vm-select-folder-buffer)
210 (vm-check-for-killed-summary)
211 (vm-error-if-folder-empty)
212 (vm-mark-or-unmark-messages-same-subject t))
213
214 (defun vm-unmark-messages-same-subject ()
215 "Unmark all messages with the same subject as the current message."
216 (interactive)
217 (vm-follow-summary-cursor)
218 (vm-select-folder-buffer)
219 (vm-check-for-killed-summary)
220 (vm-error-if-folder-empty)
221 (vm-mark-or-unmark-messages-same-subject nil))
222
223 (defun vm-mark-or-unmark-messages-same-subject (mark)
224 (let ((mp vm-message-list)
225 (mark-count 0)
226 (subject (vm-so-sortable-subject (car vm-message-pointer))))
227 (while mp
228 (if (and (not (eq (vm-mark-of (car mp)) mark))
229 (string-equal subject (vm-so-sortable-subject (car mp))))
230 (progn
231 (vm-set-mark-of (car mp) mark)
232 (vm-increment mark-count)
233 (vm-mark-for-summary-update (car mp) t)))
234 (setq mp (cdr mp)))
235 (if (zerop mark-count)
236 (message "No messages %smarked" (if mark "" "un"))
237 (message "%d message%s %smarked"
238 mark-count
239 (if (= 1 mark-count) "" "s")
240 (if mark "" "un"))))
241 (vm-display nil nil
242 '(vm-mark-messages-same-subject
243 vm-unmark-messages-same-subject)
244 (list this-command 'marking-message))
245 (vm-update-summary-and-mode-line))
246
247 (defun vm-mark-messages-same-author ()
248 "Mark all messages with the same author as the current message."
249 (interactive)
250 (vm-follow-summary-cursor)
251 (vm-select-folder-buffer)
252 (vm-check-for-killed-summary)
253 (vm-error-if-folder-empty)
254 (vm-mark-or-unmark-messages-same-author t))
255
256 (defun vm-unmark-messages-same-author ()
257 "Unmark all messages with the same author as the current message."
258 (interactive)
259 (vm-follow-summary-cursor)
260 (vm-select-folder-buffer)
261 (vm-check-for-killed-summary)
262 (vm-error-if-folder-empty)
263 (vm-mark-or-unmark-messages-same-author nil))
264
265 (defun vm-mark-or-unmark-messages-same-author (mark)
266 (let ((mp vm-message-list)
267 (mark-count 0)
268 (author (vm-su-from (car vm-message-pointer))))
269 (while mp
270 (if (and (not (eq (vm-mark-of (car mp)) mark))
271 (string-equal author (vm-su-from (car mp))))
272 (progn
273 (vm-set-mark-of (car mp) mark)
274 (vm-increment mark-count)
275 (vm-mark-for-summary-update (car mp) t)))
276 (setq mp (cdr mp)))
277 (if (zerop mark-count)
278 (message "No messages %smarked" (if mark "" "un"))
279 (message "%d message%s %smarked"
280 mark-count
281 (if (= 1 mark-count) "" "s")
282 (if mark "" "un"))))
283 (vm-display nil nil
284 '(vm-mark-messages-same-author
285 vm-unmark-messages-same-author)
286 (list this-command 'marking-message))
287 (vm-update-summary-and-mode-line))
288
289 (defun vm-next-command-uses-marks ()
290 "Does nothing except insure that the next VM command will operate only
291 on the marked messages in the current folder."
292 (interactive)
293 (setq this-command 'vm-next-command-uses-marks)
294 (vm-unsaved-message "Next command uses marks...")
295 (vm-display nil nil '(vm-next-command-uses-marks)
296 '(vm-next-command-uses-marks)))
297
298 (defun vm-marked-messages ()
299 (let (list (mp vm-message-list))
300 (while mp
301 (if (vm-mark-of (car mp))
302 (setq list (cons (car mp) list)))
303 (setq mp (cdr mp)))
304 (nreverse list)))
305
306 (defun vm-mark-help ()
307 (interactive)
308 (vm-display nil nil '(vm-mark-help) '(vm-mark-help))
309 (message "MM = mark, MU = unmark, Mm = mark all, Mu = unmark all, MN = use marks, ..."))