;;; Saving and piping messages under VM
;;; Copyright (C) 1989 Kyle E. Jones
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 1, or (at your option)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

(require 'vm)

;; (match-data) returns the match data as MARKERS, often corrupting
;; it in the process due to buffer narrowing, and the fact that buffers are
;; indexed from 1 while strings are indexed from 0. :-(
(defun vm-match-data ()
  (delq nil
	(apply 'nconc
	       (mapcar (function
			(lambda (n) (list (match-beginning n) (match-end n))))
		       '(0 1 2 3 4 5 6 7 8 9)))))

(defun vm-auto-select-folder (mp)
  (condition-case ()
      (catch 'match
	(let (header alist tuple-list)
	  (setq alist vm-auto-folder-alist)
	  (while alist
	    (setq header (vm-get-header-contents (car mp) (car (car alist))))
	    (if (null header)
		()
	      (setq tuple-list (cdr (car alist)))
	      (while tuple-list
		(if (let (case-fold-search)
		      (string-match (car (car tuple-list)) header))
		    (let* ((match-data (vm-match-data))
			   (buf (get-buffer-create " *VM scratch*")))
		      ;; Set up a buffer that matches our cached
		      ;; match data.
		      (save-excursion
			(set-buffer buf)
			(widen)
			(erase-buffer)
			(insert header)
			;; It appears that get-buffer-create clobbers the
			;; match-data.
			;;
			;; The match data is off by one because we matched
			;; a string and Emacs indexes strings from 0 and
			;; buffers from 1.
			;;
			;; Also store-match-data only accepts MARKERS!!
			;; AUGHGHGH!!
			(store-match-data
			 (mapcar (function (lambda (n) (vm-marker n)))
				 (mapcar '1+ match-data)))
			(throw 'match (eval (cdr (car tuple-list)))))))
		(setq tuple-list (cdr tuple-list))))
	    (setq alist (cdr alist)))
	  nil ))
    (error nil)))

(defun vm-auto-archive-messages ()
  "Save all unfiled messages that auto-match a folder via vm-auto-folder-alist
to their appropriate folders."
  (interactive)
  (if vm-mail-buffer
      (set-buffer vm-mail-buffer))
  (vm-error-if-folder-empty)
  (let ((auto-folder)
	(archived 0))
    ;; Need separate (let ...) so vm-message-pointer can revert back
    ;; in time for (vm-update-summary-and-mode-line).
    ;; vm-last-save-folder is tucked away here since archives shouldn't affect
    ;; its value.
    (let ((vm-message-pointer vm-message-list)
	  (vm-last-save-folder vm-last-save-folder)
	  (vm-move-after-deleting))
      (while vm-message-pointer
	(and (not (vm-filed-flag (car vm-message-pointer)))
	     (setq auto-folder (vm-auto-select-folder vm-message-pointer))
	     (progn (vm-save-message auto-folder)
		    (vm-increment archived)))
	(setq vm-message-pointer (cdr vm-message-pointer))))
    (if (zerop archived)
	(message "No messages archived")
      (message "%d message%s archived" archived (if (= 1 archived) "" "s"))
      (vm-update-summary-and-mode-line))))

;; unexpanded-folder is an old fashioned local variable.
(defun vm-save-message (folder &optional count unexpanded-folder)
  "Save the current message to a mail folder.
Prefix arg COUNT means save the next COUNT messages.  A negative COUNT means
save the previous COUNT.  If the folder already exists, the message
will be appended to it.  The saved messages are marked as being filed."
  (interactive
   (list
    (progn
      (vm-follow-summary-cursor)
      (let ((default (save-excursion
		       (if vm-mail-buffer
			   (set-buffer vm-mail-buffer))
		       (or (vm-auto-select-folder vm-message-pointer)
			   vm-last-save-folder)))
	    (dir (or vm-folder-directory default-directory)))
	(if default
	    (read-file-name (format "Save in folder: (default %s) "
				    default)
			    dir default nil )
	  (read-file-name "Save in folder: " dir nil nil))))
    (prefix-numeric-value current-prefix-arg)))
  (setq unexpanded-folder folder)
  (if vm-mail-buffer
      (set-buffer vm-mail-buffer))
  (vm-error-if-folder-empty)
  (or count (setq count 1))
  (if (not (eq vm-circular-folders t))
      (vm-check-count count))
  ;; Expand the filename forcing relative paths to resolve
  ;; into the folder directory.  The while loop is required
  ;; because expand-file-name does not always completely expand
  ;; its argument.
  (let ((default-directory (or vm-folder-directory default-directory)))
    (while (not (equal folder (setq folder (expand-file-name folder))))))
  ;; Confirm new folders, if the user requested this.
  (if (and vm-confirm-new-folders (interactive-p) (not (file-exists-p folder))
	   (not (y-or-n-p (format "%s does not exist, save there anyway? "
				  folder))))
      (error "Save aborted"))
  (if (not vm-visit-when-saving)
      ;; Check and see if we are currently visiting the folder
      ;; that the user wants to save to.
      (let ((blist (buffer-list)))
	(while blist
	  (if (equal (buffer-file-name (car blist)) folder)
	      (error "Folder %s is being visited, cannot save." folder))
	  (setq blist (cdr blist)))))
  (let ((vm-message-pointer vm-message-pointer)
	(direction (if (> count 0) 'forward 'backward))
	(folder-buffer)
	(mail-buffer (current-buffer))
	(counter)
	(count (vm-abs count)))
    (setq counter count)
    (if vm-visit-when-saving
	;; set inhibit-local-variables non-nil to protect
	;; against letter bombs.
	(let ((inhibit-local-variables t))
	  (setq folder-buffer (find-file-noselect folder))
	  (if (eq folder-buffer mail-buffer)
	      (error "This IS folder %s, you must save messages elsewhere."
		     buffer-file-name))))
    (save-restriction
      (widen)
      (while (not (zerop counter))
	(if (not vm-visit-when-saving)
	    (write-region (vm-start-of (car vm-message-pointer))
			  (vm-end-of (car vm-message-pointer))
			  folder t 'quiet)
	  (let ((start (vm-start-of (car vm-message-pointer)))
		(end (vm-end-of (car vm-message-pointer))))
	    (save-excursion
	      (set-buffer folder-buffer)
	      (let (buffer-read-only)
		(vm-save-restriction
		 (widen)
		 (goto-char (point-max))
		 (insert-buffer-substring mail-buffer start end)
		 (vm-increment vm-messages-not-on-disk)
		 (vm-clear-modification-flag-undos))))))
	(if (null (vm-filed-flag (car vm-message-pointer)))
	    (vm-set-filed-flag (car vm-message-pointer) t))
	(vm-decrement counter)
	(if (not (zerop counter))
	    (vm-move-message-pointer direction))))
    (if vm-visit-when-saving
	(progn
	  (save-excursion
	    (set-buffer folder-buffer)
	    (let (buffer-read-only)
	      (if (eq major-mode 'vm-mode)
		  (progn
		    (vm-assimilate-new-messages)
		    ;; If there's a current grouping, then the summary
		    ;; has already been redone in vm-group-messages.
		    (if (and vm-summary-buffer (not vm-current-grouping))
			(progn
			  (vm-do-summary)
			  (if (get-buffer-window vm-summary-buffer)
			      (vm-set-summary-pointer
			       (car vm-message-pointer)))))))))
	  (message "Message%s saved to buffer %s" (if (/= 1 count) "s" "")
		   (buffer-name folder-buffer)))
      (message "Message%s saved to %s" (if (/= 1 count) "s" "") folder)))
  (setq vm-last-save-folder unexpanded-folder)
  (if vm-delete-after-saving
      (vm-delete-message count))
  (vm-update-summary-and-mode-line))

(defun vm-save-message-sans-headers (file &optional count)
  "Save the current message to a file minus its header section.
Prefix arg COUNT means save the next COUNT messages.  A negative COUNT means
save the previous COUNT.  If the file already exists, the message
will be appended to it.  The saved messages are NOT marked as being filed,
because the filed attributes is meant to denote saving to mail folders and
this command should NOT be used to do that.  Use vm-save-message instead
\(normally bound to `s')."
  (interactive
   (progn
     (vm-follow-summary-cursor)
     (list
      (read-file-name "Write text to file: " nil nil nil)
      (prefix-numeric-value current-prefix-arg))))
  (if vm-mail-buffer
      (set-buffer vm-mail-buffer))
  (vm-error-if-folder-empty)
  (or count (setq count 1))
  (if (not (eq vm-circular-folders t))
      (vm-check-count count))
  (setq file (expand-file-name file))
  (if (not vm-visit-when-saving)
      ;; Check and see if we are currently visiting the file
      ;; that the user wants to save to.
      (let ((blist (buffer-list)))
	(while blist
	  (if (equal (buffer-file-name (car blist)) file)
	      (error "File %s is being visited, cannot save." file))
	  (setq blist (cdr blist)))))
  (let ((vm-message-pointer vm-message-pointer)
	(direction (if (> count 0) 'forward 'backward))
	(file-buffer)
	(mail-buffer (current-buffer))
	(counter)
	(count (vm-abs count)))
    (setq counter count)
    (if vm-visit-when-saving
	;; set inhibit-local-variables non-nil to protect
	;; against letter bombs.
	(let ((inhibit-local-variables t))
	  (setq file-buffer (find-file-noselect file))
	  (if (eq file-buffer mail-buffer)
	      (error "This IS file %s, you must write messages elsewhere."
		     buffer-file-name))))
    (save-restriction
      (widen)
      (while (not (zerop counter))
	(if (not vm-visit-when-saving)
	    (write-region (vm-text-of (car vm-message-pointer))
			  (vm-text-end-of (car vm-message-pointer))
			  file t 'quiet)
	  (let ((start (vm-text-of (car vm-message-pointer)))
		(end (vm-text-end-of (car vm-message-pointer))))
	    (save-excursion
	      (set-buffer file-buffer)
	      (save-excursion
		(let (buffer-read-only)
		  (vm-save-restriction
		   (widen)
		   (goto-char (point-max))
		   (insert-buffer-substring mail-buffer start end)))))))
	(vm-decrement counter)
	(if (not (zerop counter))
	    (vm-move-message-pointer direction))))
    (if vm-visit-when-saving
	(message "Message%s written to buffer %s" (if (/= 1 count) "s" "")
		 (buffer-name file-buffer))
      (message "Message%s written to %s" (if (/= 1 count) "s" "") file)))
  (vm-update-summary-and-mode-line))

(defun vm-pipe-message-to-command (command prefix-arg)
  "Run shell command with the some or all of the current message as input.
By default the entire message is used.
With one \\[universal-argument] the text portion of the message is used.
With two \\[universal-argument]'s the header portion of the message is used.

Output is discarded.  The message is not altered."
  (interactive
   (progn
     (vm-follow-summary-cursor)
     (list (read-string "Pipe message to command: " vm-last-pipe-command)
	   current-prefix-arg)))
  (if vm-mail-buffer
      (set-buffer vm-mail-buffer))
  (vm-error-if-folder-empty)
  (setq vm-last-pipe-command command)
  (let ((buffer (get-buffer-create "*Shell Command Output*"))
	(pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))))
    (save-excursion (set-buffer buffer) (erase-buffer))
    (save-restriction
      (widen)
      (cond ((equal prefix-arg nil)
	     (narrow-to-region (vm-start-of (car vm-message-pointer))
			       (vm-end-of (car vm-message-pointer))))
	    ((equal prefix-arg '(4))
	     (narrow-to-region (vm-text-of (car vm-message-pointer))
			       (vm-text-end-of (car vm-message-pointer))))
	    ((equal prefix-arg '(16))
	     (narrow-to-region (vm-start-of (car vm-message-pointer))
			       (vm-text-of (car vm-message-pointer))))
	    (t (narrow-to-region (vm-start-of (car vm-message-pointer))
				 (vm-end-of (car vm-message-pointer)))))
      (let ((pop-up-windows (and pop-up-windows (eq vm-mutable-windows t))))
	(call-process-region (point-min) (point-max)
			     (or shell-file-name "sh")
			     nil buffer nil "-c" command)))
    (set-buffer buffer)
    (if (not (zerop (buffer-size)))
	(display-buffer buffer))))
