home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / vm / vm-5.33beta / vm-save.el < prev    next >
Encoding:
Text File  |  1991-04-11  |  13.0 KB  |  348 lines
  1. ;;; Saving and piping messages under VM
  2. ;;; Copyright (C) 1989, 1990 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. ;; (match-data) returns the match data as MARKERS, often corrupting
  19. ;; it in the process due to buffer narrowing, and the fact that buffers are
  20. ;; indexed from 1 while strings are indexed from 0. :-(
  21. (defun vm-match-data ()
  22.   (let ((index '(9 8 7 6 5 4 3 2 1 0))
  23.         (list))
  24.     (while index
  25.       (setq list (cons (match-beginning (car index))
  26.                (cons (match-end (car index)) list))
  27.         index (cdr index)))
  28.     list ))
  29.  
  30. (defun vm-auto-select-folder (mp auto-folder-alist)
  31.   (condition-case ()
  32.       (catch 'match
  33.     (let (header alist tuple-list)
  34.       (setq alist auto-folder-alist)
  35.       (while alist
  36.         (setq header (vm-get-header-contents (car mp) (car (car alist))))
  37.         (if (null header)
  38.         ()
  39.           (setq tuple-list (cdr (car alist)))
  40.           (while tuple-list
  41.         (if (let ((case-fold-search vm-auto-folder-case-fold-search))
  42.               (string-match (car (car tuple-list)) header))
  43.             ;; Don't waste time eval'ing an atom.
  44.             (if (atom (cdr (car tuple-list)))
  45.             (throw 'match (cdr (car tuple-list)))
  46.               (let* ((match-data (vm-match-data))
  47.                  (buf (get-buffer-create " *VM scratch*"))
  48.                  (result))
  49.             ;; Set up a buffer that matches our cached
  50.             ;; match data.
  51.             (save-excursion
  52.               (set-buffer buf)
  53.               (widen)
  54.               (erase-buffer)
  55.               (insert header)
  56.               ;; It appears that get-buffer-create clobbers the
  57.               ;; match-data.
  58.               ;;
  59.               ;; The match data is off by one because we matched
  60.               ;; a string and Emacs indexes strings from 0 and
  61.               ;; buffers from 1.
  62.               ;;
  63.               ;; Also store-match-data only accepts MARKERS!!
  64.               ;; AUGHGHGH!!
  65.               (store-match-data
  66.                (mapcar
  67.                 (function (lambda (n) (and n (vm-marker n))))
  68.                 (mapcar
  69.                  (function (lambda (n) (and n (1+ n))))
  70.                  match-data)))
  71.               (setq result (eval (cdr (car tuple-list))))
  72.               (throw 'match (if (listp result)
  73.                         (vm-auto-select-folder mp result)
  74.                       result ))))))
  75.         (setq tuple-list (cdr tuple-list))))
  76.         (setq alist (cdr alist)))
  77.       nil ))
  78.     (error nil)))
  79.  
  80. (defun vm-auto-archive-messages (&optional arg)
  81.   "Save all unfiled messages that auto-match a folder via vm-auto-folder-alist
  82. to their appropriate folders.  Deleted message are not saved.
  83.  
  84. Prefix arg means to ask user for confirmation before saving each message."
  85.   (interactive "P")
  86.   (vm-select-folder-buffer)
  87.   (vm-check-for-killed-summary)
  88.   (vm-error-if-folder-empty)
  89.   (let ((auto-folder)
  90.     (archived 0))
  91.     ;; Need separate (let ...) so vm-message-pointer can revert back
  92.     ;; in time for (vm-update-summary-and-mode-line).
  93.     ;; vm-last-save-folder is tucked away here since archives shouldn't affect
  94.     ;; its value.
  95.     (let ((vm-message-pointer vm-message-list)
  96.       (vm-last-save-folder vm-last-save-folder)
  97.       (vm-move-after-deleting))
  98.       (while vm-message-pointer
  99.     (and (not (vm-filed-flag (car vm-message-pointer)))
  100.          ;; don't archive deleted messages
  101.          (not (vm-deleted-flag (car vm-message-pointer)))
  102.          (setq auto-folder (vm-auto-select-folder vm-message-pointer
  103.                               vm-auto-folder-alist))
  104.          (or (null arg)
  105.          (y-or-n-p
  106.           (format "Save message %s in folder %s? "
  107.               (vm-number-of (car vm-message-pointer))
  108.               auto-folder)))
  109.          (progn (vm-save-message auto-folder)
  110.             (and vm-delete-after-archiving (vm-delete-message 1))
  111.             (vm-increment archived)))
  112.     (setq vm-message-pointer (cdr vm-message-pointer))))
  113.     (if (zerop archived)
  114.     (message "No messages archived")
  115.       (message "%d message%s archived" archived (if (= 1 archived) "" "s"))
  116.       (vm-update-summary-and-mode-line))))
  117.  
  118. (defun vm-save-message (folder &optional count)
  119.   "Save the current message to a mail folder.
  120. If the folder already exists, the message will be appended to it.
  121. Prefix arg COUNT means save the next COUNT messages.  A negative COUNT means
  122. save the previous COUNT messages.
  123.  
  124. When invoked on marked messages (via vm-next-command-uses-marks),
  125. all marked message in the current folder are saved; other messages are
  126. ignored.
  127.  
  128. The saved messages are flagged as `filed'."
  129.   (interactive
  130.    (list
  131.     ;; protect value of last-command
  132.     (let ((last-command last-command))
  133.       (vm-follow-summary-cursor)
  134.       (let ((default (save-excursion
  135.                (vm-select-folder-buffer)
  136.                (vm-check-for-killed-summary)
  137.                (or (vm-auto-select-folder vm-message-pointer
  138.                           vm-auto-folder-alist)
  139.                vm-last-save-folder)))
  140.         (dir (or vm-folder-directory default-directory)))
  141.     (if default
  142.         (read-file-name (format "Save in folder: (default %s) "
  143.                     default)
  144.                 dir default nil )
  145.       (read-file-name "Save in folder: " dir nil nil))))
  146.     (prefix-numeric-value current-prefix-arg)))
  147.   (let (unexpanded-folder)
  148.     (setq unexpanded-folder folder)
  149.     (vm-select-folder-buffer)
  150.     (vm-check-for-killed-summary)
  151.     (vm-error-if-folder-empty)
  152.     (or count (setq count 1))
  153.     ;; Expand the filename, forcing relative paths to resolve
  154.     ;; into the folder directory.
  155.     (let ((default-directory
  156.         (expand-file-name (or vm-folder-directory default-directory))))
  157.       (setq folder (expand-file-name folder)))
  158.     ;; Confirm new folders, if the user requested this.
  159.     (if (and vm-confirm-new-folders (interactive-p)
  160.          (not (file-exists-p folder))
  161.          (or (not vm-visit-when-saving) (not (get-file-buffer folder)))
  162.          (not (y-or-n-p (format "%s does not exist, save there anyway? "
  163.                     folder))))
  164.     (error "Save aborted"))
  165.     ;; Check and see if we are currently visiting the folder
  166.     ;; that the user wants to save to.
  167.     (if (and (not vm-visit-when-saving) (get-file-buffer folder))
  168.     (error "Folder %s is being visited, cannot save." folder))
  169.     (let ((mlist (vm-select-marked-or-prefixed-messages count))
  170.       folder-buffer)
  171.       (cond ((eq vm-visit-when-saving t)
  172.          (setq folder-buffer (or (get-file-buffer folder)
  173.                      (find-file-noselect folder))))
  174.         (vm-visit-when-saving
  175.          (setq folder-buffer (get-file-buffer folder))))
  176.       (save-excursion
  177.     (while mlist
  178.       (set-buffer (marker-buffer (vm-start-of (car mlist))))
  179.       (vm-save-restriction
  180.        (widen)
  181.        ;; if message is deleted then we have to restuff with
  182.        ;; the delete flag suppressed before we save.
  183.        (if (or (vm-modflag-of (car mlist)) (vm-deleted-flag (car mlist)))
  184.            (vm-stuff-attributes (car mlist) t))
  185.        (if (null folder-buffer)
  186.            (write-region (vm-start-of (car mlist))
  187.                  (vm-end-of (car mlist))
  188.                  folder t 'quiet)
  189.          (let ((start (vm-start-of (car mlist)))
  190.            (end (vm-end-of (car mlist))))
  191.            (save-excursion
  192.          (set-buffer folder-buffer)
  193.          (let (buffer-read-only)
  194.            (vm-save-restriction
  195.             (widen)
  196.             (save-excursion
  197.               (goto-char (point-max))
  198.               (insert-buffer-substring
  199.                (marker-buffer (vm-start-of (car mlist)))
  200.                start end))
  201.             ;; vars should exist and be local
  202.             ;; but they may have strange values,
  203.             ;; so check the major-mode.
  204.             (cond ((eq major-mode 'vm-mode)
  205.                (vm-increment vm-messages-not-on-disk)
  206.                (vm-set-buffer-modified-p (buffer-modified-p))
  207.                (vm-clear-modification-flag-undos))))))))
  208.        (if (null (vm-filed-flag (car mlist)))
  209.            (vm-set-filed-flag (car mlist) t))
  210.        (setq mlist (cdr mlist)))))
  211.       (if folder-buffer
  212.       (progn
  213.         (save-excursion
  214.           (set-buffer folder-buffer)
  215.           (if (eq major-mode 'vm-mode)
  216.           (let (buffer-read-only)
  217.             (vm-check-for-killed-summary)
  218.             (vm-assimilate-new-messages)
  219.             (vm-update-summary-and-mode-line))))
  220.         (message "Message%s saved to buffer %s" (if (/= 1 count) "s" "")
  221.              (buffer-name folder-buffer)))
  222.     (message "Message%s saved to %s" (if (/= 1 count) "s" "") folder)))
  223.     (setq vm-last-save-folder unexpanded-folder)
  224.     (if vm-delete-after-saving
  225.     (vm-delete-message count))
  226.     (vm-update-summary-and-mode-line)))
  227.  
  228. (defun vm-save-message-sans-headers (file &optional count)
  229.   "Save the current message to a file, without its header section.
  230. If the file already exists, the message will be appended to it.
  231. Prefix arg COUNT means save the next COUNT messages.  A negative COUNT means
  232. save the previous COUNT.
  233.  
  234. When invoked on marked messages (via vm-next-command-uses-marks),
  235. all marked messages in the current folder are saved; other messages are
  236. ignored.
  237.  
  238. The saved messages are flagged as `written'.
  239.  
  240. This command should NOT be used to save message to mail folders; use
  241. vm-save-message instead (normally bound to `s')."
  242.   (interactive
  243.    ;; protect value of last-command
  244.    (let ((last-command last-command))
  245.      (vm-follow-summary-cursor)
  246.      (list
  247.       (read-file-name "Write text to file: " nil nil nil)
  248.       (prefix-numeric-value current-prefix-arg))))
  249.   (vm-select-folder-buffer)
  250.   (vm-check-for-killed-summary)
  251.   (vm-error-if-folder-empty)
  252.   (or count (setq count 1))
  253.   (setq file (expand-file-name file))
  254.   ;; Check and see if we are currently visiting the file
  255.   ;; that the user wants to save to.
  256.   (if (and (not vm-visit-when-saving) (get-file-buffer file))
  257.       (error "File %s is being visited, cannot save." file))
  258.   (let ((mlist (vm-select-marked-or-prefixed-messages count))
  259.     file-buffer)
  260.     (cond ((eq vm-visit-when-saving t)
  261.        (setq file-buffer (or (get-file-buffer file)
  262.                  (find-file-noselect file))))
  263.       (vm-visit-when-saving
  264.        (setq file-buffer (get-file-buffer file))))
  265.     (save-excursion
  266.       (while mlist
  267.     (set-buffer (marker-buffer (vm-start-of (car mlist))))
  268.     (vm-save-restriction
  269.      (widen)
  270.      (if (null file-buffer)
  271.          (write-region (vm-text-of (car mlist))
  272.                (vm-text-end-of (car mlist))
  273.                file t 'quiet)
  274.        (let ((start (vm-text-of (car mlist)))
  275.          (end (vm-text-end-of (car mlist))))
  276.          (save-excursion
  277.            (set-buffer file-buffer)
  278.            (save-excursion
  279.          (let (buffer-read-only)
  280.            (vm-save-restriction
  281.             (widen)
  282.             (save-excursion
  283.               (goto-char (point-max))
  284.               (insert-buffer-substring
  285.                (marker-buffer (vm-start-of (car mlist)))
  286.                start end))))))))
  287.     (if (null (vm-written-flag (car mlist)))
  288.         (vm-set-written-flag (car mlist) t))
  289.     (setq mlist (cdr mlist)))))
  290.     (if file-buffer
  291.     (message "Message%s written to buffer %s" (if (/= 1 count) "s" "")
  292.          (buffer-name file-buffer))
  293.       (message "Message%s written to %s" (if (/= 1 count) "s" "") file)))
  294.   (vm-update-summary-and-mode-line))
  295.  
  296. (defun vm-pipe-message-to-command (command prefix-arg)
  297.   "Run shell command with the some or all of the current message as input.
  298. By default the entire message is used.
  299. With one \\[universal-argument] the text portion of the message is used.
  300. With two \\[universal-argument]'s the header portion of the message is used.
  301.  
  302. When invoked on marked messages (via vm-next-command-uses-marks),
  303. each marked message is successively piped to the shell command,
  304. one message per command invocation.
  305.  
  306. Output, if any, is displayed.  The message is not altered."
  307.   (interactive
  308.    ;; protect value of last-command
  309.    (let ((last-command last-command))
  310.      (vm-follow-summary-cursor)
  311.      (list (read-string "Pipe to command: " vm-last-pipe-command)
  312.        current-prefix-arg)))
  313.   (vm-select-folder-buffer)
  314.   (vm-check-for-killed-summary)
  315.   (vm-error-if-folder-empty)
  316.   (setq vm-last-pipe-command command)
  317.   (let ((buffer (get-buffer-create "*Shell Command Output*"))
  318.     (pop-up-windows (and pop-up-windows (eq vm-mutable-windows t)))
  319.     ;; prefix arg doesn't have "normal" meaning here, so only call
  320.     ;; vm-select-marked-or-prefixed-messages if we're using marks.
  321.     (mlist (if (eq last-command 'vm-next-command-uses-marks)
  322.            (vm-select-marked-or-prefixed-messages 0)
  323.          (list (car vm-message-pointer)))))
  324.     (save-excursion (set-buffer buffer) (erase-buffer))
  325.     (save-excursion
  326.      (while mlist
  327.        (set-buffer (marker-buffer (vm-start-of (car mlist))))
  328.        (save-restriction
  329.      (widen)
  330.      (goto-char (vm-start-of (car mlist)))
  331.      (forward-line)
  332.      (cond ((equal prefix-arg nil)
  333.         (narrow-to-region (point) (vm-text-end-of (car mlist))))
  334.            ((equal prefix-arg '(4))
  335.         (narrow-to-region (vm-text-of (car mlist))
  336.                   (vm-text-end-of (car mlist))))
  337.            ((equal prefix-arg '(16))
  338.         (narrow-to-region (point) (vm-text-of (car mlist))))
  339.            (t (narrow-to-region (point) (vm-text-end-of (car mlist)))))
  340.      (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))))
  341.        (call-process-region (point-min) (point-max)
  342.                 (or shell-file-name "sh")
  343.                 nil buffer nil "-c" command)))
  344.        (setq mlist (cdr mlist)))
  345.      (set-buffer buffer)
  346.      (if (not (zerop (buffer-size)))
  347.      (display-buffer buffer)))))
  348.