X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/06aa1ec4bf66181248fc44a3e5953d41c7cc0a97..7c7d40755ab10f374dd656e9f0e5f2a158ae9edb:/lisp/mail/rmailout.el

diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el
index fa96fb9316..0dd23d71d3 100644
--- a/lisp/mail/rmailout.el
+++ b/lisp/mail/rmailout.el
@@ -1,6 +1,6 @@
-;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file.
+;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file
 
-;; Copyright (C) 1985, 1987, 1993 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 1987, 1993, 1994, 2001 Free Software Foundation, Inc.
 
 ;; Maintainer: FSF
 ;; Keywords: mail
@@ -18,84 +18,127 @@
 ;; GNU General Public License for more details.
 
 ;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING.  If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+;; along with GNU Emacs; see the file COPYING.  If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Commentary:
 
 ;;; Code:
 
 (require 'rmail)
+(provide 'rmailout)
 
-;; Temporary until Emacs always has this variable.
-(defvar rmail-delete-after-output nil
-  "*Non-nil means automatically delete a message that is copied to a file.")
-
-(defvar rmail-output-file-alist nil
+;;;###autoload
+(defcustom rmail-output-file-alist nil
   "*Alist matching regexps to suggested output Rmail files.
 This is a list of elements of the form (REGEXP . NAME-EXP).
 The suggestion is taken if REGEXP matches anywhere in the message buffer.
 NAME-EXP may be a string constant giving the file name to use,
 or more generally it may be any kind of expression that returns
-a file name as a string.")
+a file name as a string."
+  :type '(repeat (cons regexp
+		       (choice :value ""
+			       (string :tag "File Name")
+			       sexp)))
+  :group 'rmail-output)
 
-(defun rmail-output-menu (event)
-  "Output current message to another Rmail file, chosen with a menu."
-  (interactive "e")
-  (rmail-output-to-rmail-file
-   (expand-file-name (rmail-secondary-file-menu event)
-		     rmail-secondary-file-directory)))
+(defun rmail-output-read-rmail-file-name ()
+  "Read the file name to use for `rmail-output-to-rmail-file'.
+Set `rmail-default-rmail-file' to this name as well as returning it."
+  (let ((default-file
+	  (let (answer tail)
+	    (setq tail rmail-output-file-alist)
+	    ;; Suggest a file based on a pattern match.
+	    (while (and tail (not answer))
+	      (save-excursion
+		(set-buffer rmail-buffer)
+		(goto-char (point-min))
+		(if (re-search-forward (car (car tail)) nil t)
+		    (setq answer (eval (cdr (car tail)))))
+		(setq tail (cdr tail))))
+	    ;; If no suggestions, use same file as last time.
+	    (expand-file-name (or answer rmail-default-rmail-file)))))
+    (let ((read-file
+	   (expand-file-name
+	    (read-file-name
+	     (concat "Output message to Rmail file: (default "
+		     (file-name-nondirectory default-file)
+		     ") ")
+	     (file-name-directory default-file)
+	     (abbreviate-file-name default-file))
+	    (file-name-directory default-file))))
+      ;; If the user enters just a directory,
+      ;; use the name within that directory chosen by the default.
+      (setq rmail-default-rmail-file
+	    (if (file-directory-p read-file)
+		(expand-file-name (file-name-nondirectory default-file)
+				  read-file)
+	      read-file)))))
+
+(defun rmail-output-read-file-name ()
+  "Read the file name to use for `rmail-output'.
+Set `rmail-default-file' to this name as well as returning it."
+  (let ((default-file
+	  (let (answer tail)
+	    (setq tail rmail-output-file-alist)
+	    ;; Suggest a file based on a pattern match.
+	    (while (and tail (not answer))
+	      (save-excursion
+		(goto-char (point-min))
+		(if (re-search-forward (car (car tail)) nil t)
+		    (setq answer (eval (cdr (car tail)))))
+		(setq tail (cdr tail))))
+	    ;; If no suggestion, use same file as last time.
+	    (or answer rmail-default-file))))
+    (let ((read-file
+	   (expand-file-name
+	    (read-file-name
+	     (concat "Output message to Unix mail file: (default "
+		     (file-name-nondirectory default-file)
+		     ") ")
+	     (file-name-directory default-file)
+	     (abbreviate-file-name default-file))
+	    (file-name-directory default-file))))
+      (setq rmail-default-file
+	    (if (file-directory-p read-file)
+		(expand-file-name (file-name-nondirectory default-file)
+				  read-file)
+	      (expand-file-name
+	       (or read-file (file-name-nondirectory default-file))
+	       (file-name-directory default-file)))))))
 
-;;; There are functions elsewhere in Emacs that use this function; check
-;;; them out before you change the calling method.
-(defun rmail-output-to-rmail-file (file-name &optional count)
+;;; There are functions elsewhere in Emacs that use this function;
+;;; look at them before you change the calling method.
+;;;###autoload
+(defun rmail-output-to-rmail-file (file-name &optional count stay)
   "Append the current message to an Rmail file named FILE-NAME.
 If the file does not exist, ask if it should be created.
 If file is being visited, the message is appended to the Emacs
 buffer visiting that file.
-If the file exists and is not an Rmail file, 
-the message is appended in inbox format.
+If the file exists and is not an Rmail file, the message is
+appended in inbox format, the same way `rmail-output' does it.
 
-The default file name comes from `rmail-last-rmail-file',
+The default file name comes from `rmail-default-rmail-file',
 which is updated to the name you use in this command.
 
 A prefix argument N says to output N consecutive messages
-starting with the current one.  Deleted messages are skipped and don't count."
+starting with the current one.  Deleted messages are skipped and don't count.
+
+If optional argument STAY is non-nil, then leave the last filed
+mesasge up instead of moving forward to the next non-deleted message."
   (interactive
-   (let ((default-file
-	   (let (answer tail)
-	     (setq tail rmail-output-file-alist)
-	     ;; Suggest a file based on a pattern match.
-	     (while (and tail (not answer))
-	       (save-excursion
-		 (goto-char (point-min))
-		 (if (re-search-forward (car (car tail)) nil t)
-		     (setq answer (eval (cdr (car tail)))))
-		 (setq tail (cdr tail))))
-	     ;; If not suggestions, use same file as last time.
-	     (or answer rmail-default-rmail-file))))
-     (list (setq rmail-default-rmail-file
-		 (let ((read-file
-			(read-file-name
-			 (concat "Output message to Rmail file: (default "
-				 (file-name-nondirectory default-file)
-				 ") ")
-			 (file-name-directory default-file)
-			 default-file)))
-		   (if (file-directory-p read-file)
-		       (expand-file-name (file-name-nondirectory default-file)
-					 read-file)
-		     (expand-file-name
-		      (or read-file default-file)
-		      (file-name-directory default-file)))))
-	   (prefix-numeric-value current-prefix-arg))))
+   (list (rmail-output-read-rmail-file-name)
+	 (prefix-numeric-value current-prefix-arg)))
   (or count (setq count 1))
   (setq file-name
 	(expand-file-name file-name
 			  (file-name-directory rmail-default-rmail-file)))
-  (if (and (file-readable-p file-name) (not (rmail-file-p file-name)))
+  (if (and (file-readable-p file-name) (not (mail-file-babyl-p file-name)))
       (rmail-output file-name count)
     (rmail-maybe-set-message-counters)
     (setq file-name (abbreviate-file-name file-name))
-    (or (get-file-buffer file-name)
+    (or (find-buffer-visiting file-name)
 	(file-exists-p file-name)
 	(if (yes-or-no-p
 	     (concat "\"" file-name "\" does not exist, create it? "))
@@ -103,7 +146,10 @@ starting with the current one.  Deleted messages are skipped and don't count."
 	      (save-excursion
 		(set-buffer file-buffer)
 		(rmail-insert-rmail-file-header)
-		(let ((require-final-newline nil))
+		(let ((require-final-newline nil)
+		      (coding-system-for-write
+		       (or rmail-file-coding-system
+			   'emacs-mule-unix)))
 		  (write-region (point-min) (point-max) file-name t 1)))
 	      (kill-buffer file-buffer))
 	  (error "Output file does not exist")))
@@ -111,6 +157,7 @@ starting with the current one.  Deleted messages are skipped and don't count."
       (let (redelete)
 	(unwind-protect
 	    (progn
+	      (set-buffer rmail-buffer)
 	      ;; Temporarily turn off Deleted attribute.
 	      ;; Do this outside the save-restriction, since it would
 	      ;; shift the place in the buffer where the visible text starts.
@@ -121,12 +168,25 @@ starting with the current one.  Deleted messages are skipped and don't count."
 		(widen)
 		;; Decide whether to append to a file or to an Emacs buffer.
 		(save-excursion
-		  (let ((buf (get-file-buffer file-name))
+		  (let ((buf (find-buffer-visiting file-name))
 			(cur (current-buffer))
 			(beg (1+ (rmail-msgbeg rmail-current-message)))
-			(end (1+ (rmail-msgend rmail-current-message))))
+			(end (1+ (rmail-msgend rmail-current-message)))
+			(coding-system-for-write
+			 (or rmail-file-coding-system
+			     'emacs-mule-unix)))
 		    (if (not buf)
-			(append-to-file beg end file-name)
+			;; Output to a file.
+			(if rmail-fields-not-to-output
+			    ;; Delete some fields while we output.
+			    (let ((obuf (current-buffer)))
+			      (set-buffer (get-buffer-create " rmail-out-temp"))
+			      (insert-buffer-substring obuf beg end)
+			      (rmail-delete-unwanted-fields)
+			      (append-to-file (point-min) (point-max) file-name)
+			      (set-buffer obuf)
+			      (kill-buffer (get-buffer " rmail-out-temp")))
+			  (append-to-file beg end file-name))
 		      (if (eq buf (current-buffer))
 			  (error "Can't output message to same file it's already in"))
 		      ;; File has been visited, in buffer BUF.
@@ -150,36 +210,58 @@ starting with the current one.  Deleted messages are skipped and don't count."
 			      (widen)
 			      (search-backward "\n\^_")
 			      (narrow-to-region (point) (point-max))
+			      (rmail-delete-unwanted-fields)
 			      (rmail-count-new-messages t)
 			      (if (rmail-summary-exists)
 				  (rmail-select-summary
 				    (rmail-update-summary)))
 			      (rmail-show-message msg))
-		;; Output file not in rmail mode => just insert at the end.
-		(narrow-to-region (point-min) (1+ (buffer-size)))
-		(goto-char (point-max))
-		(insert-buffer-substring cur beg end)))))))
+			  ;; Output file not in rmail mode => just insert at the end.
+			  (narrow-to-region (point-min) (1+ (buffer-size)))
+			  (goto-char (point-max))
+			  (insert-buffer-substring cur beg end)
+			  (rmail-delete-unwanted-fields)))))))
 	      (rmail-set-attribute "filed" t))
 	  (if redelete (rmail-set-attribute "deleted" t))))
       (setq count (1- count))
       (if rmail-delete-after-output
-	  (rmail-delete-forward)
+	  (unless
+	      (if (and (= count 0) stay)
+		  (rmail-delete-message)
+		(rmail-delete-forward))
+	    (setq count 0))
 	(if (> count 0)
-	    (rmail-next-undeleted-message 1))))))
+	    (unless
+		(if (not stay) (rmail-next-undeleted-message 1))
+	      (setq count 0)))))))
 
-;; Returns t if file FILE is an Rmail file.
 ;;;###autoload
-(defun rmail-file-p (file)
-  (let ((buf (generate-new-buffer " *rmail-file-p*")))
-    (unwind-protect
-	(save-excursion
-	  (set-buffer buf)
-	  (insert-file-contents file nil 0 100)
-	  (looking-at "BABYL OPTIONS:"))
-      (kill-buffer buf))))
+(defcustom rmail-fields-not-to-output nil
+  "*Regexp describing fields to exclude when outputting a message to a file."
+  :type '(choice (const :tag "None" nil)
+		 regexp)
+  :group 'rmail-output)
+
+;; Delete from the buffer header fields we don't want output.
+;; NOT-RMAIL if t means this buffer does not have the full header
+;; and *** EOOH *** that a message in an Rmail file has.
+(defun rmail-delete-unwanted-fields (&optional not-rmail)
+  (if rmail-fields-not-to-output
+      (save-excursion
+	(goto-char (point-min))
+	;; Find the end of the header.
+	(if (and (or not-rmail (search-forward "\n*** EOOH ***\n" nil t))
+		 (search-forward "\n\n" nil t))
+	    (let ((end (point-marker)))
+	      (goto-char (point-min))
+	      (while (re-search-forward rmail-fields-not-to-output end t)
+		(beginning-of-line)
+		(delete-region (point)
+			       (progn (forward-line 1) (point)))))))))
 
-;;; There are functions elsewhere in Emacs that use this function; check
-;;; them out before you change the calling method.
+;;; There are functions elsewhere in Emacs that use this function;
+;;; look at them before you change the calling method.
+;;;###autoload
 (defun rmail-output (file-name &optional count noattribute from-gnus)
   "Append this message to system-inbox-format mail file named FILE-NAME.
 A prefix argument N says to output N consecutive messages
@@ -190,7 +272,7 @@ If the pruned message header is shown on the current message, then
 messages will be appended with pruned headers; otherwise, messages
 will be appended with their original headers.
 
-The default file name comes from `rmail-last-file',
+The default file name comes from `rmail-default-file',
 which is updated to the name you use in this command.
 
 The optional third argument NOATTRIBUTE, if non-nil, says not
@@ -198,70 +280,65 @@ to set the `filed' attribute, and not to display a message.
 
 The optional fourth argument FROM-GNUS is set when called from GNUS."
   (interactive
-   (let ((default-file
-	   (let (answer tail)
-	     (setq tail rmail-output-file-alist)
-	     ;; Suggest a file based on a pattern match.
-	     (while (and tail (not answer))
-	       (save-excursion
-		 (goto-char (point-min))
-		 (if (re-search-forward (car (car tail)) nil t)
-		     (setq answer (eval (cdr (car tail)))))
-		 (setq tail (cdr tail))))
-	     ;; If not suggestions, use same file as last time.
-	     (or answer rmail-default-file))))
-     (list (setq rmail-default-file
-		 (let ((read-file
-			(read-file-name
-			 (concat "Output message to Unix mail file: (default "
-				 (file-name-nondirectory default-file)
-				 ") ")
-			 (file-name-directory default-file)
-			 default-file)))
-		   (if (file-directory-p read-file)
-		       (expand-file-name (file-name-nondirectory default-file)
-					 read-file)
-		     (expand-file-name
-		      (or read-file default-file)
-		      (file-name-directory default-file)))))
-	   (prefix-numeric-value current-prefix-arg))))
+   (list (rmail-output-read-file-name)
+	 (prefix-numeric-value current-prefix-arg)))
   (or count (setq count 1))
   (setq file-name
 	(expand-file-name file-name
 			  (and rmail-default-file
 			       (file-name-directory rmail-default-file))))
-  (if (and (file-readable-p file-name) (rmail-file-p file-name))
+  (if (and (file-readable-p file-name) (mail-file-babyl-p file-name))
       (rmail-output-to-rmail-file file-name count)
+    (set-buffer rmail-buffer)
     (let ((orig-count count)
 	  (rmailbuf (current-buffer))
 	  (case-fold-search t)
 	  (tembuf (get-buffer-create " rmail-output"))
 	  (original-headers-p
 	   (and (not from-gnus)
-		(save-excursion 
+		(save-excursion
 		  (save-restriction
 		    (narrow-to-region (rmail-msgbeg rmail-current-message) (point-max))
 		    (goto-char (point-min))
 		    (forward-line 1)
 		    (= (following-char) ?0)))))
 	  header-beginning
-	  mail-from)
+	  mail-from mime-version content-type)
       (while (> count 0)
+	;; Preserve the Mail-From and MIME-Version fields
+	;; even if they have been pruned.
 	(or from-gnus
-	    (setq mail-from
-		  (save-excursion
-		    (save-restriction
-		      (widen)
-		      (goto-char (rmail-msgbeg rmail-current-message))
-		      (setq header-beginning (point))
-		      (search-forward "\n*** EOOH ***\n")
-		      (narrow-to-region header-beginning (point))
-		      (mail-fetch-field "Mail-From")))))
+	    (save-excursion
+	      (save-restriction
+		(widen)
+		(goto-char (rmail-msgbeg rmail-current-message))
+		(setq header-beginning (point))
+		(search-forward "\n*** EOOH ***\n")
+		(narrow-to-region header-beginning (point))
+		(setq mail-from (mail-fetch-field "Mail-From"))
+		(unless rmail-enable-mime
+		  (setq mime-version (mail-fetch-field "MIME-Version")
+			content-type (mail-fetch-field "Content-type"))))))
 	(save-excursion
 	  (set-buffer tembuf)
 	  (erase-buffer)
 	  (insert-buffer-substring rmailbuf)
-	  (insert "\n")
+	  (when rmail-enable-mime
+	    (if original-headers-p
+		(delete-region (goto-char (point-min))
+			       (if (search-forward "\n*** EOOH ***\n")
+				   (match-end 0)))
+	      (goto-char (point-min))
+	      (forward-line 2)
+	      (delete-region (point-min)(point))
+	      (search-forward "\n*** EOOH ***\n")
+	      (delete-region (match-beginning 0)
+			     (if (search-forward "\n\n")
+				 (1- (match-end 0)))))
+	    (setq buffer-file-coding-system (or rmail-file-coding-system
+						'raw-text)))
+	  (rmail-delete-unwanted-fields t)
+	  (or (bolp) (insert "\n"))
 	  (goto-char (point-min))
 	  (if mail-from
 	      (insert mail-from "\n")
@@ -271,12 +348,16 @@ The optional fourth argument FROM-GNUS is set when called from GNUS."
 						 (mail-fetch-field "sender")
 						 "unknown"))
 		    " " (current-time-string) "\n"))
+	  (if mime-version
+	      (insert "MIME-Version: " mime-version
+		      "\nContent-type: " content-type "\n"))
 	  ;; ``Quote'' "\nFrom " as "\n>From "
 	  ;;  (note that this isn't really quoting, as there is no requirement
 	  ;;   that "\n[>]+From " be quoted in the same transparent way.)
-	  (while (search-forward "\nFrom " nil t)
-	    (forward-char -5)
-	    (insert ?>))
+	  (let ((case-fold-search nil))
+	    (while (search-forward "\nFrom " nil t)
+	      (forward-char -5)
+	      (insert ?>)))
 	  (write-region (point-min) (point-max) file-name t
 			(if noattribute 'nomsg)))
 	(or noattribute
@@ -293,7 +374,7 @@ The optional fourth argument FROM-GNUS is set when called from GNUS."
 	      (if (and next-message-p original-headers-p)
 		  (rmail-toggle-header))
 	      (if (and (> count 0) (not next-message-p))
-		  (progn 
+		  (progn
 		    (error
 		     (save-excursion
 		       (set-buffer rmailbuf)
@@ -302,4 +383,35 @@ The optional fourth argument FROM-GNUS is set when called from GNUS."
 		    (setq count 0))))))
       (kill-buffer tembuf))))
 
+;;;###autoload
+(defun rmail-output-body-to-file (file-name)
+  "Write this message body to the file FILE-NAME.
+FILE-NAME defaults, interactively, from the Subject field of the message."
+  (interactive
+   (let ((default-file
+	   (or (mail-fetch-field "Subject")
+	       rmail-default-body-file)))
+     (list (setq rmail-default-body-file
+		 (read-file-name
+		  "Output message body to file: "
+		  (and default-file (file-name-directory default-file))
+		  default-file
+		  nil default-file)))))
+  (setq file-name
+	(expand-file-name file-name
+			  (and rmail-default-body-file
+			       (file-name-directory rmail-default-body-file))))
+  (save-excursion
+    (goto-char (point-min))
+    (search-forward "\n\n")
+    (and (file-exists-p file-name)
+	 (not (y-or-n-p (message "File %s exists; overwrite? " file-name)))
+	 (error "Operation aborted"))
+    (write-region (point) (point-max) file-name)
+    (if (equal major-mode 'rmail-mode)
+	(rmail-set-attribute "stored" t)))
+  (if rmail-delete-after-output
+      (rmail-delete-forward)))
+
+;;; arch-tag: 447117c6-1a9a-4b88-aa43-3101b043e3a4
 ;;; rmailout.el ends here