procyberian/emacs
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Renamed all pmail* files to rmail*.

Browse source
This commit is contained in:
Bastien Guerry 2009-01-22 17:09:23 +00:00
parent 13847f7970
commit 537ab246b2
8 changed files with 7367 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3893
lisp/mail/rmail.el Normal file
View file

File diff suppressed because it is too large Load diff

217
lisp/mail/rmailedit.el Normal file
View file

@ -0,0 +1,217 @@
;;; rmailedit.el --- "RMAIL edit mode" Edit the current message
;; Copyright (C) 1985, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
;; 2007, 2008, 2009 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(eval-when-compile
(require 'rmail)
(require 'rmailsum))
(defcustom rmail-edit-mode-hook nil
"List of functions to call when editing an RMAIL message."
:type 'hook
:version "21.1"
:group 'rmail-edit)
(defvar rmail-old-text)
(defvar rmail-edit-map nil)
(if rmail-edit-map
nil
;; Make a keymap that inherits text-mode-map.
(setq rmail-edit-map (make-sparse-keymap))
(set-keymap-parent rmail-edit-map text-mode-map)
(define-key rmail-edit-map "\C-c\C-c" 'rmail-cease-edit)
(define-key rmail-edit-map "\C-c\C-]" 'rmail-abort-edit))
;; Rmail Edit mode is suitable only for specially formatted data.
(put 'rmail-edit-mode 'mode-class 'special)
(declare-function rmail-summary-disable "" ())
(declare-function rmail-summary-enable "rmailsum" ())
(defun rmail-edit-mode ()
"Major mode for editing the contents of an RMAIL message.
The editing commands are the same as in Text mode, together with two commands
to return to regular RMAIL:
* \\[rmail-abort-edit] cancels the changes
you have made and returns to RMAIL
* \\[rmail-cease-edit] makes them permanent.
This functions runs the normal hook `rmail-edit-mode-hook'.
\\{rmail-edit-map}"
(if (rmail-summary-exists)
(save-excursion
(set-buffer rmail-summary-buffer)
(rmail-summary-disable)))
(let (rmail-buffer-swapped)
;; Prevent change-major-mode-hook from unswapping the buffers.
(delay-mode-hooks (text-mode))
(use-local-map rmail-edit-map)
(setq major-mode 'rmail-edit-mode)
(setq mode-name "RMAIL Edit")
(if (boundp 'mode-line-modified)
(setq mode-line-modified (default-value 'mode-line-modified))
(setq mode-line-format (default-value 'mode-line-format)))
(run-mode-hooks 'rmail-edit-mode-hook)))
(defvar rmail-old-pruned nil)
(put 'rmail-old-pruned 'permanent-local t)
;;;###autoload
(defun rmail-edit-current-message ()
"Edit the contents of this message."
(interactive)
(if (= rmail-total-messages 0)
(error "No messages in this buffer"))
(make-local-variable 'rmail-old-pruned)
(setq rmail-old-pruned (eq rmail-header-style 'normal))
(rmail-edit-mode)
(make-local-variable 'rmail-old-text)
(save-restriction
(widen)
(setq rmail-old-text (buffer-substring (point-min) (point-max))))
(setq buffer-read-only nil)
(setq buffer-undo-list nil)
(force-mode-line-update)
(if (and (eq (key-binding "\C-c\C-c") 'rmail-cease-edit)
(eq (key-binding "\C-c\C-]") 'rmail-abort-edit))
(message "Editing: Type C-c C-c to return to Rmail, C-c C-] to abort")
(message "%s" (substitute-command-keys
"Editing: Type \\[rmail-cease-edit] to return to Rmail, \\[rmail-abort-edit] to abort"))))
(defun rmail-cease-edit ()
"Finish editing message; switch back to Rmail proper."
(interactive)
(if (rmail-summary-exists)
(save-excursion
(set-buffer rmail-summary-buffer)
(rmail-summary-enable)))
(widen)
;; Disguise any "From " lines so they don't start a new message.
(save-excursion
(goto-char (point-min))
(while (search-forward "\nFrom " nil t)
(beginning-of-line)
(insert ">")))
;; Make sure buffer ends with a blank line
;; so as not to run this message together with the following one.
(save-excursion
(goto-char (point-max))
(if (/= (preceding-char) ?\n)
(insert "\n"))
(unless (looking-back "\n\n")
(insert "\n")))
(let ((old rmail-old-text)
character-coding is-text-message coding-system
headers-end)
;; Go back to Rmail mode, but carefully.
(force-mode-line-update)
(let (rmail-buffer-swapped)
(kill-all-local-variables)
(rmail-mode-1)
(if (boundp 'tool-bar-map)
(set (make-local-variable 'tool-bar-map) rmail-tool-bar-map))
(setq buffer-undo-list t)
(rmail-variables))
;; If text has really changed, mark message as edited.
(unless (and (= (length old) (- (point-max) (point-min)))
(string= old (buffer-substring (point-min) (point-max))))
(setq old nil)
(goto-char (point-min))
(search-forward "\n\n")
(setq headers-end (point))
(rmail-swap-buffers-maybe)
(setq character-coding (mail-fetch-field "content-transfer-encoding")
is-text-message (rmail-is-text-p)
coding-system (rmail-get-coding-system))
(if character-coding
(setq character-coding (downcase character-coding)))
(narrow-to-region (rmail-msgbeg rmail-current-message)
(rmail-msgend rmail-current-message))
(goto-char (point-min))
(search-forward "\n\n")
(let ((inhibit-read-only t)
(headers-end-1 (point)))
(insert-buffer-substring rmail-view-buffer headers-end)
(delete-region (point) (point-max))
;; Re-encode the message body in whatever
;; way it was decoded.
(cond
((string= character-coding "quoted-printable")
(mail-quote-printable-region headers-end-1 (point-max)))
((and (string= character-coding "base64") is-text-message)
(base64-encode-region headers-end-1 (point-max)))
((eq character-coding 'uuencode)
(error "Not supported yet."))
(t
(if (or (not coding-system) (not (coding-system-p coding-system)))
(setq coding-system 'undecided))
(encode-coding-region headers-end-1 (point-max) coding-system)))
))
(rmail-set-attribute rmail-edited-attr-index t)
;;??? BROKEN perhaps.
;; I think that the Summary-Line header may not be kept there any more.
;;; (if (boundp 'rmail-summary-vector)
;;; (progn
;;; (aset rmail-summary-vector (1- rmail-current-message) nil)
;;; (save-excursion
;;; (rmail-widen-to-current-msgbeg
;;; (function (lambda ()
;;; (forward-line 2)
;;; (if (looking-at "Summary-line: ")
;;; (let ((buffer-read-only nil))
;;; (delete-region (point)
;;; (progn (forward-line 1)
;;; (point)))))))))))
)
(save-excursion
(rmail-show-message)
(rmail-toggle-header (if rmail-old-pruned 1 0)))
(run-hooks 'rmail-mode-hook))
(defun rmail-abort-edit ()
"Abort edit of current message; restore original contents."
(interactive)
(widen)
(delete-region (point-min) (point-max))
(insert rmail-old-text)
(rmail-cease-edit)
(rmail-highlight-headers))
(provide 'rmailedit)
;; Local Variables:
;; change-log-default-name: "ChangeLog.rmail"
;; End:
;; arch-tag: 9524f335-12cc-4e95-9e9b-3208dc30550b
;;; rmailedit.el ends here

169
lisp/mail/rmailkwd.el Normal file
View file

@ -0,0 +1,169 @@
;;; rmailkwd.el --- part of the "RMAIL" mail reader for Emacs
;; Copyright (C) 1985, 1988, 1994, 2001, 2002, 2003, 2004, 2005, 2006,
;; 2007, 2008, 2009 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'rmail)
;; Global to all RMAIL buffers. It exists primarily for the sake of
;; completion. It is better to use strings with the label functions
;; and let them worry about making the label.
(defvar rmail-label-obarray (make-vector 47 0))
(mapc (function (lambda (s) (intern s rmail-label-obarray)))
'("deleted" "answered" "filed" "forwarded" "unseen" "edited"
"resent"))
(defun rmail-make-label (s)
(intern (downcase s) rmail-label-obarray))
;;;###autoload
(defun rmail-add-label (string)
"Add LABEL to labels associated with current RMAIL message.
Performs completion over known labels when reading."
(interactive (list (rmail-read-label "Add label")))
(rmail-set-label string t))
;;;###autoload
(defun rmail-kill-label (string)
"Remove LABEL from labels associated with current RMAIL message.
Performs completion over known labels when reading."
(interactive (list (rmail-read-label "Remove label")))
(rmail-set-label string nil))
;;;###autoload
(defun rmail-read-label (prompt)
(let ((result
(completing-read (concat prompt
(if rmail-last-label
(concat " (default "
(symbol-name rmail-last-label)
"): ")
": "))
rmail-label-obarray
nil
nil)))
(if (string= result "")
rmail-last-label
(setq rmail-last-label (rmail-make-label result)))))
(defun rmail-set-label (label state &optional msg)
"Set LABEL as present or absent according to STATE in message MSG."
(with-current-buffer rmail-buffer
(rmail-maybe-set-message-counters)
(if (not msg) (setq msg rmail-current-message))
;; Force recalculation of summary for this message.
(aset rmail-summary-vector (1- msg) nil)
(let (attr-index)
;; Is this label an attribute?
(dotimes (i (length rmail-attr-array))
(if (string= (cadr (aref rmail-attr-array i)) label)
(setq attr-index i)))
(if attr-index
;; If so, set it as an attribute.
(rmail-set-attribute attr-index state msg)
;; Is this keyword already present in msg's keyword list?
(let* ((header (rmail-get-header rmail-keyword-header msg))
(regexp (concat ", " (regexp-quote (symbol-name label)) ","))
(present (string-match regexp (concat ", " header ","))))
;; If current state is not correct,
(unless (eq present state)
;; either add it or delete it.
(rmail-set-header
rmail-keyword-header msg
(if state
;; Add this keyword at the end.
(if (and header (not (string= header "")))
(concat header ", " (symbol-name label))
(symbol-name label))
;; Delete this keyword.
(let ((before (substring header 0
(max 0 (- (match-beginning 0) 2))))
(after (substring header
(min (length header)
(- (match-end 0) 1)))))
(cond ((string= before "")
after)
((string= after "")
before)
(t (concat before ", " after)))))))))
(if (= msg rmail-current-message)
(rmail-display-labels)))))
;; Motion on messages with keywords.
;;;###autoload
(defun rmail-previous-labeled-message (n labels)
"Show previous message with one of the labels LABELS.
LABELS should be a comma-separated list of label names.
If LABELS is empty, the last set of labels specified is used.
With prefix argument N moves backward N messages with these labels."
(interactive "p\nsMove to previous msg with labels: ")
(rmail-next-labeled-message (- n) labels))
(declare-function mail-comma-list-regexp "mail-utils" (labels))
;;;###autoload
(defun rmail-next-labeled-message (n labels)
"Show next message with one of the labels LABELS.
LABELS should be a comma-separated list of label names.
If LABELS is empty, the last set of labels specified is used.
With prefix argument N moves forward N messages with these labels."
(interactive "p\nsMove to next msg with labels: ")
(if (string= labels "")
(setq labels rmail-last-multi-labels))
(or labels
(error "No labels to find have been specified previously"))
(set-buffer rmail-buffer)
(setq rmail-last-multi-labels labels)
(rmail-maybe-set-message-counters)
(let ((lastwin rmail-current-message)
(current rmail-current-message)
(regexp (concat ", ?\\("
(mail-comma-list-regexp labels)
"\\),")))
(while (and (> n 0) (< current rmail-total-messages))
(setq current (1+ current))
(if (string-match regexp (rmail-get-labels current))
(setq lastwin current n (1- n))))
(while (and (< n 0) (> current 1))
(setq current (1- current))
(if (string-match regexp (rmail-get-labels current))
(setq lastwin current n (1+ n))))
(if (< n 0)
(error "No previous message with labels %s" labels)
(if (> n 0)
(error "No following message with labels %s" labels)
(rmail-show-message lastwin)))))
(provide 'rmailkwd)
;; Local Variables:
;; change-log-default-name: "ChangeLog.rmail"
;; End:
;; arch-tag: 1149979c-8e47-4333-9629-cf3dc887a6a7
;;; rmailkwd.el ends here

410
lisp/mail/rmailmm.el Normal file
View file

@ -0,0 +1,410 @@
;;; rmailmm.el --- MIME decoding and display stuff for RMAIL
;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;; Essentially based on the design of Alexander Pohoyda's MIME
;; extensions (mime-display.el and mime.el). To use, copy a complete
;; message into a new buffer and call (mime-show t).
;; To use:
;; (autoload 'rmail-mime "rmailmm"
;; "Show MIME message." t)
;; (add-hook 'rmail-mode-hook
;; (lambda ()
;; (define-key rmail-mode-map (kbd "v")
;; 'rmail-mime)))
;;; Code:
(require 'rmail)
(require 'mail-parse)
;;; Variables
(defcustom rmail-mime-media-type-handlers-alist
'(("multipart/.*" rmail-mime-multipart-handler)
("text/.*" rmail-mime-text-handler)
("text/\\(x-\\)?patch" rmail-mime-bulk-handler)
("application/pgp-signature" rmail-mime-application/pgp-signature-handler)
("\\(image\\|audio\\|video\\|application\\)/.*" rmail-mime-bulk-handler))
"Alist of media type handlers, also known as agents.
Every handler is a list of type (string symbol) where STRING is a
regular expression to match the media type with and SYMBOL is a
function to run. Handlers should return a non-nil value if the
job is done."
:type 'list
:group 'mime)
(defcustom rmail-mime-attachment-dirs-alist
'(("text/.*" "~/Documents")
("image/.*" "~/Pictures")
(".*" "~/Desktop" "~" "/tmp"))
"Default directories to save attachments into.
Each media type may have it's own list of directories in order of
preference. The first existing directory in the list will be
used."
:type 'list
:group 'mime)
(defvar rmail-mime-total-number-of-bulk-attachments 0
"A total number of attached bulk bodyparts in the message. If more than 3,
offer a way to save all attachments at once.")
(put 'rmail-mime-total-number-of-bulk-attachments 'permanent-local t)
;;; Buttons
(defun rmail-mime-save (button)
"Save the attachment using info in the BUTTON."
(let* ((filename (button-get button 'filename))
(directory (button-get button 'directory))
(data (button-get button 'data)))
(while (file-exists-p (expand-file-name filename directory))
(let* ((f (file-name-sans-extension filename))
(i 1))
(when (string-match "-\\([0-9]+\\)$" f)
(setq i (1+ (string-to-number (match-string 1 f)))
f (substring f 0 (match-beginning 0))))
(setq filename (concat f "-" (number-to-string i) "."
(file-name-extension filename)))))
(setq filename (expand-file-name
(read-file-name (format "Save as (default: %s): " filename)
directory
(expand-file-name filename directory))
directory))
(when (file-regular-p filename)
(error (message "File `%s' already exists" filename)))
(with-temp-file filename
(set-buffer-file-coding-system 'no-conversion)
(insert data))))
(define-button-type 'rmail-mime-save
'action 'rmail-mime-save)
;;; Handlers
(defun rmail-mime-text-handler (content-type
content-disposition
content-transfer-encoding)
"Handle the current buffer as a plain text MIME part."
(let* ((charset (cdr (assq 'charset (cdr content-type))))
(coding-system (when charset
(intern (downcase charset)))))
(when (coding-system-p coding-system)
(decode-coding-region (point-min) (point-max) coding-system))))
(defun test-rmail-mime-handler ()
"Test of a mail using no MIME parts at all."
(let ((mail "To: alex@gnu.org
Content-Type: text/plain; charset=koi8-r
Content-Transfer-Encoding: 8bit
MIME-Version: 1.0
\372\304\322\301\327\323\324\327\325\312\324\305\41"))
(switch-to-buffer (get-buffer-create "*test*"))
(erase-buffer)
(set-buffer-multibyte nil)
(insert mail)
(rmail-mime-show t)
(set-buffer-multibyte t)))
(defun rmail-mime-bulk-handler (content-type
content-disposition
content-transfer-encoding)
"Handle the current buffer as an attachment to download."
(setq rmail-mime-total-number-of-bulk-attachments
(1+ rmail-mime-total-number-of-bulk-attachments))
;; Find the default directory for this media type
(let* ((directory (catch 'directory
(dolist (entry rmail-mime-attachment-dirs-alist)
(when (string-match (car entry) (car content-type))
(dolist (dir (cdr entry))
(when (file-directory-p dir)
(throw 'directory dir)))))))
(filename (or (cdr (assq 'name (cdr content-type)))
(cdr (assq 'filename (cdr content-disposition)))
"noname"))
(label (format "\nAttached %s file: " (car content-type)))
(data (buffer-string)))
(delete-region (point-min) (point-max))
(insert label)
(insert-button filename
:type 'rmail-mime-save
'filename filename
'directory directory
'data data)))
(defun test-rmail-mime-bulk-handler ()
"Test of a mail used as an example in RFC 2183."
(let ((mail "Content-Type: image/jpeg
Content-Disposition: attachment; filename=genome.jpeg;
modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
Content-Description: a complete map of the human genome
Content-Transfer-Encoding: base64
iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
+ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
lgAAAABJRU5ErkJggg==
"))
(switch-to-buffer (get-buffer-create "*test*"))
(erase-buffer)
(insert mail)
(rmail-mime-show)))
(defun rmail-mime-multipart-handler (content-type
content-disposition
content-transfer-encoding)
"Handle the current buffer as a multipart MIME body.
The current buffer should be narrowed to the body. CONTENT-TYPE,
CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
of the respective parsed headers. See `rmail-mime-handle' for their
format."
;; Some MUAs start boundaries with "--", while it should start
;; with "CRLF--", as defined by RFC 2046:
;; The boundary delimiter MUST occur at the beginning of a line,
;; i.e., following a CRLF, and the initial CRLF is considered to
;; be attached to the boundary delimiter line rather than part
;; of the preceding part.
;; We currently don't handle that.
(let ((boundary (cdr (assq 'boundary content-type)))
beg end next)
(unless boundary
(rmail-mm-get-boundary-error-message
"No boundary defined" content-type content-disposition
content-transfer-encoding))
(setq boundary (concat "\n--" boundary))
;; Hide the body before the first bodypart
(goto-char (point-min))
(when (and (search-forward boundary nil t)
(looking-at "[ \t]*\n"))
(delete-region (point-min) (match-end 0)))
;; Reset the counter
(setq rmail-mime-total-number-of-bulk-attachments 0)
;; Loop over all body parts, where beg points at the beginning of
;; the part and end points at the end of the part. next points at
;; the beginning of the next part.
(setq beg (point-min))
(while (search-forward boundary nil t)
(setq end (match-beginning 0))
;; If this is the last boundary according to RFC 2046, hide the
;; epilogue, else hide the boundary only. Use a marker for
;; `next' because `rmail-mime-show' may change the buffer.
(cond ((looking-at "--[ \t]*\n")
(setq next (point-max-marker)))
((looking-at "[ \t]*\n")
(setq next (copy-marker (match-end 0))))
(t
(rmail-mm-get-boundary-error-message
"Malformed boundary" content-type content-disposition
content-transfer-encoding)))
(delete-region end next)
;; Handle the part.
(save-match-data
(save-excursion
(save-restriction
(narrow-to-region beg end)
(rmail-mime-show))))
(setq beg next)
(goto-char beg))))
(defun test-rmail-mime-multipart-handler ()
"Test of a mail used as an example in RFC 2046."
(let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
To: Ned Freed <ned@innosoft.com>
Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
Subject: Sample message
MIME-Version: 1.0
Content-type: multipart/mixed; boundary=\"simple boundary\"
This is the preamble. It is to be ignored, though it
is a handy place for composition agents to include an
explanatory note to non-MIME conformant readers.
--simple boundary
This is implicitly typed plain US-ASCII text.
It does NOT end with a linebreak.
--simple boundary
Content-type: text/plain; charset=us-ascii
This is explicitly typed plain US-ASCII text.
It DOES end with a linebreak.
--simple boundary--
This is the epilogue. It is also to be ignored."))
(switch-to-buffer (get-buffer-create "*test*"))
(erase-buffer)
(insert mail)
(rmail-mime-show t)))
;;; Main code
(defun rmail-mime-handle (content-type
content-disposition
content-transfer-encoding)
"Handle the current buffer as a MIME part.
The current buffer should be narrowed to the respective body, and
point should be at the beginning of the body.
CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING
are the values of the respective parsed headers. The parsed
headers for CONTENT-TYPE and CONTENT-DISPOSITION have the form
\(VALUE . ALIST)
In other words:
\(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
VALUE is a string and ATTRIBUTE is a symbol.
Consider the following header, for example:
Content-Type: multipart/mixed;
boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"
The parsed header value:
\(\"multipart/mixed\"
\(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
;; Handle the content transfer encodings we know. Unknown transfer
;; encodings will be passed on to the various handlers.
(cond ((string= content-transfer-encoding "base64")
(when (ignore-errors
(base64-decode-region (point) (point-max)))
(setq content-transfer-encoding nil)))
((string= content-transfer-encoding "quoted-printable")
(quoted-printable-decode-region (point) (point-max))
(setq content-transfer-encoding nil))
((string= content-transfer-encoding "8bit")
;; FIXME: Is this the correct way?
(set-buffer-multibyte nil)))
;; Inline stuff requires work. Attachments are handled by the bulk
;; handler.
(if (string= "inline" (car content-disposition))
(let ((stop nil))
(dolist (entry rmail-mime-media-type-handlers-alist)
(when (and (string-match (car entry) (car content-type)) (not stop))
(progn
(setq stop (funcall (cadr entry) content-type
content-disposition
content-transfer-encoding))))))
;; Everything else is an attachment.
(rmail-mime-bulk-handler content-type
content-disposition
content-transfer-encoding)))
(defun rmail-mime-show (&optional show-headers)
"Handle the current buffer as a MIME message.
If SHOW-HEADERS is non-nil, then the headers of the current part
will shown as usual for a MIME message. The headers are also
shown for the content type message/rfc822. This function will be
called recursively if multiple parts are available.
The current buffer must contain a single message. It will be
modified."
(let ((end (point-min))
content-type
content-transfer-encoding
content-disposition)
;; `point-min' returns the beginning and `end' points at the end
;; of the headers.
(goto-char (point-min))
;; If we're showing a part without headers, then it will start
;; with a newline.
(if (eq (char-after) ?\n)
(setq end (1+ (point)))
(when (search-forward "\n\n" nil t)
(setq end (match-end 0))
(save-restriction
(narrow-to-region (point-min) end)
;; FIXME: Default disposition of the multipart entities should
;; be inherited.
(setq content-type
(mail-fetch-field "Content-Type")
content-transfer-encoding
(mail-fetch-field "Content-Transfer-Encoding")
content-disposition
(mail-fetch-field "Content-Disposition")))))
(if content-type
(setq content-type (mail-header-parse-content-type
content-type))
;; FIXME: Default "message/rfc822" in a "multipart/digest"
;; according to RFC 2046.
(setq content-type '("text/plain")))
(setq content-disposition
(if content-disposition
(mail-header-parse-content-disposition content-disposition)
;; If none specified, we are free to choose what we deem
;; suitable according to RFC 2183. We like inline.
'("inline")))
;; Unrecognized disposition types are to be treated like
;; attachment according to RFC 2183.
(unless (member (car content-disposition) '("inline" "attachment"))
(setq content-disposition '("attachment")))
;; Hide headers and handle the part.
(save-restriction
(cond ((string= (car content-type) "message/rfc822")
(narrow-to-region end (point-max)))
((not show-headers)
(delete-region (point-min) end)))
(rmail-mime-handle content-type content-disposition
content-transfer-encoding))))
(defun rmail-mime ()
"Copy buffer contents to a temporary buffer and handle MIME.
This calls `rmail-mime-show' to do the real job."
(interactive)
(rmail-swap-buffers-maybe)
(let ((data (with-current-buffer rmail-buffer
(save-restriction
(widen)
(buffer-substring
(rmail-msgbeg rmail-current-message)
(rmail-msgend rmail-current-message)))))
(buf (get-buffer-create "*RMAIL*")))
(set-buffer buf)
(let ((inhibit-read-only t))
(erase-buffer)
(insert data)
(rmail-mime-show t))
(view-buffer buf)))
(defun rmail-mm-get-boundary-error-message (message type disposition encoding)
"Return MESSAGE with more information on the main mime components."
(error "%s; type: %s; disposition: %s; encoding: %s"
message type disposition encoding))
(provide 'rmailmm)
;; Local Variables:
;; change-log-default-name: "ChangeLog.rmail"
;; End:
;; arch-tag: 3f2c5e5d-1aef-4512-bc20-fd737c9d5dd9
;;; rmailmm.el ends here

66
lisp/mail/rmailmsc.el Normal file
View file

@ -0,0 +1,66 @@
;;; rmailmsc.el --- miscellaneous support functions for the RMAIL mail reader
;; Copyright (C) 1985, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
;; 2009 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(eval-when-compile
(require 'rmail))
(defvar rmail-current-message)
(defvar rmail-inbox-list)
(declare-function mail-parse-comma-list "mail-utils" ())
(declare-function rmail-show-message "rmail" (&optional msg))
;;;###autoload
(defun set-rmail-inbox-list (file-name)
"Set the inbox list of the current RMAIL file to FILE-NAME.
You can specify one file name, or several names separated by commas.
If FILE-NAME is empty, remove any existing inbox list."
(interactive "sSet mailbox list to (comma-separated list of filenames): ")
(unless (eq major-mode 'rmail-mode)
(error "set-rmail-inbox-list works only for an Rmail file"))
(let ((inbox-list
(with-temp-buffer
(insert file-name)
(goto-char (point-min))
(nreverse (mail-parse-comma-list)))))
(when (or (not rmail-inbox-list)
(y-or-n-p (concat "Replace "
(mapconcat 'identity
rmail-inbox-list
", ")
"? ")))
(message "Setting the inbox list for %s for this session"
(file-name-nondirectory (buffer-file-name)))
(setq rmail-inbox-list inbox-list)))
(rmail-show-message rmail-current-message))
;; Local Variables:
;; change-log-default-name: "ChangeLog.rmail"
;; End:
;; arch-tag: 94614a62-2a0a-4e25-bac9-06f461ed4c60
;;; rmailmsc.el ends here

602
lisp/mail/rmailout.el Normal file
View file

@ -0,0 +1,602 @@
;;; rmailout.el --- "RMAIL" mail reader for Emacs: output message to a file
;; Copyright (C) 1985, 1987, 1993, 1994, 2001, 2002, 2003, 2004, 2005,
;; 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Maintainer: FSF
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(require 'rmail)
(provide 'rmailout)
;;;###autoload
(defcustom rmail-output-decode-coding nil
"*If non-nil, do coding system decoding when outputting message as Babyl."
:type '(choice (const :tag "on" t)
(const :tag "off" nil))
:group 'rmail)
;;;###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."
:type '(repeat (cons regexp
(choice :value ""
(string :tag "File Name")
sexp)))
:group 'rmail-output)
(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 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)))))))
;;;###autoload
(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.
;; Buffer should be pre-narrowed to the header.
;; PRESERVE is a regexp for fields NEVER to delete.
(defun rmail-delete-unwanted-fields (preserve)
(if rmail-fields-not-to-output
(save-excursion
(goto-char (point-min))
(while (re-search-forward rmail-fields-not-to-output nil t)
(beginning-of-line)
(unless (looking-at preserve)
(delete-region (point)
(progn (forward-line 1) (point))))))))
(defun rmail-output-as-babyl (file-name nomsg)
"Convert the current buffer's text to Babyl and output to FILE-NAME.
It alters the current buffer's text, so it should be a temp buffer."
(let ((coding-system-for-write
'emacs-mule-unix))
(save-restriction
(goto-char (point-min))
(search-forward "\n\n" nil 'move)
(narrow-to-region (point-min) (point))
(if rmail-fields-not-to-output
(rmail-delete-unwanted-fields nil)))
;; Convert to Babyl format.
(rmail-convert-to-babyl-format)
;; Write it into the file, or its buffer.
(let ((buf (find-buffer-visiting file-name))
(tembuf (current-buffer)))
(if (null buf)
(write-region (point-min) (point-max) file-name t nomsg)
(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 ((inhibit-read-only t)
(msg (with-no-warnings
(and (boundp 'rmail-current-message)
rmail-current-message))))
;; If MSG is non-nil, buffer is in RMAIL mode.
(if msg
(rmail-output-to-r-mail-buffer tembuf 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 tembuf)))))))
;; When Rmail is really installed, if we delete or rename the old Rmail
;; we should do likewise with this function.
(defun rmail-output-to-r-mail-buffer (tembuf msg)
"Copy msg in TEMBUF from BEG to END into this old R-mail BABYL buffer.
Do what is necessary to make babyl R-mail know about the new message.
Then display message number MSG."
(with-no-warnings
;; 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))
(rmail-maybe-set-message-counters)
(widen)
(narrow-to-region (point-max) (point-max))
(insert-buffer-substring tembuf)
(goto-char (point-min))
(widen)
(search-backward "\n\^_")
(narrow-to-region (point) (point-max))
(rmail-count-new-messages t)
(if (rmail-summary-exists)
(rmail-select-summary
(rmail-update-summary)))
(rmail-show-message msg)))
(defun rmail-convert-to-babyl-format ()
(let ((count 0) (start (point-min))
(case-fold-search nil)
(buffer-undo-list t))
(goto-char (point-min))
(save-restriction
(unless (looking-at "^From ")
(error "Invalid mbox message"))
(insert "\^L\n0, unseen,,\n*** EOOH ***\n")
(rmail-nuke-pinhead-header)
;; Decode base64 or quoted printable contents, Rmail style.
(let* ((header-end (save-excursion
(and (re-search-forward "\n\n" nil t)
(1- (point)))))
(case-fold-search t)
(quoted-printable-header-field-end
(save-excursion
(re-search-forward
"^content-transfer-encoding:\\(\n?[\t ]\\)*quoted-printable\\(\n?[\t ]\\)*"
header-end t)))
(base64-header-field-end
(and
;; Don't decode non-text data.
(save-excursion
(re-search-forward
"^content-type:\\(\n?[\t ]\\)\\(text\\|message\\)/"
header-end t))
(save-excursion
(re-search-forward
"^content-transfer-encoding:\\(\n?[\t ]\\)*base64\\(\n?[\t ]\\)*"
header-end t)))))
(goto-char (point-max))
(if quoted-printable-header-field-end
(save-excursion
(unless (mail-unquote-printable-region
header-end (point) nil t t)
(message "Malformed MIME quoted-printable message"))
;; Change "quoted-printable" to "8bit",
;; to reflect the decoding we just did.
(goto-char quoted-printable-header-field-end)
(delete-region (point) (search-backward ":"))
(insert ": 8bit")))
(if base64-header-field-end
(save-excursion
(when (condition-case nil
(progn
(base64-decode-region
(1+ header-end)
(save-excursion
;; Prevent base64-decode-region
;; from removing newline characters.
(skip-chars-backward "\n\t ")
(point)))
t)
(error nil))
;; Change "base64" to "8bit", to reflect the
;; decoding we just did.
(goto-char base64-header-field-end)
(delete-region (point) (search-backward ":"))
(insert ": 8bit")))))
;; Transform anything within the message text
;; that might appear to be the end of a Babyl-format message.
(save-excursion
(save-restriction
(narrow-to-region start (point))
(goto-char (point-min))
(while (search-forward "\n\^_" nil t) ; single char
(replace-match "\n^_")))) ; 2 chars: "^" and "_"
;; This is for malformed messages that don't end in newline.
;; There shouldn't be any, but some users say occasionally
;; there are some.
(or (bolp) (newline))
(insert ?\^_)
(setq last-coding-system-used nil)
;; Decode coding system, following specs in the message header,
;; and record what coding system was decoded.
(if rmail-output-decode-coding
(let ((mime-charset
(if (save-excursion
(goto-char start)
(search-forward "\n\n" nil t)
(let ((case-fold-search t))
(re-search-backward
rmail-mime-charset-pattern
start t)))
(intern (downcase (match-string 1))))))
(rmail-decode-region start (point) mime-charset)))
(save-excursion
(goto-char start)
(forward-line 3)
(insert "X-Coding-System: "
(symbol-name last-coding-system-used)
"\n")))))
;; Delete the "From ..." line, creating various other headers with
;; information from it if they don't already exist. Now puts the
;; original line into a mail-from: header line for debugging and for
;; use by the rmail-output function.
(defun rmail-nuke-pinhead-header ()
(save-excursion
(save-restriction
(let ((start (point))
(end (progn
(condition-case ()
(search-forward "\n\n")
(error
(goto-char (point-max))
(insert "\n\n")))
(point)))
has-from has-date)
(narrow-to-region start end)
(let ((case-fold-search t))
(goto-char start)
(setq has-from (search-forward "\nFrom:" nil t))
(goto-char start)
(setq has-date (and (search-forward "\nDate:" nil t) (point)))
(goto-char start))
(let ((case-fold-search nil))
(if (re-search-forward (concat "^" rmail-unix-mail-delimiter) nil t)
(replace-match
(concat
"Mail-from: \\&"
;; Keep and reformat the date if we don't
;; have a Date: field.
(if has-date
""
(concat
"Date: \\2, \\4 \\3 \\9 \\5 "
;; The timezone could be matched by group 7 or group 10.
;; If neither of them matched, assume EST, since only
;; Easterners would be so sloppy.
;; It's a shame the substitution can't use "\\10".
(cond
((/= (match-beginning 7) (match-end 7)) "\\7")
((/= (match-beginning 10) (match-end 10))
(buffer-substring (match-beginning 10)
(match-end 10)))
(t "EST"))
"\n"))
;; Keep and reformat the sender if we don't
;; have a From: field.
(if has-from
""
"From: \\1\n"))
t)))))))
(defun rmail-output-as-mbox (file-name nomsg &optional as-seen)
"Convert the current buffer's text to mbox Babyl and output to FILE-NAME.
It alters the current buffer's text, so call with a temp buffer current.
If FILE-NAME is visited, output into its buffer instead.
AS-SEEN is non-nil if we are copying the message \"as seen\"."
(let ((case-fold-search t)
mail-from mime-version content-type)
;; Preserve the Mail-From and MIME-Version fields
;; even if they have been pruned.
(search-forward "\n\n" nil 'move)
(narrow-to-region (point-min) (point))
(rmail-delete-unwanted-fields
(if rmail-enable-mime "Mail-From"
"Mail-From\\|MIME-Version\\|Content-type"))
(widen)
;; Make sure message ends with blank line.
(goto-char (point-max))
(unless (bolp)
(insert "\n"))
(unless (looking-back "\n\n")
(insert "\n"))
;; Generate a From line from other header fields
;; if necessary.
(goto-char (point-min))
(unless (looking-at "From ")
(insert "From "
(mail-strip-quoted-names
(save-excursion
(save-restriction
(goto-char (point-min))
(narrow-to-region
(point)
(or (search-forward "\n\n" nil)
(point-max)))
(or (mail-fetch-field "from")
(mail-fetch-field "really-from")
(mail-fetch-field "sender")
"unknown"))))
" " (current-time-string) "\n"))
(let ((buf (find-buffer-visiting file-name))
(tembuf (current-buffer)))
(if (null buf)
(let ((coding-system-for-write 'raw-text-unix))
(write-region (point-min) (point-max) file-name t nomsg))
(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 ((inhibit-read-only t)
(msg (and (boundp 'rmail-current-message)
rmail-current-message)))
(and msg as-seen
(error "Can't output \"as seen\" to a visited Rmail file"))
(if msg
(rmail-output-to-rmail-buffer tembuf 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 tembuf)))))))
;; Called only if rmail-summary-exists, which means rmailsum is loaded.
(declare-function rmail-update-summary "rmailsum" (&rest ignore))
(defun rmail-output-to-rmail-buffer (tembuf msg)
"Copy msg in TEMBUF from BEG to END into this Rmail buffer.
Do what is necessary to make Rmail know about the new message.
Then display message number MSG."
(save-excursion
(rmail-swap-buffers-maybe)
;; 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))
(rmail-maybe-set-message-counters)
(narrow-to-region (point-max) (point-max))
(insert-buffer-substring tembuf)
(rmail-count-new-messages t)
(if (rmail-summary-exists)
(rmail-select-summary
(rmail-update-summary)))
(rmail-show-message msg)))
;;; 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 mail file FILE-NAME.
This works with both mbox format and Babyl format files,
outputting in the appropriate format for each.
The default file name comes from `rmail-default-file',
which is updated to the name you use in this command.
A prefix argument COUNT says to output that many consecutive messages,
starting with the current one. Deleted messages are skipped and don't count.
When called from Lisp code, COUNT may be omitted and defaults to 1.
This command always outputs the complete message header,
even the header display is currently pruned.
The optional third argument NOATTRIBUTE, if non-nil, says not
to set the `filed' attribute, and not to display a message.
The optional fourth argument FROM-GNUS is set when called from GNUS."
(interactive
(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))))
;; Warn about creating new file.
(or (find-buffer-visiting file-name)
(file-exists-p file-name)
(yes-or-no-p
(concat "\"" file-name "\" does not exist, create it? "))
(error "Output file does not exist"))
(set-buffer rmail-buffer)
(let ((orig-count count)
(case-fold-search t)
(tembuf (get-buffer-create " rmail-output"))
(babyl-format
(and (file-readable-p file-name) (mail-file-babyl-p file-name))))
(unwind-protect
(while (> count 0)
(with-current-buffer rmail-buffer
(let (cur beg end)
(setq beg (rmail-msgbeg rmail-current-message)
end (rmail-msgend rmail-current-message))
;; All access to the buffer's local variables is now finished...
(save-excursion
;; ... so it is ok to go to a different buffer.
(if (rmail-buffers-swapped-p) (set-buffer rmail-view-buffer))
(setq cur (current-buffer))
(save-restriction
(widen)
(with-current-buffer tembuf
(insert-buffer-substring cur beg end)
;; Convert the text to one format or another and output.
(if babyl-format
(rmail-output-as-babyl file-name (if noattribute 'nomsg))
(rmail-output-as-mbox file-name
(if noattribute 'nomsg))))))))
;; Mark message as "filed".
(unless noattribute
(rmail-set-attribute rmail-filed-attr-index t))
(setq count (1- count))
(or from-gnus
(let ((next-message-p
(if rmail-delete-after-output
(rmail-delete-forward)
(if (> count 0)
(rmail-next-undeleted-message 1))))
(num-appended (- orig-count count)))
(if (and (> count 0) (not next-message-p))
(error "Only %d message%s appended" num-appended
(if (= num-appended 1) "" "s"))))))
(kill-buffer tembuf))))
(defun rmail-output-as-seen (file-name &optional count noattribute from-gnus)
"Append this message to system-inbox-format mail file named FILE-NAME.
A prefix argument COUNT says to output that many consecutive messages,
starting with the current one. Deleted messages are skipped and don't count.
When called from Lisp code, COUNT may be omitted and defaults to 1.
This outputs the message header as you see it.
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
to set the `filed' attribute, and not to display a message.
The optional fourth argument FROM-GNUS is set when called from GNUS."
(interactive
(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))))
(set-buffer rmail-buffer)
;; Warn about creating new file.
(or (find-buffer-visiting file-name)
(file-exists-p file-name)
(yes-or-no-p
(concat "\"" file-name "\" does not exist, create it? "))
(error "Output file does not exist"))
(if (and (file-readable-p file-name) (mail-file-babyl-p file-name))
(error "Cannot output `as seen' to a Babyl file"))
(let ((orig-count count)
(case-fold-search t)
(tembuf (get-buffer-create " rmail-output")))
(unwind-protect
(while (> count 0)
(let (cur beg end)
;; If operating from whole-mbox buffer, get message bounds.
(if (not (rmail-buffers-swapped-p))
(setq beg (rmail-msgbeg rmail-current-message)
end (rmail-msgend rmail-current-message)))
;; All access to the buffer's local variables is now finished...
(save-excursion
(setq cur (current-buffer))
(save-restriction
(widen)
;; If operating from the view buffer, get the bounds.
(unless beg
(setq beg (point-min)
end (point-max)))
(with-current-buffer tembuf
(insert-buffer-substring cur beg end)
;; Convert the text to one format or another and output.
(rmail-output-as-mbox file-name
(if noattribute 'nomsg)
t)))))
;; Mark message as "filed".
(unless noattribute
(rmail-set-attribute rmail-filed-attr-index t))
(setq count (1- count))
(or from-gnus
(let ((next-message-p
(if rmail-delete-after-output
(rmail-delete-forward)
(if (> count 0)
(rmail-next-undeleted-message 1))))
(num-appended (- orig-count count)))
(if (and (> count 0) (not next-message-p))
(error "Only %d message%s appended" num-appended
(if (= num-appended 1) "" "s"))))))
(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 (format "File %s exists; overwrite? " file-name)))
(error "Operation aborted"))
(write-region (point) (point-max) file-name))
(if rmail-delete-after-output
(rmail-delete-forward)))
;; Local Variables:
;; change-log-default-name: "ChangeLog.rmail"
;; End:
;; arch-tag: 4059abf0-f249-4be4-8e0d-602d370d01d1
;;; rmailout.el ends here

245
lisp/mail/rmailsort.el Normal file
View file

@ -0,0 +1,245 @@
;;; rmailsort.el --- Rmail: sort messages
;; Copyright (C) 1990, 1993, 1994, 2001, 2002, 2003, 2004,
;; 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp>
;; Maintainer: FSF
;; Keywords: mail
;; This file is part of GNU Emacs.
;; GNU Emacs 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 3 of the License, or
;; (at your option) any later version.
;; GNU Emacs 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 GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
;;; Commentary:
;;; Code:
(eval-when-compile
(require 'mail-utils)
(require 'sort)
(require 'rmail))
(autoload 'timezone-make-date-sortable "timezone")
(declare-function rmail-update-summary "rmailsum" (&rest ignore))
;; Sorting messages in Rmail buffer
;;;###autoload
(defun rmail-sort-by-date (reverse)
"Sort messages of current Rmail file by date.
If prefix argument REVERSE is non-nil, sort them in reverse order."
(interactive "P")
(rmail-sort-messages reverse
(function
(lambda (msg)
(rmail-make-date-sortable
(rmail-get-header "Date" msg))))))
;;;###autoload
(defun rmail-sort-by-subject (reverse)
"Sort messages of current Rmail file by subject.
If prefix argument REVERSE is non-nil, sort them in reverse order."
(interactive "P")
(rmail-sort-messages reverse
(function
(lambda (msg)
(let ((key (or (rmail-get-header "Subject" msg) ""))
(case-fold-search t))
;; Remove `Re:'
(if (string-match "^\\(re:[ \t]*\\)*" key)
(substring key (match-end 0))
key))))))
;;;###autoload
(defun rmail-sort-by-author (reverse)
"Sort messages of current Rmail file by author.
If prefix argument REVERSE is non-nil, sort them in reverse order."
(interactive "P")
(rmail-sort-messages reverse
(function
(lambda (msg)
(downcase ;Canonical name
(mail-strip-quoted-names
(or (rmail-get-header "From" msg)
(rmail-get-header "Sender" msg) "")))))))
;;;###autoload
(defun rmail-sort-by-recipient (reverse)
"Sort messages of current Rmail file by recipient.
If prefix argument REVERSE is non-nil, sort them in reverse order."
(interactive "P")
(rmail-sort-messages reverse
(function
(lambda (msg)
(downcase ;Canonical name
(mail-strip-quoted-names
(or (rmail-get-header "To" msg)
(rmail-get-header "Apparently-To" msg) "")
))))))
;;;###autoload
(defun rmail-sort-by-correspondent (reverse)
"Sort messages of current Rmail file by other correspondent.
If prefix argument REVERSE is non-nil, sort them in reverse order."
(interactive "P")
(rmail-sort-messages reverse
(function
(lambda (msg)
(rmail-select-correspondent
msg
'("From" "Sender" "To" "Apparently-To"))))))
(defun rmail-select-correspondent (msg fields)
(let ((ans ""))
(while (and fields (string= ans ""))
(setq ans
;; NB despite the name, this lives in mail-utils.el.
(rmail-dont-reply-to
(mail-strip-quoted-names
(or (rmail-get-header (car fields) msg) ""))))
(setq fields (cdr fields)))
ans))
;;;###autoload
(defun rmail-sort-by-lines (reverse)
"Sort messages of current Rmail file by number of lines.
If prefix argument REVERSE is non-nil, sort them in reverse order."
(interactive "P")
(rmail-sort-messages reverse
(function
(lambda (msg)
(count-lines (rmail-msgbeg msg)
(rmail-msgend msg))))))
;;;###autoload
(defun rmail-sort-by-labels (reverse labels)
"Sort messages of current Rmail file by labels.
If prefix argument REVERSE is non-nil, sort them in reverse order.
KEYWORDS is a comma-separated list of labels."
(interactive "P\nsSort by labels: ")
(or (string-match "[^ \t]" labels)
(error "No labels specified"))
(setq labels (concat (substring labels (match-beginning 0)) ","))
(let (labelvec)
(while (string-match "[ \t]*,[ \t]*" labels)
(setq labelvec (cons
(concat ", ?\\("
(substring labels 0 (match-beginning 0))
"\\),")
labelvec))
(setq labels (substring labels (match-end 0))))
(setq labelvec (apply 'vector (nreverse labelvec)))
(rmail-sort-messages reverse
(function
(lambda (msg)
(let ((n 0))
(while (and (< n (length labelvec))
(not (rmail-message-labels-p
msg (aref labelvec n))))
(setq n (1+ n)))
n))))))
;; Basic functions
(defun rmail-sort-messages (reverse keyfun)
"Sort messages of current Rmail file.
If 1st argument REVERSE is non-nil, sort them in reverse order.
2nd argument KEYFUN is called with a message number, and should return a key."
(with-current-buffer rmail-buffer
(let ((return-to-point
(if (rmail-buffers-swapped-p)
(point)))
(predicate nil) ;< or string-lessp
(sort-lists nil))
(rmail-swap-buffers-maybe)
(message "Finding sort keys...")
(widen)
(let ((msgnum 1))
(while (>= rmail-total-messages msgnum)
(setq sort-lists
(cons (list (funcall keyfun msgnum) ;Make sorting key
(eq rmail-current-message msgnum) ;True if current
(aref rmail-message-vector msgnum)
(aref rmail-message-vector (1+ msgnum)))
sort-lists))
(if (zerop (% msgnum 10))
(message "Finding sort keys...%d" msgnum))
(setq msgnum (1+ msgnum))))
(or reverse (setq sort-lists (nreverse sort-lists)))
;; Decide predicate: < or string-lessp
(if (numberp (car (car sort-lists))) ;Is a key numeric?
(setq predicate (function <))
(setq predicate (function string-lessp)))
(setq sort-lists
(sort sort-lists
(function
(lambda (a b)
(funcall predicate (car a) (car b))))))
(if reverse (setq sort-lists (nreverse sort-lists)))
;; Now we enter critical region. So, keyboard quit is disabled.
(message "Reordering messages...")
(let ((inhibit-quit t) ;Inhibit quit
(inhibit-read-only t)
(current-message nil)
(msgnum 1)
(msginfo nil))
;; There's little hope that we can easily undo after that.
(buffer-disable-undo (current-buffer))
(goto-char (rmail-msgbeg 1))
;; To force update of all markers,
;; keep the new copies separated from the remaining old messages.
(insert-before-markers ?Z)
(backward-char 1)
;; Now reorder messages.
(dolist (msginfo sort-lists)
;; Swap two messages.
(insert-buffer-substring
(current-buffer) (nth 2 msginfo) (nth 3 msginfo))
;; The last message may not have \n\n after it.
(unless (bobp)
(insert "\n"))
(unless (looking-back "\n\n")
(insert "\n"))
(delete-region (nth 2 msginfo) (nth 3 msginfo))
;; Is current message?
(if (nth 1 msginfo)
(setq current-message msgnum))
(if (zerop (% msgnum 10))
(message "Reordering messages...%d" msgnum))
(setq msgnum (1+ msgnum)))
;; Delete the dummy separator Z inserted before.
(delete-char 1)
(setq quit-flag nil)
(rmail-set-message-counters)
(rmail-show-message current-message)
(if return-to-point
(goto-char return-to-point))
(if (rmail-summary-exists)
(rmail-select-summary (rmail-update-summary)))))))
(defun rmail-make-date-sortable (date)
"Make DATE sortable using the function string-lessp."
;; Assume the default time zone is GMT.
(timezone-make-date-sortable date "GMT" "GMT"))
(provide 'rmailsort)
;; Local Variables:
;; change-log-default-name: "ChangeLog.rmail"
;; End:
;; arch-tag: 665da245-f6a7-4115-ad8c-ba19216988d5
;;; rmailsort.el ends here

1765
lisp/mail/rmailsum.el Normal file
View file

File diff suppressed because it is too large Load diff