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