home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-delete.el < prev    next >
Encoding:
Text File  |  1991-04-06  |  6.3 KB  |  175 lines
  1. ;;; Delete and expunge commands for VM.
  2. ;;; Copyright (C) 1989, 1990, 1991 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. (defun vm-delete-message (count)
  19.   "Add the `deleted' attribute to the current message.
  20.  
  21. The message will be physically deleted from the current folder the next
  22. time the current folder is expunged.
  23.  
  24. With a prefix argument, the next COUNT messages are deleted.  A negative
  25. argument means the previous COUNT messages are deleted.
  26.  
  27. When invoked on marked messages (via vm-next-command-uses-marks),
  28. all marked messages are deleted, other messages are ignored."
  29.   (interactive "p")
  30.   (if (interactive-p)
  31.       (vm-follow-summary-cursor))
  32.   (vm-select-folder-buffer)
  33.   (vm-check-for-killed-summary)
  34.   (vm-error-if-folder-read-only)
  35.   (vm-error-if-folder-empty)
  36.   (let* ((used-marks (eq last-command 'vm-next-command-uses-marks))
  37.      (mlist (vm-select-marked-or-prefixed-messages count)))
  38.     (while mlist
  39.       (if (not (vm-deleted-flag (car mlist)))
  40.       (vm-set-deleted-flag (car mlist) t))
  41.       (setq mlist (cdr mlist)))
  42.     (vm-update-summary-and-mode-line)
  43.     (if (and vm-move-after-deleting (not used-marks))
  44.     (vm-next-message count t executing-kbd-macro))))
  45.  
  46. (defun vm-delete-message-backward (count)
  47.   "Like vm-delete-message, except that the deletion direction is reversed."
  48.   (interactive "p")
  49.   (let ((prefix-arg (- count)))
  50.     (command-execute 'vm-delete-message)))
  51.  
  52. (defun vm-undelete-message (count)
  53.   "Remove the `deleted' attribute from the current message.
  54.  
  55. With a prefix argument, the next COUNT messages are undeleted.  A
  56. negative argument means the previous COUNT messages are undeleted.
  57.  
  58. When invoked on marked messages (via vm-next-command-uses-marks),
  59. all marked messages are undeleted, other messages are ignored."
  60.   (interactive "p")
  61.   (if (interactive-p)
  62.       (vm-follow-summary-cursor))
  63.   (vm-select-folder-buffer)
  64.   (vm-check-for-killed-summary)
  65.   (vm-error-if-folder-read-only)
  66.   (vm-error-if-folder-empty)
  67.   (let* ((used-marks (eq last-command 'vm-next-command-uses-marks))
  68.      (mlist (vm-select-marked-or-prefixed-messages count)))
  69.     (while mlist
  70.       (if (vm-deleted-flag (car mlist))
  71.       (vm-set-deleted-flag (car mlist) nil))
  72.       (setq mlist (cdr mlist)))
  73.     (vm-update-summary-and-mode-line)
  74.     (if (and vm-move-after-undeleting (not used-marks))
  75.     (vm-next-message count t executing-kbd-macro))))
  76.  
  77. (defun vm-kill-subject ()
  78.   "Delete all messages with the same subject as the current message
  79. \(ignoring re:'s)."
  80.   (interactive)
  81.   (vm-follow-summary-cursor)
  82.   (vm-select-folder-buffer)
  83.   (vm-check-for-killed-summary)
  84.   (vm-error-if-folder-read-only)
  85.   (vm-error-if-folder-empty)
  86.   (let ((subject (vm-su-subject (car vm-message-pointer)))
  87.     (mp vm-message-list)
  88.     (n 0))
  89.     (if (string-match "^\\(re: *\\)+" subject)
  90.     (setq subject (substring subject (match-end 0))))
  91.     (setq subject (concat "^\\(re: *\\)*" (regexp-quote subject) " *$"))
  92.     (while mp
  93.       (if (and (not (vm-deleted-flag (car mp)))
  94.            (string-match subject (vm-su-subject (car mp))))
  95.       (progn
  96.         (vm-set-deleted-flag (car mp) t)
  97.         (vm-increment n)))
  98.       (setq mp (cdr mp)))
  99.     (and (interactive-p)
  100.        (if (zerop n)
  101.        (message "No messages deleted.")
  102.      (message "%d message%s deleted" n (if (= n 1) "" "s")))))
  103.   (vm-update-summary-and-mode-line))
  104.  
  105. (defun vm-expunge-folder (&optional quitting shaddap)
  106.   "Expunge deleted messages, but don't save folder to disk or exit VM."
  107.   (interactive)
  108.   (vm-select-folder-buffer)
  109.   (vm-check-for-killed-summary)
  110.   (vm-error-if-folder-read-only)
  111.   (vm-error-if-referenced-virtually)
  112.   (if (not shaddap)
  113.       (message "Expunging..."))
  114.   (let ((inhibit-quit t) did-gobble)
  115.     (if (setq did-gobble (vm-gobble-deleted-messages))
  116.     (progn
  117.       (setq vm-numbering-redo-start-point did-gobble
  118.         vm-summary-redo-start-point did-gobble
  119.         vm-totals nil)
  120.       (if (not quitting)
  121.           (progn
  122.         (if (not shaddap)
  123.             (vm-deferred-message "Deleted messages expunged."))
  124.         (if (null vm-message-pointer)
  125.             (if (null vm-message-list)
  126.             (vm-update-summary-and-mode-line)
  127.               (vm-next-message))
  128.           (if (null vm-system-state)
  129.               (vm-preview-current-message)
  130.             (vm-update-summary-and-mode-line))))))
  131.       (error "No messages are flagged for deletion."))))
  132.  
  133. ;; Remove any message marked for deletion from the buffer and the
  134. ;; message list.
  135. (defun vm-gobble-deleted-messages ()
  136.   (save-excursion
  137.     (vm-save-restriction
  138.      (widen)
  139.      (let ((mp vm-message-list)
  140.        (old-message-list vm-message-list)
  141.        virtual prev buffer-read-only tail-cons did-gobble)
  142.        (setq virtual
  143.          (and mp (not (eq (car mp) (vm-real-message-of (car mp))))))
  144.        (while mp
  145.      (if (not (vm-deleted-flag (car mp)))
  146.          (setq prev mp)
  147.        (or did-gobble (setq did-gobble (or prev vm-message-list)))
  148.        (or virtual (delete-region (vm-start-of (car mp))
  149.                       (vm-end-of (car mp))))
  150.        (if (null prev)
  151.            (progn (setq vm-message-list (cdr vm-message-list))
  152.               (vm-set-reverse-link-of (car mp) nil))
  153.          (setcdr prev (cdr mp))
  154.          (and (cdr mp) (vm-set-reverse-link-of (car (cdr mp)) prev))))
  155.      (setq mp (cdr mp)))
  156.        (if (and did-gobble (eq did-gobble old-message-list))
  157.        (setq did-gobble t))
  158.        (if did-gobble
  159.        (progn
  160.          (vm-clear-expunge-invalidated-undos)
  161.          (vm-set-buffer-modified-p t)
  162.          (setq vm-message-order-changed vm-message-order-stuffed)
  163.          (cond ((and vm-last-message-pointer
  164.              (vm-deleted-flag (car vm-last-message-pointer)))
  165.             (setq vm-last-message-pointer nil)))
  166.          (cond ((and vm-message-pointer
  167.              (vm-deleted-flag (car vm-message-pointer)))
  168.             (setq vm-system-state nil)
  169.             (setq mp (cdr vm-message-pointer))
  170.             (while (and mp (vm-deleted-flag (car mp)))
  171.               (setq mp (cdr mp)))
  172.             (setq vm-message-pointer
  173.               (or mp (vm-last vm-message-list)))))
  174.          did-gobble ))))))
  175.