Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-undo.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 to undo message attribute changes in VM
2 ;;; Copyright (C) 1989, 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-undo)
19
20 (defun vm-set-buffer-modified-p (flag &optional buffer)
21 (save-excursion
22 (and buffer (set-buffer buffer))
23 (set-buffer-modified-p flag)
24 (vm-increment vm-modification-counter)
25 (intern (buffer-name) vm-buffers-needing-display-update)
26 (if (null flag)
27 (setq vm-messages-not-on-disk 0))))
28
29 (defun vm-undo-boundary ()
30 (if (car vm-undo-record-list)
31 (setq vm-undo-record-list (cons nil vm-undo-record-list))))
32
33 (defun vm-clear-expunge-invalidated-undos ()
34 (let ((udp vm-undo-record-list) udp-prev)
35 (while udp
36 (cond ((null (car udp))
37 (setq udp-prev udp))
38 ((and (not (eq (car (car udp)) 'vm-set-buffer-modified-p))
39 ;; delete flag == expunged is the
40 ;; indicator of an expunged message
41 (eq (vm-deleted-flag (car (cdr (car udp)))) 'expunged))
42 (cond (udp-prev (setcdr udp-prev (cdr udp)))
43 (t (setq vm-undo-record-list (cdr udp)))))
44 (t (setq udp-prev udp)))
45 (setq udp (cdr udp))))
46 (vm-clear-modification-flag-undos))
47
48 (defun vm-clear-virtual-quit-invalidated-undos ()
49 (let ((udp vm-undo-record-list) udp-prev)
50 (while udp
51 (cond ((null (car udp))
52 (setq udp-prev udp))
53 ((and (not (eq (car (car udp)) 'vm-set-buffer-modified-p))
54 ;; message-id-number == "Q" is the
55 ;; indicator of a dead message
56 (equal (vm-message-id-number-of (car (cdr (car udp)))) "Q"))
57 (cond (udp-prev (setcdr udp-prev (cdr udp)))
58 (t (setq vm-undo-record-list (cdr udp)))))
59 (t (setq udp-prev udp)))
60 (setq udp (cdr udp))))
61 (vm-clear-modification-flag-undos))
62
63 (defun vm-clear-modification-flag-undos ()
64 (let ((udp vm-undo-record-list) udp-prev)
65 (while udp
66 (cond ((null (car udp))
67 (setq udp-prev udp))
68 ((eq (car (car udp)) 'vm-set-buffer-modified-p)
69 (cond (udp-prev (setcdr udp-prev (cdr udp)))
70 (t (setq vm-undo-record-list (cdr udp)))))
71 (t (setq udp-prev udp)))
72 (setq udp (cdr udp)))
73 (vm-squeeze-consecutive-undo-boundaries)))
74
75 ;; squeeze out consecutive record separators left by record deletions
76 (defun vm-squeeze-consecutive-undo-boundaries ()
77 (let ((udp vm-undo-record-list) udp-prev)
78 (while udp
79 (cond ((and (null (car udp)) udp-prev (null (car udp-prev)))
80 (setcdr udp-prev (cdr udp)))
81 (t (setq udp-prev udp)))
82 (setq udp (cdr udp)))
83 (if (equal '(nil) vm-undo-record-list)
84 (setq vm-undo-record-list nil)))
85 ;; for the Undo button on the menubar, if present
86 (and (null vm-undo-record-list)
87 (vm-menu-support-possible-p)
88 (vm-menu-xemacs-menus-p)
89 (vm-menu-set-menubar-dirty-flag)))
90
91 (defun vm-undo-record (sexp)
92 ;; for the Undo button on the menubar, if present
93 (and (null vm-undo-record-list)
94 (vm-menu-support-possible-p)
95 (vm-menu-xemacs-menus-p)
96 (vm-menu-set-menubar-dirty-flag))
97 (setq vm-undo-record-list (cons sexp vm-undo-record-list)))
98
99 (defun vm-undo-describe (record)
100 (let ((cell
101 (assq (car record)
102 '((vm-set-new-flag "new" "old")
103 (vm-set-unread-flag "unread" "read")
104 (vm-set-deleted-flag "deleted" "undeleted")
105 (vm-set-forwarded-flag "forwarded" "unforwarded")
106 (vm-set-replied-flag "answered" "unanswered")
107 (vm-set-redistributed-flag "redistributed" "unredistributed")
108 (vm-set-filed-flag "filed" "unfiled")
109 (vm-set-written-flag "written" "unwritten"))))
110 (m (nth 1 record))
111 labels)
112 (cond (cell
113 (message "VM Undo! %s/%s %s -> %s"
114 (buffer-name (vm-buffer-of m))
115 (vm-number-of m)
116 (if (nth 2 record)
117 (nth 2 cell)
118 (nth 1 cell))
119 (if (nth 2 record)
120 (nth 1 cell)
121 (nth 2 cell))))
122 ((eq (car cell) 'vm-set-labels)
123 (setq labels (nth 2 record))
124 (message "VM Undo! %s/%s %s%s"
125 (buffer-name (vm-buffer-of m))
126 (vm-number-of m)
127 (if (null labels)
128 "lost all its labels"
129 "labels set to ")
130 (if (null labels)
131 ""
132 (mapconcat 'identity labels ", ")))))))
133
134 (defun vm-undo-set-message-pointer (record)
135 (if (and (not (eq (car record) 'vm-set-buffer-modified-p))
136 (not (eq (nth 1 record) vm-message-pointer)))
137 (progn
138 (vm-record-and-change-message-pointer
139 vm-message-pointer
140 (or (cdr (vm-reverse-link-of (nth 1 record)))
141 vm-message-list))
142 ;; make folder read-only to avoid modifications when we
143 ;; do this.
144 (let ((vm-folder-read-only t))
145 (vm-preview-current-message)))))
146
147 (defun vm-undo ()
148 "Undo last change to message attributes in the current folder.
149 Consecutive invocations of this command cause sequentially earlier
150 changes to be undone. After an intervening command between undos,
151 the undos themselves become undoable."
152 (interactive)
153 (vm-select-folder-buffer)
154 (vm-check-for-killed-summary)
155 (vm-display nil nil '(vm-undo) '(vm-undo))
156 (let ((modified (buffer-modified-p)))
157 (if (not (eq last-command 'vm-undo))
158 (setq vm-undo-record-pointer vm-undo-record-list))
159 (if (not vm-undo-record-pointer)
160 (error "No further VM undo information available"))
161 ;; skip current record boundary
162 (setq vm-undo-record-pointer (cdr vm-undo-record-pointer))
163 (while (car vm-undo-record-pointer)
164 (vm-undo-set-message-pointer (car vm-undo-record-pointer))
165 (vm-undo-describe (car vm-undo-record-pointer))
166 (eval (car vm-undo-record-pointer))
167 (setq vm-undo-record-pointer (cdr vm-undo-record-pointer)))
168 (and modified (not (buffer-modified-p))
169 (delete-auto-save-file-if-necessary))
170 (vm-update-summary-and-mode-line)))
171
172 (defun vm-set-message-attributes (string count)
173 "Set message attributes.
174 Use this command to change attributes like `deleted' or
175 `replied'. Interactively you will be prompted for the attributes
176 to be changed, and only the attributes you enter will be altered.
177 You can use completion to expand the attribute names. The names
178 should be entered as a space separated list.
179
180 A numeric prefix argument COUNT causes the current message and
181 the next COUNT-1 message to have their attributes altered. A
182 negative COUNT arg causes the current message and the previous
183 COUNT-1 messages to be altered. COUNT defaults to one."
184 (interactive
185 (let ((last-command last-command)
186 (this-command this-command))
187 ;; so the user can see what message they are about to
188 ;; modify.
189 (vm-follow-summary-cursor)
190 (list
191 (vm-read-string "Set attributes: " vm-supported-attribute-names t)
192 (prefix-numeric-value current-prefix-arg))))
193 (vm-follow-summary-cursor)
194 (vm-select-folder-buffer)
195 (vm-check-for-killed-summary)
196 (vm-error-if-folder-read-only)
197 (vm-error-if-folder-empty)
198 (vm-display nil nil '(vm-set-message-attributes)
199 '(vm-set-message-attributes))
200 (let ((name-list (vm-parse string "[ \t]*\\([^ \t]+\\)"))
201 (m-list (vm-select-marked-or-prefixed-messages count))
202 n-list name m)
203 (while m-list
204 (setq m (car m-list)
205 n-list name-list)
206 (while n-list
207 (setq name (car n-list))
208 (cond ((string= name "new")
209 (vm-set-new-flag m t))
210 ((string= name "recent")
211 (vm-set-new-flag m t))
212 ((string= name "unread")
213 (vm-set-unread-flag m t))
214 ((string= name "unseen")
215 (vm-set-unread-flag m t))
216 ((string= name "read")
217 (vm-set-new-flag m nil)
218 (vm-set-unread-flag m nil))
219 ((string= name "deleted")
220 (vm-set-deleted-flag m t))
221 ((string= name "replied")
222 (vm-set-replied-flag m t))
223 ((string= name "answered")
224 (vm-set-replied-flag m t))
225 ((string= name "forwarded")
226 (vm-set-forwarded-flag m t))
227 ((string= name "redistributed")
228 (vm-set-redistributed-flag m t))
229 ((string= name "filed")
230 (vm-set-filed-flag m t))
231 ((string= name "written")
232 (vm-set-written-flag m t))
233 ((string= name "edited")
234 (vm-set-edited-flag-of m t))
235 ((string= name "undeleted")
236 (vm-set-deleted-flag m nil))
237 ((string= name "unreplied")
238 (vm-set-replied-flag m nil))
239 ((string= name "unanswered")
240 (vm-set-replied-flag m nil))
241 ((string= name "unforwarded")
242 (vm-set-forwarded-flag m nil))
243 ((string= name "unredistributed")
244 (vm-set-redistributed-flag m nil))
245 ((string= name "unfiled")
246 (vm-set-filed-flag m nil))
247 ((string= name "unwritten")
248 (vm-set-written-flag m nil))
249 ((string= name "unedited")
250 (vm-set-edited-flag-of m nil)))
251 (setq n-list (cdr n-list)))
252 (setq m-list (cdr m-list)))
253 (vm-update-summary-and-mode-line)))
254
255 (defun vm-add-message-labels (string count)
256 "Attach some labels to a message.
257 These are arbitrary user-defined labels, not to be confused with
258 message attributes like `new' and `deleted'. Interactively you
259 will be prompted for the labels to be added. You can use
260 completion to expand the label names, with the completion list
261 being all the labels that have ever been used in this folder.
262 The names should be entered as a space separated list. Label
263 names are compared case-insensitively.
264
265 A numeric prefix argument COUNT causes the current message and
266 the next COUNT-1 message to have the labels added. A
267 negative COUNT arg causes the current message and the previous
268 COUNT-1 messages to be altered. COUNT defaults to one."
269 (interactive
270 (let ((last-command last-command)
271 (this-command this-command)
272 (vm-completion-auto-correct nil)
273 (completion-ignore-case t))
274 ;; so the user can see what message they are about to
275 ;; modify.
276 (vm-follow-summary-cursor)
277 (vm-select-folder-buffer)
278 (list
279 (vm-read-string "Add labels: "
280 (vm-obarray-to-string-list vm-label-obarray) t)
281 (prefix-numeric-value current-prefix-arg))))
282 (vm-follow-summary-cursor)
283 (vm-select-folder-buffer)
284 (vm-check-for-killed-summary)
285 (vm-error-if-folder-read-only)
286 (vm-error-if-folder-empty)
287 (vm-add-or-delete-message-labels string count t))
288
289 (defun vm-delete-message-labels (string count)
290 "Delete some labels from a message.
291 These are arbitrary user-defined labels, not to be confused with
292 message attributes like `new' and `deleted'. Interactively you
293 will be prompted for the labels to be deleted. You can use
294 completion to expand the label names, with the completion list
295 being all the labels that have ever been used in this folder.
296 The names should be entered as a space separated list. Label
297 names are compared case-insensitively.
298
299 A numeric prefix argument COUNT causes the current message and
300 the next COUNT-1 message to have the labels deleted. A
301 negative COUNT arg causes the current message and the previous
302 COUNT-1 messages to be altered. COUNT defaults to one."
303 (interactive
304 (let ((last-command last-command)
305 (this-command this-command)
306 (vm-completion-auto-correct nil)
307 (completion-ignore-case t))
308 ;; so the user can see what message they are about to
309 ;; modify.
310 (vm-follow-summary-cursor)
311 (vm-select-folder-buffer)
312 (list
313 (vm-read-string "Delete labels: "
314 (vm-obarray-to-string-list vm-label-obarray) t)
315 (prefix-numeric-value current-prefix-arg))))
316 (vm-follow-summary-cursor)
317 (vm-select-folder-buffer)
318 (vm-check-for-killed-summary)
319 (vm-error-if-folder-read-only)
320 (vm-error-if-folder-empty)
321 (vm-add-or-delete-message-labels string count nil))
322
323 (defun vm-add-or-delete-message-labels (string count add)
324 (vm-display nil nil '(vm-add-message-labels vm-delete-message-labels)
325 (list this-command))
326 (setq string (downcase string))
327 (let ((m-list (vm-select-marked-or-prefixed-messages count))
328 (action-labels (vm-parse string
329 "[\000-\040,\177-\377]*\\([^\000-\040,\177-\377]+\\)[\000-\040,\177-\377]*"))
330 labels act-labels)
331 (if (and add m-list)
332 (progn
333 (setq act-labels action-labels)
334 (while act-labels
335 (intern (car act-labels) vm-label-obarray)
336 (setq act-labels (cdr act-labels)))))
337 (while m-list
338 (setq act-labels action-labels
339 labels (copy-sequence (vm-labels-of (car m-list))))
340 (if add
341 (while act-labels
342 (setq labels (cons (car act-labels) labels)
343 act-labels (cdr act-labels)))
344 (while act-labels
345 (setq labels (vm-delqual (car act-labels) labels)
346 act-labels (cdr act-labels))))
347 (if add
348 (setq labels (vm-delete-duplicates labels)))
349 (vm-set-labels (car m-list) labels)
350 (setq m-list (cdr m-list))))
351 (vm-update-summary-and-mode-line))
352
353 (defun vm-set-xxxx-flag (m flag norecord function attr-index)
354 (let ((m-list nil) vmp)
355 (cond
356 ((and (not vm-folder-read-only)
357 (or (not (vm-virtual-messages-of m))
358 (not (save-excursion
359 (set-buffer
360 (vm-buffer-of
361 (vm-real-message-of m)))
362 vm-folder-read-only))))
363 (aset (vm-attributes-of m) attr-index flag)
364 (vm-mark-for-summary-update m)
365 (cond
366 ((not norecord)
367 (if (eq vm-flush-interval t)
368 (vm-stuff-virtual-attributes m)
369 (vm-set-modflag-of m t))
370 (setq vmp (cons (vm-real-message-of m) (vm-virtual-messages-of m)))
371 (while vmp
372 (if (eq (vm-attributes-of m) (vm-attributes-of (car vmp)))
373 (setq m-list (cons (car vmp) m-list)))
374 (setq vmp (cdr vmp)))
375 (if (null m-list)
376 (setq m-list (cons m m-list)))
377 (while m-list
378 (save-excursion
379 (set-buffer (vm-buffer-of (car m-list)))
380 (cond ((not (buffer-modified-p))
381 (vm-set-buffer-modified-p t)
382 (vm-undo-record (list 'vm-set-buffer-modified-p nil))))
383 (vm-undo-record (list function (car m-list) (not flag)))
384 (vm-undo-boundary)
385 (vm-increment vm-modification-counter))
386 (setq m-list (cdr m-list)))))))))
387
388 (defun vm-set-labels (m labels)
389 (let ((m-list nil)
390 (old-labels (vm-labels-of m))
391 vmp)
392 (cond
393 ((and (not vm-folder-read-only)
394 (or (not (vm-virtual-messages-of m))
395 (not (save-excursion
396 (set-buffer
397 (vm-buffer-of
398 (vm-real-message-of m)))
399 vm-folder-read-only))))
400 (vm-set-labels-of m labels)
401 (vm-set-label-string-of m nil)
402 (vm-mark-for-summary-update m)
403 (if (eq vm-flush-interval t)
404 (vm-stuff-virtual-attributes m)
405 (vm-set-modflag-of m t))
406 (setq vmp (cons (vm-real-message-of m) (vm-virtual-messages-of m)))
407 (while vmp
408 (if (eq (vm-attributes-of m) (vm-attributes-of (car vmp)))
409 (setq m-list (cons (car vmp) m-list)))
410 (setq vmp (cdr vmp)))
411 (if (null m-list)
412 (setq m-list (cons m m-list)))
413 (while m-list
414 (save-excursion
415 (set-buffer (vm-buffer-of (car m-list)))
416 (cond ((not (buffer-modified-p))
417 (vm-set-buffer-modified-p t)
418 (vm-undo-record (list 'vm-set-buffer-modified-p nil))))
419 (vm-undo-record (list 'vm-set-labels m old-labels))
420 (vm-undo-boundary)
421 (vm-increment vm-modification-counter))
422 (setq m-list (cdr m-list)))))))
423
424 (defun vm-set-new-flag (m flag &optional norecord)
425 (vm-set-xxxx-flag m flag norecord 'vm-set-new-flag 0))
426
427 (defun vm-set-unread-flag (m flag &optional norecord)
428 (vm-set-xxxx-flag m flag norecord 'vm-set-unread-flag 1))
429
430 (defun vm-set-deleted-flag (m flag &optional norecord)
431 (vm-set-xxxx-flag m flag norecord 'vm-set-deleted-flag 2))
432
433 (defun vm-set-filed-flag (m flag &optional norecord)
434 (vm-set-xxxx-flag m flag norecord 'vm-set-filed-flag 3))
435
436 (defun vm-set-replied-flag (m flag &optional norecord)
437 (vm-set-xxxx-flag m flag norecord 'vm-set-replied-flag 4))
438
439 (defun vm-set-written-flag (m flag &optional norecord)
440 (vm-set-xxxx-flag m flag norecord 'vm-set-written-flag 5))
441
442 (defun vm-set-forwarded-flag (m flag &optional norecord)
443 (vm-set-xxxx-flag m flag norecord 'vm-set-forwarded-flag 6))
444
445 (defun vm-set-redistributed-flag (m flag &optional norecord)
446 (vm-set-xxxx-flag m flag norecord 'vm-set-forwarded-flag 8))
447
448 ;; use these to avoid undo and summary update.
449 (defun vm-set-new-flag-of (m flag) (aset (aref m 2) 0 flag))
450 (defun vm-set-unread-flag-of (m flag) (aset (aref m 2) 1 flag))
451 (defun vm-set-deleted-flag-of (m flag) (aset (aref m 2) 2 flag))
452 (defun vm-set-filed-flag-of (m flag) (aset (aref m 2) 3 flag))
453 (defun vm-set-replied-flag-of (m flag) (aset (aref m 2) 4 flag))
454 (defun vm-set-written-flag-of (m flag) (aset (aref m 2) 5 flag))
455 (defun vm-set-forwarded-flag-of (m flag) (aset (aref m 2) 6 flag))
456 (defun vm-set-redistributed-flag-of (m flag) (aset (aref m 2) 8 flag))
457
458 ;; this is solely for the use of vm-stuff-attributes and appears here
459 ;; only because this function should be grouped with others of its kind
460 ;; for maintenance purposes.
461 (defun vm-set-deleted-flag-in-vector (v flag)
462 (aset v 2 flag))
463 ;; ditto. this is for vm-read-attributes.
464 (defun vm-set-new-flag-in-vector (v flag)
465 (aset v 0 flag))