home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / vm / vm-delete.el < prev    next >
Encoding:
Text File  |  1995-07-28  |  10.6 KB  |  288 lines
  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.     (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 count)))
  95.       (setq mlist (cdr mlist)))
  96.     (if (and used-marks (interactive-p))
  97.     (if (zerop count)
  98.         (message "No messages undeleted")
  99.       (message "%d message%s undeleted" count (if (= 1 count) "" "s"))))
  100.     (vm-display nil nil '(vm-undelete-message) '(vm-undelete-message))
  101.     (vm-update-summary-and-mode-line)
  102.     (if (and vm-move-after-undeleting (not used-marks))
  103.     (let ((vm-circular-folders (and vm-circular-folders
  104.                     (eq vm-move-after-undeleting t))))
  105.       (vm-next-message count t executing-kbd-macro)))))
  106.  
  107. (defun vm-kill-subject ()
  108.   "Delete all messages with the same subject as the current message.
  109. Message subjects are compared after ignoring parts matched by
  110. the variables vm-subject-ignored-prefix and vm-subject-ignored-suffix."
  111.   (interactive)
  112.   (vm-follow-summary-cursor)
  113.   (vm-select-folder-buffer)
  114.   (vm-check-for-killed-summary)
  115.   (vm-error-if-folder-read-only)
  116.   (vm-error-if-folder-empty)
  117.   (let ((subject (vm-so-sortable-subject (car vm-message-pointer)))
  118.     (mp vm-message-list)
  119.     (n 0)
  120.     (case-fold-search t))
  121.     (while mp
  122.       (if (and (not (vm-deleted-flag (car mp)))
  123.            (string-equal subject (vm-so-sortable-subject (car mp))))
  124.       (progn
  125.         (vm-set-deleted-flag (car mp) t)
  126.         (vm-increment n)))
  127.       (setq mp (cdr mp)))
  128.     (and (interactive-p)
  129.      (if (zerop n)
  130.          (message "No messages deleted.")
  131.        (message "%d message%s deleted" n (if (= n 1) "" "s")))))
  132.   (vm-display nil nil '(vm-kill-subject) '(vm-kill-subject))
  133.   (vm-update-summary-and-mode-line))
  134.  
  135. (defun vm-expunge-folder (&optional shaddap)
  136.   "Expunge messages with the `deleted' attribute.
  137. For normal folders this means that the deleted messages are
  138. removed from the message list and the message contents are
  139. removed from the folder buffer.
  140.  
  141. For virtual folders, messages are removed from the virtual
  142. message list.  If virtual mirroring is in effect for the virtual
  143. folder, the corresponding real messages are also removed from real
  144. message lists and the message contents are removed from real folders.
  145.  
  146. When invoked on marked messages (via vm-next-command-uses-marks),
  147. only messages both marked and deleted are expunged, other messages are
  148. ignored."
  149.   (interactive)
  150.   (vm-select-folder-buffer)
  151.   (vm-check-for-killed-summary)
  152.   (vm-error-if-folder-read-only)
  153.   ;; do this so we have a clean slate.  code below depends on the
  154.   ;; fact that the numbering redo start point begins as nil in
  155.   ;; all folder buffers.
  156.   (vm-update-summary-and-mode-line)
  157.   (if (not shaddap)
  158.       (vm-unsaved-message "Expunging..."))
  159.   (let ((use-marks (eq last-command 'vm-next-command-uses-marks))
  160.     (mp vm-message-list)
  161.     (virtual (eq major-mode 'vm-virtual-mode))
  162.     (buffers-altered (make-vector 29 0))
  163.     prev virtual-messages)
  164.     (while mp
  165.       (cond
  166.        ((and (vm-deleted-flag (car mp))
  167.          (or (not use-marks)
  168.          (vm-mark-of (car mp))))
  169.     ;; remove the message from the thread tree.
  170.     (if vm-thread-obarray
  171.         (vm-unthread-message (vm-real-message-of (car mp))))
  172.     ;; expunge from the virtual side first, removing all
  173.     ;; references to this message before actually removing
  174.     ;; the message itself.
  175.     (cond
  176.      ((setq virtual-messages (vm-virtual-messages-of (car mp)))
  177.       (let (vms prev curr)
  178.         (if virtual
  179.         (setq vms (cons (vm-real-message-of (car mp))
  180.                 (vm-virtual-messages-of (car mp))))
  181.           (setq vms (vm-virtual-messages-of (car mp))))
  182.         (while vms
  183.           (save-excursion
  184.         (set-buffer (vm-buffer-of (car vms)))
  185.         (setq prev (vm-reverse-link-of (car vms))
  186.               curr (or (cdr prev) vm-message-list))
  187.         (intern (buffer-name) buffers-altered)
  188.         (vm-set-numbering-redo-start-point (or prev t))
  189.         (vm-set-summary-redo-start-point (or prev t))
  190.         (if (eq vm-message-pointer curr)
  191.             (setq vm-system-state nil
  192.               vm-message-pointer (or prev (cdr curr))))
  193.         (if (eq vm-last-message-pointer curr)
  194.             (setq vm-last-message-pointer nil))
  195.         ;; lock out interrupts to preserve message-list integrity
  196.         (let ((inhibit-quit t))
  197.           ;; vm-clear-expunge-invalidated-undos uses
  198.           ;; this to recognize expunged messages.
  199.           ;; If this stuff is mirrored we'll be
  200.           ;; setting this value multiple times if there
  201.           ;; are multiple virtual messages referencing
  202.           ;; the underlying real message.  Harmless.
  203.           (vm-set-deleted-flag-of (car curr) 'expunged)
  204.           ;; disable summary any summary update that may have
  205.           ;; already been scheduled.
  206.           (vm-set-su-start-of (car curr) nil)
  207.           (vm-increment vm-modification-counter)
  208.           (if (null prev)
  209.               (progn
  210.             (setq vm-message-list (cdr vm-message-list))
  211.             (and (cdr curr)
  212.                  (vm-set-reverse-link-of (car (cdr curr)) nil)))
  213.             (setcdr prev (cdr curr))
  214.             (and (cdr curr)
  215.              (vm-set-reverse-link-of (car (cdr curr)) prev)))
  216.           (vm-set-virtual-messages-of (car mp) (cdr vms))
  217.           (vm-set-buffer-modified-p t)))
  218.           (setq vms (cdr vms))))))
  219.     (cond
  220.      ((or (not virtual-messages)
  221.           (not virtual))
  222.       (and (not virtual-messages) virtual
  223.            (vm-set-virtual-messages-of
  224.         (vm-real-message-of (car mp))
  225.         (delq (car mp) (vm-virtual-messages-of
  226.                 (vm-real-message-of (car mp))))))
  227.       (if (eq vm-message-pointer mp)
  228.           (setq vm-system-state nil
  229.             vm-message-pointer (or prev (cdr mp))))
  230.       (if (eq vm-last-message-pointer mp)
  231.           (setq vm-last-message-pointer nil))
  232.       (intern (buffer-name) buffers-altered)
  233.       (if (null vm-numbering-redo-start-point)
  234.           (progn 
  235.         (vm-set-numbering-redo-start-point (or prev t))
  236.         (vm-set-summary-redo-start-point (or prev t))))
  237.       ;; lock out interrupt to preserve message list integrity
  238.       (let ((inhibit-quit t))
  239.         (if (null prev)
  240.         (progn (setq vm-message-list (cdr vm-message-list))
  241.                (and (cdr mp)
  242.                 (vm-set-reverse-link-of (car (cdr mp)) nil)))
  243.           (setcdr prev (cdr mp))
  244.           (and (cdr mp) (vm-set-reverse-link-of (car (cdr mp)) prev)))
  245.         ;; vm-clear-expunge-invalidated-undos uses this to recognize
  246.         ;; expunged messages.
  247.         (vm-set-deleted-flag-of (car mp) 'expunged)
  248.         ;; disable summary any summary update that may have
  249.         ;; already been scheduled.
  250.         (vm-set-su-start-of (car mp) nil)
  251.         (vm-set-buffer-modified-p t)
  252.         (vm-increment vm-modification-counter))))
  253.     (if (eq (vm-attributes-of (car mp))
  254.         (vm-attributes-of (vm-real-message-of (car mp))))
  255.         (save-excursion
  256.           (set-buffer (vm-buffer-of (vm-real-message-of (car mp))))
  257.           (vm-save-restriction
  258.            (widen)
  259.            (let ((buffer-read-only nil))
  260.          (delete-region (vm-start-of (vm-real-message-of (car mp)))
  261.                 (vm-end-of (vm-real-message-of (car mp)))))))))
  262.        (t (setq prev mp)))
  263.       (setq mp (cdr mp)))
  264.     (vm-display nil nil '(vm-expunge-folder) '(vm-expunge-folder))
  265.     (cond
  266.      (buffers-altered
  267.       (save-excursion
  268.     (mapatoms
  269.      (function
  270.       (lambda (buffer)
  271.         (set-buffer (symbol-name buffer))
  272.         (if (null vm-system-state)
  273.         (if (null vm-message-pointer)
  274.             ;; folder is now empty
  275.             (progn (setq vm-folder-type nil)
  276.                (vm-update-summary-and-mode-line))
  277.           (vm-preview-current-message))
  278.           (vm-update-summary-and-mode-line))
  279.         (if (not (eq major-mode 'vm-virtual-mode))
  280.         (setq vm-message-order-changed
  281.               (or vm-message-order-changed
  282.               vm-message-order-header-present)))
  283.         (vm-clear-expunge-invalidated-undos)))
  284.      buffers-altered))
  285.       (if (not shaddap)
  286.       (message "Deleted messages expunged.")))
  287.      (t (message "No messages are flagged for deletion.")))))
  288.