X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/e155e60e2dfaa1c400beec0f42ce1b2414aaefc6..7c7d40755ab10f374dd656e9f0e5f2a158ae9edb:/lisp/mail/rmailout.el diff --git a/lisp/mail/rmailout.el b/lisp/mail/rmailout.el index 1834ff5ae2..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, 1994 Free Software Foundation, Inc. +;; Copyright (C) 1985, 1987, 1993, 1994, 2001 Free Software Foundation, Inc. ;; Maintainer: FSF ;; Keywords: mail @@ -22,9 +22,12 @@ ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;; Boston, MA 02111-1307, USA. +;;; Commentary: + ;;; Code: (require 'rmail) +(provide 'rmailout) ;;;###autoload (defcustom rmail-output-file-alist nil @@ -40,10 +43,75 @@ a file name as a string." sexp))) :group 'rmail-output) -;;; There are functions elsewhere in Emacs that use this function; check -;;; them out before you change the calling method. +(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; +;;; look at them before you change the calling method. ;;;###autoload -(defun rmail-output-to-rmail-file (file-name &optional count) +(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 @@ -55,35 +123,13 @@ 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 @@ -100,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"))) @@ -108,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,7 +171,10 @@ starting with the current one. Deleted messages are skipped and don't count." (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) ;; Output to a file. (if rmail-fields-not-to-output @@ -163,18 +216,24 @@ starting with the current one. Deleted messages are skipped and don't count." (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) - (rmail-delete-unwanted-fields))))))) + ;; 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))))))) ;;;###autoload (defcustom rmail-fields-not-to-output nil @@ -187,7 +246,7 @@ starting with the current one. Deleted messages are skipped and don't count." ;; 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 + (if rmail-fields-not-to-output (save-excursion (goto-char (point-min)) ;; Find the end of the header. @@ -200,8 +259,8 @@ starting with the current one. Deleted messages are skipped and don't count." (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. @@ -221,33 +280,8 @@ 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 @@ -255,37 +289,56 @@ The optional fourth argument FROM-GNUS is set when called from GNUS." (file-name-directory rmail-default-file)))) (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) + (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) - (insert "\n") + (or (bolp) (insert "\n")) (goto-char (point-min)) (if mail-from (insert mail-from "\n") @@ -295,6 +348,9 @@ 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.) @@ -318,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) @@ -333,12 +389,18 @@ The optional fourth argument FROM-GNUS is set when called from GNUS." FILE-NAME defaults, interactively, from the Subject field of the message." (interactive (let ((default-file - (mail-fetch-field "Subject"))) - (list (read-file-name - "Output message body to file: " - (file-name-directory default-file) - default-file - nil 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") @@ -351,4 +413,5 @@ FILE-NAME defaults, interactively, from the Subject field of the message." (if rmail-delete-after-output (rmail-delete-forward))) +;;; arch-tag: 447117c6-1a9a-4b88-aa43-3101b043e3a4 ;;; rmailout.el ends here