cgit.sxemacs.org Git - packages/blob - xemacs-packages/vm/lisp/vm-delete.el

   1 ;;; vm-delete.el --- Delete and expunge commands for VM.
   2 ;;
   3 ;; Copyright (C) 1989-1997 Kyle E. Jones
   4 ;; Copyright (C) 2003-2006 Robert Widhopf-Fenk
   5 ;;
   6 ;; This program is free software; you can redistribute it and/or modify
   7 ;; it under the terms of the GNU General Public License as published by
   8 ;; the Free Software Foundation; either version 2 of the License, or
   9 ;; (at your option) any later version.
  10 ;;
  11 ;; This program is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;; GNU General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU General Public License along
  17 ;; with this program; if not, write to the Free Software Foundation, Inc.,
  18 ;; 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
  19
  20 ;;; Code:
  21
  22 ;;;###autoload
  23 (defun vm-delete-message (count)
  24   "Add the `deleted' attribute to the current message.
  25
  26 The message will be physically deleted from the current folder the next
  27 time the current folder is expunged.
  28
  29 With a prefix argument COUNT, the current message and the next
  30 COUNT - 1 messages are deleted.  A negative argument means
  31 the current message and the previous |COUNT| - 1 messages are
  32 deleted.
  33
  34 When invoked on marked messages (via `vm-next-command-uses-marks'),
  35 only marked messages are deleted, other messages are ignored."
  36   (interactive "p")
  37   (if (interactive-p)
  38       (vm-follow-summary-cursor))
  39   (vm-select-folder-buffer)
  40   (vm-check-for-killed-summary)
  41   (vm-error-if-folder-read-only)
  42   (vm-error-if-folder-empty)
  43   (let ((used-marks (eq last-command 'vm-next-command-uses-marks))
  44         (mlist (vm-select-marked-or-prefixed-messages count))
  45         (del-count 0))
  46     (while mlist
  47       (if (not (vm-deleted-flag (car mlist)))
  48           (progn
  49             (vm-set-deleted-flag (car mlist) t)
  50             (vm-increment del-count)))
  51       (setq mlist (cdr mlist)))
  52     (vm-display nil nil '(vm-delete-message vm-delete-message-backward)
  53                 (list this-command))
  54     (if (and used-marks (interactive-p))
  55         (if (zerop del-count)
  56             (message "No messages deleted")
  57           (message "%d message%s deleted"
  58                    del-count
  59                    (if (= 1 del-count) "" "s"))))
  60     (vm-update-summary-and-mode-line)
  61     (if (and vm-move-after-deleting (not used-marks))
  62         (let ((vm-circular-folders (and vm-circular-folders
  63                                         (eq vm-move-after-deleting t))))
  64           (vm-next-message count t executing-kbd-macro)))))
  65
  66 ;;;###autoload
  67 (defun vm-delete-message-backward (count)
  68   "Like vm-delete-message, except the deletion direction is reversed."
  69   (interactive "p")
  70   (if (interactive-p)
  71       (vm-follow-summary-cursor))
  72   (vm-delete-message (- count)))
  73
  74 ;;;###autoload
  75 (defun vm-undelete-message (count)
  76   "Remove the `deleted' attribute from the current message.
  77
  78 With a prefix argument COUNT, the current message and the next
  79 COUNT - 1 messages are undeleted.  A negative argument means
  80 the current message and the previous |COUNT| - 1 messages are
  81 deleted.
  82
  83 When invoked on marked messages (via `vm-next-command-uses-marks'),
  84 only marked messages are undeleted, other messages are ignored."
  85   (interactive "p")
  86   (if (interactive-p)
  87       (vm-follow-summary-cursor))
  88   (vm-select-folder-buffer)
  89   (vm-check-for-killed-summary)
  90   (vm-error-if-folder-read-only)
  91   (vm-error-if-folder-empty)
  92   (let ((used-marks (eq last-command 'vm-next-command-uses-marks))
  93         (mlist (vm-select-marked-or-prefixed-messages count))
  94         (undel-count 0))
  95     (while mlist
  96       (if (vm-deleted-flag (car mlist))
  97           (progn
  98             (vm-set-deleted-flag (car mlist) nil)
  99             (vm-increment undel-count)))
 100       (setq mlist (cdr mlist)))
 101     (if (and used-marks (interactive-p))
 102         (if (zerop undel-count)
 103             (message "No messages undeleted")
 104           (message "%d message%s undeleted"
 105                    undel-count
 106                    (if (= 1 undel-count)
 107                        "" "s"))))
 108     (vm-display nil nil '(vm-undelete-message) '(vm-undelete-message))
 109     (vm-update-summary-and-mode-line)
 110     (if (and vm-move-after-undeleting (not used-marks))
 111         (let ((vm-circular-folders (and vm-circular-folders
 112                                         (eq vm-move-after-undeleting t))))
 113           (vm-next-message count t executing-kbd-macro)))))
 114
 115 ;;;###autoload
 116 (defun vm-kill-subject (&optional arg)
 117 "Delete all messages with the same subject as the current message.
 118 Message subjects are compared after ignoring parts matched by
 119 the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix.
 120
 121 The optional prefix argument ARG specifies the direction to move
 122 if vm-move-after-killing is non-nil.  The default direction is
 123 forward.  A positive prefix argument means move forward, a
 124 negative arugment means move backward, a zero argument means
 125 don't move at all."
 126   (interactive "p")
 127   (vm-follow-summary-cursor)
 128   (vm-select-folder-buffer)
 129   (vm-check-for-killed-summary)
 130   (vm-error-if-folder-read-only)
 131   (vm-error-if-folder-empty)
 132   (let ((subject (vm-so-sortable-subject (car vm-message-pointer)))
 133         (mp vm-message-list)
 134         (n 0)
 135         (case-fold-search t))
 136     (while mp
 137       (if (and (not (vm-deleted-flag (car mp)))
 138                (string-equal subject (vm-so-sortable-subject (car mp))))
 139           (progn
 140             (vm-set-deleted-flag (car mp) t)
 141             (vm-increment n)))
 142       (setq mp (cdr mp)))
 143     (and (interactive-p)
 144          (if (zerop n)
 145              (message "No messages deleted.")
 146            (message "%d message%s deleted" n (if (= n 1) "" "s")))))
 147   (vm-display nil nil '(vm-kill-subject) '(vm-kill-subject))
 148   (vm-update-summary-and-mode-line)
 149   (cond ((or (not (numberp arg)) (> arg 0))
 150          (setq arg 1))
 151         ((< arg 0)
 152          (setq arg -1))
 153         (t (setq arg 0)))
 154   (if vm-move-after-killing
 155       (let ((vm-circular-folders (and vm-circular-folders
 156                                       (eq vm-move-after-killing t))))
 157         (vm-next-message arg t executing-kbd-macro))))
 158
 159 ;;;###autoload
 160 (defun vm-delete-duplicate-messages ()
 161 "Delete duplicate messages in the current folder.
 162 This command works by computing an MD5 hash for the body ofeach
 163 non-deleted message in the folder and deleting messages that have
 164 a hash that has already been seen.  Messages that already deleted
 165 are never hashed, so VM will never delete the last copy of a
 166 message in a folder.  'Deleting' means flagging for deletion; you
 167 will have to expunge the messages with `vm-expunge-folder' to
 168 really get rid of them, as usual.
 169
 170 When invoked on marked messages (via `vm-next-command-uses-marks'),
 171 only duplicate messages among the marked messages are deleted,
 172 unmarked messages are not hashed or considerd for deletion."
 173   (interactive)
 174   (vm-select-folder-buffer)
 175   (vm-check-for-killed-summary)
 176   (vm-error-if-folder-read-only)
 177   (vm-error-if-folder-empty)
 178   (let ((used-marks (eq last-command 'vm-next-command-uses-marks))
 179         (mlist vm-message-list)
 180         (table (make-vector 61 0))
 181         hash m
 182         (del-count 0))
 183     (if used-marks
 184         (setq mlist (vm-select-marked-or-prefixed-messages 0)))
 185     (save-excursion
 186       (save-restriction
 187         (widen)
 188         (while mlist
 189           (if (vm-deleted-flag (car mlist))
 190               nil
 191             (setq m (vm-real-message-of (car mlist)))
 192             (set-buffer (vm-buffer-of m))
 193             (setq hash (vm-md5-region (vm-text-of m) (vm-text-end-of m)))
 194             (if (intern-soft hash table)
 195                 (progn
 196                   (vm-set-deleted-flag (car mlist) t)
 197                   (vm-increment del-count))
 198               (intern hash table)))
 199           (setq mlist (cdr mlist)))))
 200     (vm-display nil nil '(vm-delete-duplicate-messages)
 201                 (list this-command))
 202     (if (zerop del-count)
 203         (message "No messages deleted")
 204       (message "%d message%s deleted"
 205                del-count
 206                (if (= 1 del-count) "" "s")))
 207     (vm-update-summary-and-mode-line)))
 208
 209 ;;;###autoload
 210 (defun vm-expunge-folder (&optional shaddap just-these-messages
 211                                     messages-to-expunge)
 212   "Expunge messages with the `deleted' attribute.
 213 For normal folders this means that the deleted messages are
 214 removed from the message list and the message contents are
 215 removed from the folder buffer.
 216
 217 For virtual folders, messages are removed from the virtual
 218 message list.  If virtual mirroring is in effect for the virtual
 219 folder, the corresponding real messages are also removed from real
 220 message lists and the message contents are removed from real folders.
 221
 222 When invoked on marked messages (via `vm-next-command-uses-marks'),
 223 only messages both marked and deleted are expunged, other messages are
 224 ignored."
 225   (interactive)
 226   (vm-select-folder-buffer)
 227   (vm-check-for-killed-summary)
 228   (vm-error-if-folder-read-only)
 229   ;; do this so we have a clean slate.  code below depends on the
 230   ;; fact that the numbering redo start point begins as nil in
 231   ;; all folder buffers.
 232   (vm-update-summary-and-mode-line)
 233   (if (not shaddap)
 234       (message "Expunging..."))
 235   (let ((use-marks (and (eq last-command 'vm-next-command-uses-marks)
 236                         (null just-these-messages)))
 237         (mp vm-message-list)
 238         (virtual (eq major-mode 'vm-virtual-mode))
 239         (buffers-altered (make-vector 29 0))
 240         prev virtual-messages)
 241     (while mp
 242       (cond
 243        ((if just-these-messages
 244             (memq (car mp) messages-to-expunge)
 245           (and (vm-deleted-flag (car mp))
 246                (or (not use-marks)
 247                    (vm-mark-of (car mp)))))
 248         ;; remove the message from the thread tree.
 249         (if (vectorp vm-thread-obarray)
 250             (vm-unthread-message (vm-real-message-of (car mp))))
 251         ;; expunge from the virtual side first, removing all
 252         ;; references to this message before actually removing
 253         ;; the message itself.
 254         (cond
 255          ((setq virtual-messages (vm-virtual-messages-of (car mp)))
 256           (let (vms prev curr)
 257             (if virtual
 258                 (setq vms (cons (vm-real-message-of (car mp))
 259                                 (vm-virtual-messages-of (car mp))))
 260               (setq vms (vm-virtual-messages-of (car mp))))
 261             (while vms
 262               (save-excursion
 263                 (set-buffer (vm-buffer-of (car vms)))
 264                 (setq prev (vm-reverse-link-of (car vms))
 265                       curr (or (cdr prev) vm-message-list))
 266                 (intern (buffer-name) buffers-altered)
 267                 (vm-set-numbering-redo-start-point (or prev t))
 268                 (vm-set-summary-redo-start-point (or prev t))
 269                 (if (eq vm-message-pointer curr)
 270                     (setq vm-system-state nil
 271                           vm-message-pointer (or prev (cdr curr))))
 272                 (if (eq vm-last-message-pointer curr)
 273                     (setq vm-last-message-pointer nil))
 274                 ;; lock out interrupts to preserve message-list integrity
 275                 (let ((inhibit-quit t))
 276                   ;; vm-clear-expunge-invalidated-undos uses
 277                   ;; this to recognize expunged messages.
 278                   ;; If this stuff is mirrored we'll be
 279                   ;; setting this value multiple times if there
 280                   ;; are multiple virtual messages referencing
 281                   ;; the underlying real message.  Harmless.
 282                   (vm-set-deleted-flag-of (car curr) 'expunged)
 283                   ;; disable any summary update that may have
 284                   ;; already been scheduled.
 285                   (vm-set-su-start-of (car curr) nil)
 286                   (vm-increment vm-modification-counter)
 287                   (if (null prev)
 288                       (progn
 289                         (setq vm-message-list (cdr vm-message-list))
 290                         (and (cdr curr)
 291                              (vm-set-reverse-link-of (car (cdr curr)) nil)))
 292                     (setcdr prev (cdr curr))
 293                     (and (cdr curr)
 294                          (vm-set-reverse-link-of (car (cdr curr)) prev)))
 295                   (vm-set-virtual-messages-of (car mp) (cdr vms))
 296                   (vm-set-buffer-modified-p t)))
 297               (setq vms (cdr vms))))))
 298         (cond
 299          ((or (not virtual-messages)
 300               (not virtual))
 301           (and (not virtual-messages) virtual
 302                (vm-set-virtual-messages-of
 303                 (vm-real-message-of (car mp))
 304                 (delq (car mp) (vm-virtual-messages-of
 305                                 (vm-real-message-of (car mp))))))
 306           (if (eq vm-message-pointer mp)
 307               (setq vm-system-state nil
 308                     vm-message-pointer (or prev (cdr mp))))
 309           (if (eq vm-last-message-pointer mp)
 310               (setq vm-last-message-pointer nil))
 311           (intern (buffer-name) buffers-altered)
 312           (if (null vm-numbering-redo-start-point)
 313               (progn
 314                 (vm-set-numbering-redo-start-point (or prev t))
 315                 (vm-set-summary-redo-start-point (or prev t))))
 316           ;; lock out interrupt to preserve message list integrity
 317           (let ((inhibit-quit t))
 318             (if (null prev)
 319                 (progn (setq vm-message-list (cdr vm-message-list))
 320                        (and (cdr mp)
 321                             (vm-set-reverse-link-of (car (cdr mp)) nil)))
 322               (setcdr prev (cdr mp))
 323               (and (cdr mp) (vm-set-reverse-link-of (car (cdr mp)) prev)))
 324             ;; vm-clear-expunge-invalidated-undos uses this to recognize
 325             ;; expunged messages.
 326             (vm-set-deleted-flag-of (car mp) 'expunged)
 327             ;; disable any summary update that may have
 328             ;; already been scheduled.
 329             (vm-set-su-start-of (car mp) nil)
 330             (vm-set-buffer-modified-p t)
 331             (vm-increment vm-modification-counter))))
 332         (if (eq (vm-attributes-of (car mp))
 333                 (vm-attributes-of (vm-real-message-of (car mp))))
 334             (save-excursion
 335               (set-buffer (vm-buffer-of (vm-real-message-of (car mp))))
 336               (cond ((eq vm-folder-access-method 'pop)
 337                      (setq vm-pop-messages-to-expunge
 338                            (cons (vm-pop-uidl-of (vm-real-message-of (car mp)))
 339                                  vm-pop-messages-to-expunge)
 340                            ;; Set this so that if Emacs crashes or
 341                            ;; the user quits without saving, we
 342                            ;; have a record of messages that were
 343                            ;; retrieved and expunged locally.
 344                            ;; When the user does M-x recover-file
 345                            ;; we won't re-retrieve messages the
 346                            ;; user has already dealt with.
 347                            vm-pop-retrieved-messages
 348                            (cons (list (vm-pop-uidl-of
 349                                         (vm-real-message-of (car mp)))
 350                                        (vm-folder-pop-maildrop-spec)
 351                                        'uidl)
 352                                  vm-pop-retrieved-messages)))
 353                     ((eq vm-folder-access-method 'imap)
 354                      (setq vm-imap-messages-to-expunge
 355                            (cons (cons
 356                                   (vm-imap-uid-of (vm-real-message-of (car mp)))
 357                                   (vm-imap-uid-validity-of
 358                                    (vm-real-message-of (car mp))))
 359                                  vm-imap-messages-to-expunge)
 360                            ;; Set this so that if Emacs crashes or
 361                            ;; the user quits without saving, we
 362                            ;; have a record of messages that were
 363                            ;; retrieved and expunged locally.
 364                            ;; When the user does M-x recover-file
 365                            ;; we won't re-retrieve messages the
 366                            ;; user has already dealt with.
 367                            vm-imap-retrieved-messages
 368                            (cons (list (vm-imap-uid-of
 369                                         (vm-real-message-of (car mp)))
 370                                        (vm-imap-uid-validity-of
 371                                         (vm-real-message-of (car mp)))
 372                                        (vm-folder-imap-maildrop-spec)
 373                                        'uid)
 374                                  vm-imap-retrieved-messages))))
 375               (vm-increment vm-modification-counter)
 376               (vm-save-restriction
 377                (widen)
 378                (let ((buffer-read-only nil))
 379                  (delete-region (vm-start-of (vm-real-message-of (car mp)))
 380                                 (vm-end-of (vm-real-message-of (car mp)))))))))
 381        (t (setq prev mp)))
 382       (setq mp (cdr mp)))
 383     (vm-display nil nil '(vm-expunge-folder) '(vm-expunge-folder))
 384     (cond
 385      (buffers-altered
 386       (save-excursion
 387         (mapatoms
 388          (function
 389           (lambda (buffer)
 390             (set-buffer (symbol-name buffer))
 391             (if (null vm-system-state)
 392                 (progn
 393                   (vm-garbage-collect-message)
 394                   (if (null vm-message-pointer)
 395                       ;; folder is now empty
 396                       (progn (setq vm-folder-type nil)
 397                              (vm-update-summary-and-mode-line))
 398                     (vm-preview-current-message)))
 399               (vm-update-summary-and-mode-line))
 400             (if (not (eq major-mode 'vm-virtual-mode))
 401                 (setq vm-message-order-changed
 402                       (or vm-message-order-changed
 403                           vm-message-order-header-present)))
 404             (vm-clear-expunge-invalidated-undos)))
 405          buffers-altered))
 406       (if vm-ml-sort-keys
 407           (vm-sort-messages vm-ml-sort-keys))
 408       (if (not shaddap)
 409           (message "Deleted messages expunged.")))
 410      (t (message "No messages are flagged for deletion.")))))
 411
 412 (provide 'vm-delete)
 413
 414 ;;; vm-delete.el ends here