[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] emacs/lisp/mail pmailout.el
From: |
Chong Yidong |
Subject: |
[Emacs-diffs] emacs/lisp/mail pmailout.el |
Date: |
Thu, 04 Dec 2008 22:49:30 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Chong Yidong <cyd> 08/12/04 22:49:30
Modified files:
lisp/mail : pmailout.el
Log message:
Sync with rmailout.el.
CVSWeb URLs:
http://cvs.savannah.gnu.org/viewcvs/emacs/lisp/mail/pmailout.el?cvsroot=emacs&r1=1.5&r2=1.6
Patches:
Index: pmailout.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/mail/pmailout.el,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -b -r1.5 -r1.6
--- pmailout.el 6 Sep 2008 02:55:29 -0000 1.5
+++ pmailout.el 4 Dec 2008 22:49:30 -0000 1.6
@@ -1,4 +1,4 @@
-;;; pmailout.el --- "PMAIL" mail reader for Emacs: output message to a file.
+;;; pmailout.el --- "PMAIL" mail reader for Emacs: output message to a file
;; Copyright (C) 1985, 1987, 1993, 1994, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
@@ -25,12 +25,9 @@
;;; Code:
+(require 'pmail)
(provide 'pmailout)
-(eval-when-compile
- (require 'pmail)
- (require 'pmaildesc))
-
;;;###autoload
(defcustom pmail-output-file-alist nil
"*Alist matching regexps to suggested output Pmail files.
@@ -45,40 +42,70 @@
sexp)))
:group 'pmail-output)
-;;;###autoload
-(defcustom pmail-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 'pmail-output)
+(defun pmail-output-read-pmail-file-name ()
+ "Read the file name to use for `pmail-output-to-pmail-file'.
+Set `pmail-default-pmail-file' to this name as well as returning it."
+ (let ((default-file
+ (let (answer tail)
+ (setq tail pmail-output-file-alist)
+ ;; Suggest a file based on a pattern match.
+ (while (and tail (not answer))
+ (save-excursion
+ (set-buffer pmail-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 pmail-default-pmail-file)))))
+ (let ((read-file
+ (expand-file-name
+ (read-file-name
+ (concat "Output message to Pmail 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 pmail-default-pmail-file
+ (if (file-directory-p read-file)
+ (expand-file-name (file-name-nondirectory default-file)
+ read-file)
+ read-file)))))
(defun pmail-output-read-file-name ()
"Read the file name to use for `pmail-output'.
Set `pmail-default-file' to this name as well as returning it."
- (let* ((default-file
- (with-current-buffer pmail-buffer
- (expand-file-name
- (or (catch 'answer
- (dolist (i pmail-output-file-alist)
+ (let ((default-file
+ (let (answer tail)
+ (setq tail pmail-output-file-alist)
+ ;; Suggest a file based on a pattern match.
+ (while (and tail (not answer))
+ (save-excursion
(goto-char (point-min))
- (when (re-search-forward (car i) nil t)
- (throw 'answer (eval (cdr i))))))
- pmail-default-file))))
- (read-file
+ (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 pmail-default-file))))
+ (let ((read-file
(expand-file-name
(read-file-name
- (concat "Output message to Pmail (mbox) file: (default "
- (file-name-nondirectory default-file) "): ")
+ (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 pmail-default-file
(if (file-directory-p read-file)
- (expand-file-name
- (file-name-nondirectory default-file) 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))))))
+ (file-name-directory default-file)))))))
(declare-function pmail-update-summary "pmailsum" (&rest ignore))
@@ -86,7 +113,7 @@
;;; look at them before you change the calling method.
;;;###autoload
(defun pmail-output-to-pmail-file (file-name &optional count stay)
- "Append the current message to an Pmail (mbox) file named FILE-NAME.
+ "Append the current message to an Pmail 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.
@@ -101,35 +128,137 @@
If the optional argument STAY is non-nil, then leave the last filed
message up instead of moving forward to the next non-deleted message."
- (interactive (list (pmail-output-read-file-name)
+ (interactive
+ (list (pmail-output-read-pmail-file-name)
(prefix-numeric-value current-prefix-arg)))
- ;; Use the 'pmail-output function to perform the output.
- (pmail-output file-name count nil nil)
- ;; Deal with the next message
+ (or count (setq count 1))
+ (setq file-name
+ (expand-file-name file-name
+ (file-name-directory pmail-default-pmail-file)))
+ (if (and (file-readable-p file-name) (not (mail-file-babyl-p file-name)))
+ (pmail-output file-name count)
+ (pmail-maybe-set-message-counters)
+ (setq file-name (abbreviate-file-name 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? "))
+ (let ((file-buffer (create-file-buffer file-name)))
+ (save-excursion
+ (set-buffer file-buffer)
+ (pmail-insert-pmail-file-header)
+ (let ((require-final-newline nil)
+ (coding-system-for-write
+ (or pmail-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")))
+ (while (> count 0)
+ (let (redelete)
+ (unwind-protect
+ (progn
+ (set-buffer pmail-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.
+ (if (pmail-message-deleted-p pmail-current-message)
+ (progn (setq redelete t)
+ (pmail-set-attribute "deleted" nil)))
+ (save-restriction
+ (widen)
+ ;; Decide whether to append to a file or to an Emacs buffer.
+ (save-excursion
+ (let ((buf (find-buffer-visiting file-name))
+ (cur (current-buffer))
+ (beg (1+ (pmail-msgbeg pmail-current-message)))
+ (end (1+ (pmail-msgend pmail-current-message)))
+ (coding-system-for-write
+ (or pmail-file-coding-system
+ 'emacs-mule-unix)))
+ (if (not buf)
+ ;; Output to a file.
+ (if pmail-fields-not-to-output
+ ;; Delete some fields while we output.
+ (let ((obuf (current-buffer)))
+ (set-buffer (get-buffer-create " pmail-out-temp"))
+ (insert-buffer-substring obuf beg end)
+ (pmail-delete-unwanted-fields)
+ (append-to-file (point-min) (point-max) file-name)
+ (set-buffer obuf)
+ (kill-buffer (get-buffer " pmail-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.
+ (set-buffer buf)
+ (let ((buffer-read-only nil)
+ (msg (and (boundp 'pmail-current-message)
+ pmail-current-message)))
+ ;; If MSG is non-nil, buffer is in PMAIL mode.
+ (if msg
+ (progn
+ ;; Turn on auto save mode, if it's off in this
+ ;; buffer but enabled by default.
+ (and (not buffer-auto-save-file-name)
+ auto-save-default
+ (auto-save-mode t))
+ (pmail-maybe-set-message-counters)
+ (widen)
+ (narrow-to-region (point-max) (point-max))
+ (insert-buffer-substring cur beg end)
+ (goto-char (point-min))
+ (widen)
+ (search-backward "\n\^_")
+ (narrow-to-region (point) (point-max))
+ (pmail-delete-unwanted-fields)
+ (pmail-count-new-messages t)
+ (if (pmail-summary-exists)
+ (pmail-select-summary
+ (pmail-update-summary)))
+ (pmail-show-message msg))
+ ;; Output file not in pmail mode => just insert at
the end.
+ (narrow-to-region (point-min) (1+ (buffer-size)))
+ (goto-char (point-max))
+ (insert-buffer-substring cur beg end)
+ (pmail-delete-unwanted-fields)))))))
+ (pmail-set-attribute "filed" t))
+ (if redelete (pmail-set-attribute "deleted" t))))
+ (setq count (1- count))
(if pmail-delete-after-output
- (unless (if (and (= count 0) stay)
+ (unless
+ (if (and (= count 0) stay)
(pmail-delete-message)
(pmail-delete-forward))
(setq count 0))
- (when (> count 0)
- (unless (when (not stay)
- (pmail-next-undeleted-message 1))
- (setq count 0)))))
-
-(defun pmail-delete-unwanted-fields ()
- "Delete from the buffer header fields we don't want output."
- (when pmail-fields-not-to-output
+ (if (> count 0)
+ (unless
+ (if (not stay) (pmail-next-undeleted-message 1))
+ (setq count 0)))))))
+
+;;;###autoload
+(defcustom pmail-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 'pmail-output)
+
+;; Delete from the buffer header fields we don't want output.
+;; NOT-PMAIL if t means this buffer does not have the full header
+;; and *** EOOH *** that a message in an Pmail file has.
+(defun pmail-delete-unwanted-fields (&optional not-pmail)
+ (if pmail-fields-not-to-output
(save-excursion
- (let ((limit (pmail-header-get-limit))
- (inhibit-point-motion-hooks t)
- start)
(goto-char (point-min))
- (while (re-search-forward pmail-fields-not-to-output limit t)
- (forward-line 0)
- (setq start (point))
- (while (progn (forward-line 1) (looking-at "[ \t]+"))
- (goto-char (line-end-position)))
- (delete-region start (point)))))))
+ ;; Find the end of the header.
+ (if (and (or not-pmail (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 pmail-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;
;;; look at them before you change the calling method.
@@ -160,70 +289,110 @@
(and pmail-default-file
(file-name-directory pmail-default-file))))
(if (and (file-readable-p file-name) (mail-file-babyl-p file-name))
- (error "BABYL output not supported.")
- (with-current-buffer pmail-buffer
+ (pmail-output-to-pmail-file file-name count)
+ (set-buffer pmail-buffer)
(let ((orig-count count)
(pmailbuf (current-buffer))
- (destbuf (find-buffer-visiting file-name))
- (case-fold-search t))
+ (case-fold-search t)
+ (tembuf (get-buffer-create " pmail-output"))
+ (original-headers-p
+ (and (not from-gnus)
+ (save-excursion
+ (save-restriction
+ (narrow-to-region (pmail-msgbeg pmail-current-message)
(point-max))
+ (goto-char (point-min))
+ (forward-line 1)
+ (= (following-char) ?0)))))
+ header-beginning
+ mail-from mime-version content-type)
(while (> count 0)
- (with-temp-buffer
- (insert-buffer-substring pmailbuf)
- ;; ensure we can write without barfing on exotic characters
- (setq buffer-file-coding-system
- (or pmail-file-coding-system 'raw-text))
- ;; prune junk headers
- (pmail-delete-unwanted-fields)
- (if (not destbuf)
- ;; The destination file is not being visited, just write
- ;; out the processed message.
- (write-region (point-min) (point-max) file-name
- t (when noattribute 'nomsg))
- ;; The destination file is being visited. Update it.
- (let ((msg-string (buffer-string)))
- (with-current-buffer destbuf
- ;; Determine if the destination file is an Pmail file.
- (let ((buffer-read-only nil)
- (dest-current-message
- (and (boundp 'pmail-current-message)
- pmail-current-message)))
- (if dest-current-message
- ;; The buffer is an Pmail buffer. Append the
- ;; message.
- (progn
+ ;; Preserve the Mail-From and MIME-Version fields
+ ;; even if they have been pruned.
+ (or from-gnus
+ (save-excursion
+ (save-restriction
(widen)
- (narrow-to-region (point-max) (point-max))
- (insert msg-string)
- (insert "\n")
- (pmail-process-new-messages)
- (pmail-show-message dest-current-message))
- ;; The destination file is not an Pmail file, just
- ;; insert at the end.
- (goto-char (point-max))
- (insert msg-string)))))))
- (unless noattribute
- (when (equal major-mode 'pmail-mode)
- (pmail-set-attribute "filed" t)
- (pmail-header-hide-headers)))
+ (goto-char (pmail-msgbeg pmail-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 pmail-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 pmailbuf)
+ (when pmail-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 pmail-file-coding-system
+ 'raw-text)))
+ (pmail-delete-unwanted-fields t)
+ (or (bolp) (insert "\n"))
+ (goto-char (point-min))
+ (if mail-from
+ (insert mail-from "\n")
+ (insert "From "
+ (mail-strip-quoted-names (or (mail-fetch-field "from")
+ (mail-fetch-field
"really-from")
+ (mail-fetch-field "sender")
+ "unknown"))
+ " " (current-time-string) "\n"))
+ (when mime-version
+ (insert "MIME-Version: " mime-version)
+ ;; Some malformed MIME messages set content-type to nil.
+ (when content-type
+ (insert "\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.)
+ (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
+ (if (equal major-mode 'pmail-mode)
+ (pmail-set-attribute "filed" t)))
(setq count (1- count))
- (unless from-gnus
+ (or from-gnus
(let ((next-message-p
(if pmail-delete-after-output
(pmail-delete-forward)
- (when (> count 0)
+ (if (> count 0)
(pmail-next-undeleted-message 1))))
(num-appended (- orig-count count)))
- (when (and (> count 0) (not next-message-p))
- (error (format "Only %d message%s appended" num-appended
- (if (= num-appended 1) "" "s")))
- (setq count 0)))))))))
+ (if (and next-message-p original-headers-p)
+ (pmail-toggle-header))
+ (if (and (> count 0) (not next-message-p))
+ (progn
+ (error "%s"
+ (save-excursion
+ (set-buffer pmailbuf)
+ (format "Only %d message%s appended" num-appended
+ (if (= num-appended 1) "" "s"))))
+ (setq count 0))))))
+ (kill-buffer tembuf))))
;;;###autoload
(defun pmail-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")
+ (let ((default-file
+ (or (mail-fetch-field "Subject")
pmail-default-body-file)))
(list (setq pmail-default-body-file
(read-file-name
@@ -232,20 +401,19 @@
default-file
nil default-file)))))
(setq file-name
- (expand-file-name
- file-name
+ (expand-file-name file-name
(and pmail-default-body-file
(file-name-directory pmail-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)))
+ (not (y-or-n-p (format "File %s exists; overwrite? " file-name)))
(error "Operation aborted"))
(write-region (point) (point-max) file-name)
- (when (equal major-mode 'pmail-mode)
- (pmail-desc-set-attribute pmail-current-message pmail-desc-stored-index
t)))
- (when pmail-delete-after-output
+ (if (equal major-mode 'pmail-mode)
+ (pmail-set-attribute "stored" t)))
+ (if pmail-delete-after-output
(pmail-delete-forward)))
;; Local Variables:
- [Emacs-diffs] emacs/lisp/mail pmailout.el,
Chong Yidong <=
- [Emacs-diffs] emacs/lisp/mail pmailout.el, Chong Yidong, 2008/12/10
- [Emacs-diffs] emacs/lisp/mail pmailout.el, Chong Yidong, 2008/12/12
- [Emacs-diffs] emacs/lisp/mail pmailout.el, Chong Yidong, 2008/12/13
- [Emacs-diffs] emacs/lisp/mail pmailout.el, Richard M. Stallman, 2008/12/22
- [Emacs-diffs] emacs/lisp/mail pmailout.el, Richard M. Stallman, 2008/12/29