Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-delete.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 ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; Delete and expunge commands for VM.
2 ;;; Copyright (C) 1989, 1990, 1991, 1993, 1994, 1995 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-delete)
19
20 (defun vm-delete-message (count)
21 "Add the `deleted' attribute to the current message.
22
23 The message will be physically deleted from the current folder the next
24 time the current folder is expunged.
25
26 With a prefix argument COUNT, the current message and the next
27 COUNT - 1 messages are deleted. A negative argument means the
28 the current message and the previous |COUNT| - 1 messages are
29 deleted.
30
31 When invoked on marked messages (via vm-next-command-uses-marks),
32 only marked messages are deleted, other messages are ignored."
33 (interactive "p")
34 (if (interactive-p)
35 (vm-follow-summary-cursor))
36 (vm-select-folder-buffer)
37 (vm-check-for-killed-summary)
38 (vm-error-if-folder-read-only)
39 (vm-error-if-folder-empty)
40 (let ((used-marks (eq last-command 'vm-next-command-uses-marks))
41 (mlist (vm-select-marked-or-prefixed-messages count))
42 (del-count 0))
43 (while mlist
44 (if (not (vm-deleted-flag (car mlist)))
45 (progn
46 (vm-set-deleted-flag (car mlist) t)
47 (vm-increment del-count)))
48 (setq mlist (cdr mlist)))
49 (vm-display nil nil '(vm-delete-message vm-delete-message-backward)
50 (list this-command))
51 (if (and used-marks (interactive-p))
52 (if (zerop del-count)
53 (message "No messages deleted")
54 (message "%d message%s deleted"
55 del-count
56 (if (= 1 del-count) "" "s"))))
57 (vm-update-summary-and-mode-line)
58 (if (and vm-move-after-deleting (not used-marks))
59 (let ((vm-circular-folders (and vm-circular-folders
60 (eq vm-move-after-deleting t))))
61 (vm-next-message count t executing-kbd-macro)))))
62
63 (defun vm-delete-message-backward (count)
64 "Like vm-delete-message, except the deletion direction is reversed."
65 (interactive "p")
66 (if (interactive-p)
67 (vm-follow-summary-cursor))
68 (vm-delete-message (- count)))
69
70 (defun vm-undelete-message (count)
71 "Remove the `deleted' attribute from the current message.
72
73 With a prefix argument COUNT, the current message and the next
74 COUNT - 1 messages are undeleted. A negative argument means the
75 the current message and the previous |COUNT| - 1 messages are
76 deleted.
77
78 When invoked on marked messages (via vm-next-command-uses-marks),
79 only marked messages are undeleted, other messages are ignored."
80 (interactive "p")
81 (if (interactive-p)
82 (vm-follow-summary-cursor))
83 (vm-select-folder-buffer)
84 (vm-check-for-killed-summary)
85 (vm-error-if-folder-read-only)
86 (vm-error-if-folder-empty)
87 (let ((used-marks (eq last-command 'vm-next-command-uses-marks))
88 (mlist (vm-select-marked-or-prefixed-messages count))
89 (undel-count 0))
90 (while mlist
91 (if (vm-deleted-flag (car mlist))
92 (progn
93 (vm-set-deleted-flag (car mlist) nil)
94 (vm-increment undel-count)))
95 (setq mlist (cdr mlist)))
96 (if (and used-marks (interactive-p))
97 (if (zerop undel-count)
98 (message "No messages undeleted")
99 (message "%d message%s undeleted"
100 undel-count
101 (if (= 1 undel-count)
102 "" "s"))))
103 (vm-display nil nil '(vm-undelete-message) '(vm-undelete-message))
104 (vm-update-summary-and-mode-line)
105 (if (and vm-move-after-undeleting (not used-marks))
106 (let ((vm-circular-folders (and vm-circular-folders
107 (eq vm-move-after-undeleting t))))
108 (vm-next-message count t executing-kbd-macro)))))
109
110 (defun vm-kill-subject ()
111 "Delete all messages with the same subject as the current message.
112 Message subjects are compared after ignoring parts matched by
113 the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix."
114 (interactive)
115 (vm-follow-summary-cursor)
116 (vm-select-folder-buffer)
117 (vm-check-for-killed-summary)
118 (vm-error-if-folder-read-only)
119 (vm-error-if-folder-empty)
120 (let ((subject (vm-so-sortable-subject (car vm-message-pointer)))
121 (mp vm-message-list)
122 (n 0)
123 (case-fold-search t))
124 (while mp
125 (if (and (not (vm-deleted-flag (car mp)))
126 (string-equal subject (vm-so-sortable-subject (car mp))))
127 (progn
128 (vm-set-deleted-flag (car mp) t)
129 (vm-increment n)))
130 (setq mp (cdr mp)))
131 (and (interactive-p)
132 (if (zerop n)
133 (message "No messages deleted.")
134 (message "%d message%s deleted" n (if (= n 1) "" "s")))))
135 (vm-display nil nil '(vm-kill-subject) '(vm-kill-subject))
136 (vm-update-summary-and-mode-line))
137
138 (defun vm-expunge-folder (&optional shaddap)
139 "Expunge messages with the `deleted' attribute.
140 For normal folders this means that the deleted messages are
141 removed from the message list and the message contents are
142 removed from the folder buffer.
143
144 For virtual folders, messages are removed from the virtual
145 message list. If virtual mirroring is in effect for the virtual
146 folder, the corresponding real messages are also removed from real
147 message lists and the message contents are removed from real folders.
148
149 When invoked on marked messages (via vm-next-command-uses-marks),
150 only messages both marked and deleted are expunged, other messages are
151 ignored."
152 (interactive)
153 (vm-select-folder-buffer)
154 (vm-check-for-killed-summary)
155 (vm-error-if-folder-read-only)
156 ;; do this so we have a clean slate. code below depends on the
157 ;; fact that the numbering redo start point begins as nil in
158 ;; all folder buffers.
159 (vm-update-summary-and-mode-line)
160 (if (not shaddap)
161 (vm-unsaved-message "Expunging..."))
162 (let ((use-marks (eq last-command 'vm-next-command-uses-marks))
163 (mp vm-message-list)
164 (virtual (eq major-mode 'vm-virtual-mode))
165 (buffers-altered (make-vector 29 0))
166 prev virtual-messages)
167 (while mp
168 (cond
169 ((and (vm-deleted-flag (car mp))
170 (or (not use-marks)
171 (vm-mark-of (car mp))))
172 ;; remove the message from the thread tree.
173 (if vm-thread-obarray
174 (vm-unthread-message (vm-real-message-of (car mp))))
175 ;; expunge from the virtual side first, removing all
176 ;; references to this message before actually removing
177 ;; the message itself.
178 (cond
179 ((setq virtual-messages (vm-virtual-messages-of (car mp)))
180 (let (vms prev curr)
181 (if virtual
182 (setq vms (cons (vm-real-message-of (car mp))
183 (vm-virtual-messages-of (car mp))))
184 (setq vms (vm-virtual-messages-of (car mp))))
185 (while vms
186 (save-excursion
187 (set-buffer (vm-buffer-of (car vms)))
188 (setq prev (vm-reverse-link-of (car vms))
189 curr (or (cdr prev) vm-message-list))
190 (intern (buffer-name) buffers-altered)
191 (vm-set-numbering-redo-start-point (or prev t))
192 (vm-set-summary-redo-start-point (or prev t))
193 (if (eq vm-message-pointer curr)
194 (setq vm-system-state nil
195 vm-message-pointer (or prev (cdr curr))))
196 (if (eq vm-last-message-pointer curr)
197 (setq vm-last-message-pointer nil))
198 ;; lock out interrupts to preserve message-list integrity
199 (let ((inhibit-quit t))
200 ;; vm-clear-expunge-invalidated-undos uses
201 ;; this to recognize expunged messages.
202 ;; If this stuff is mirrored we'll be
203 ;; setting this value multiple times if there
204 ;; are multiple virtual messages referencing
205 ;; the underlying real message. Harmless.
206 (vm-set-deleted-flag-of (car curr) 'expunged)
207 ;; disable summary any summary update that may have
208 ;; already been scheduled.
209 (vm-set-su-start-of (car curr) nil)
210 (vm-increment vm-modification-counter)
211 (if (null prev)
212 (progn
213 (setq vm-message-list (cdr vm-message-list))
214 (and (cdr curr)
215 (vm-set-reverse-link-of (car (cdr curr)) nil)))
216 (setcdr prev (cdr curr))
217 (and (cdr curr)
218 (vm-set-reverse-link-of (car (cdr curr)) prev)))
219 (vm-set-virtual-messages-of (car mp) (cdr vms))
220 (vm-set-buffer-modified-p t)))
221 (setq vms (cdr vms))))))
222 (cond
223 ((or (not virtual-messages)
224 (not virtual))
225 (and (not virtual-messages) virtual
226 (vm-set-virtual-messages-of
227 (vm-real-message-of (car mp))
228 (delq (car mp) (vm-virtual-messages-of
229 (vm-real-message-of (car mp))))))
230 (if (eq vm-message-pointer mp)
231 (setq vm-system-state nil
232 vm-message-pointer (or prev (cdr mp))))
233 (if (eq vm-last-message-pointer mp)
234 (setq vm-last-message-pointer nil))
235 (intern (buffer-name) buffers-altered)
236 (if (null vm-numbering-redo-start-point)
237 (progn
238 (vm-set-numbering-redo-start-point (or prev t))
239 (vm-set-summary-redo-start-point (or prev t))))
240 ;; lock out interrupt to preserve message list integrity
241 (let ((inhibit-quit t))
242 (if (null prev)
243 (progn (setq vm-message-list (cdr vm-message-list))
244 (and (cdr mp)
245 (vm-set-reverse-link-of (car (cdr mp)) nil)))
246 (setcdr prev (cdr mp))
247 (and (cdr mp) (vm-set-reverse-link-of (car (cdr mp)) prev)))
248 ;; vm-clear-expunge-invalidated-undos uses this to recognize
249 ;; expunged messages.
250 (vm-set-deleted-flag-of (car mp) 'expunged)
251 ;; disable summary any summary update that may have
252 ;; already been scheduled.
253 (vm-set-su-start-of (car mp) nil)
254 (vm-set-buffer-modified-p t)
255 (vm-increment vm-modification-counter))))
256 (if (eq (vm-attributes-of (car mp))
257 (vm-attributes-of (vm-real-message-of (car mp))))
258 (save-excursion
259 (set-buffer (vm-buffer-of (vm-real-message-of (car mp))))
260 (vm-save-restriction
261 (widen)
262 (let ((buffer-read-only nil))
263 (delete-region (vm-start-of (vm-real-message-of (car mp)))
264 (vm-end-of (vm-real-message-of (car mp)))))))))
265 (t (setq prev mp)))
266 (setq mp (cdr mp)))
267 (vm-display nil nil '(vm-expunge-folder) '(vm-expunge-folder))
268 (cond
269 (buffers-altered
270 (save-excursion
271 (mapatoms
272 (function
273 (lambda (buffer)
274 (set-buffer (symbol-name buffer))
275 (if (null vm-system-state)
276 (if (null vm-message-pointer)
277 ;; folder is now empty
278 (progn (setq vm-folder-type nil)
279 (vm-update-summary-and-mode-line))
280 (vm-preview-current-message))
281 (vm-update-summary-and-mode-line))
282 (if (not (eq major-mode 'vm-virtual-mode))
283 (setq vm-message-order-changed
284 (or vm-message-order-changed
285 vm-message-order-header-present)))
286 (vm-clear-expunge-invalidated-undos)))
287 buffers-altered))
288 (if (not shaddap)
289 (message "Deleted messages expunged.")))
290 (t (message "No messages are flagged for deletion.")))))