Mercurial > emacs
view lisp/mail/rmailmm.el @ 88306:7b65aade5e20
new file, based on Alexander Pohoyda's code.
author | Alex Schroeder <alex@gnu.org> |
---|---|
date | Tue, 31 Jan 2006 20:53:28 +0000 |
parents | |
children | b72b8d536511 |
line wrap: on
line source
;;; rmailmm.el --- MIME decoding and display stuff for RMAIL ;; Copyright (C) 2006 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 2, 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; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;;; Commentary: ;; Essentially based on the design of Alexander Pohoyda's MIME ;; extensions (mime-display.el and mime.el). The current design tries ;; to work on the current buffer, without changing it's text. All it ;; does is add text properties: It uses the text property `invisible' ;; to hide MIME boundaries and ignored media types, and it uses the ;; text property `display' to display something instead of the actual ;; MIME part. ;;; Code: ;;; Variables (defcustom mime-media-type-handlers-alist '(("multipart/.*" mime-multipart-handler) ("message/rfc822" mime-toggler-handler) ("message/delivery-status" mime-entity-hider-handler) ("message/x-body" mime-entity-hider-handler) ("message/x-command-input" mime-message/x-command-input-handler) ("message/external-body" mime-message/external-body-handler) ("text/.*" mime-text-handler) ("text/\\(x-\\)?patch" mime-bulk-handler) ("image/.*" mime-image-handler) ("application/pgp-signature" mime-application/pgp-signature-handler) ("\\(image\\|audio\\|video\\|application\\)/.*" 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." :type 'list :group 'mime) (defcustom mime-attachment-dirs-alist '(("text/.*" ("~/Documents")) ("image/.*" ("~/Pictures")) (".*" ("/tmp/"))) "Default directories to save attachments into. Each media type may have it's own directory." :type 'list :group 'mime) (defvar 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 'mime-total-number-of-bulk-attachments 'permanent-local t) ;;; Utility Functions (defun mime-hide-region (from to) "Put text property `invisible' on the region FROM TO." (put-text-property from to 'invisible t)) (defun mime-unhide-region (from to) "Remove the text property `invisible' on the region FROM TO." (remove-text-properties from to '(invisible nil))) (defun mime-display-region-as (from to text) "Put text property `display' with value TEXT on the region FROM TO." (put-text-property from to 'display text)) ;;; Buttons (defun 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))) (setq filename (expand-file-name (read-file-name "Save as: " directory nil nil filename))) (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 'mime-save 'action 'mime-save) ;;; Handlers (defun mime-text-handler (content-type content-disposition content-transfer-encoding) "Handle the current buffer as a plain text MIME part.") (defun mime-bulk-handler (content-type content-disposition content-transfer-encoding) "Handle the current buffer as an attachment to download." (setq mime-total-number-of-bulk-attachments (1+ mime-total-number-of-bulk-attachments)) ;; Find the default directory for this media type (let* ((directory (catch 'directory (dolist (entry mime-attachment-dirs-alist) (when (string-match (car entry) (car content-type)) (throw 'directory (cadr entry)))))) (filename (or (cdr (assq 'name (cdr content-type))) (cdr (assq 'filename (cdr content-disposition))) "noname")) (button (format "\nAttached %s file: %s" (car content-type) (let ((data (buffer-string))) (with-temp-buffer (insert-button filename :type 'mime-save 'filename filename 'directory directory 'data data) (buffer-string)))))) (mime-display-region-as (point-min) (point-max) button))) (defun 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 `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 (point-min)) next) (unless boundary (error "No boundary defined" content-type content-disposition content-transfer-encoding)) (setq boundary (concat "\n--" boundary)) ;; Hide the body before the first bodypart (goto-char beg) (when (and (search-forward boundary nil t) (looking-at "[ \t]*\n")) (mime-hide-region beg (match-end 0)) (setq beg (match-end 0))) ;; Reset the counter (setq 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. (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. (cond ((looking-at "--[ \t]*\n") (setq next (point-max))) ((looking-at "[ \t]*\n") (setq next (match-end 0))) (t (error "Malformed boundary" content-type content-disposition content-transfer-encoding))) (mime-hide-region end next) ;; Handle the part. (save-match-data (save-excursion (save-restriction (narrow-to-region beg end) ;; FIXME: Do decoding of content-transfer-encoding (mime-show)))) (setq beg next) (goto-char beg)))) (defun test-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) (mime-show t) (buffer-string))) ;;; Main code (defun 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. 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\"))" (if (string= "inline" (car content-disposition)) (let ((stop nil)) (dolist (entry 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)))))) ;; treat everything else as an attachment (mime-bulk-handler content-type content-disposition content-transfer-encoding))) (defun 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 are not all hidden, as they usually are \(except for message/rfc822 content types\). This is usually only used for the top-level call. The current buffer must be narrowed to a single message. This function will be called recursively if multiple parts are available." (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. We're not using `rmail-header-get-header' ;; because we must be able to handle the case of no headers ;; existing in a part. In this case end is at point-min. (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"))) ;; Hide headers. (if (or (string= (car content-type) "message/rfc822") show-headers) (rmail-header-hide-headers) (mime-hide-region (point-min) end)) ;; Unrecognized disposition types are to be treated like ;; attachment according to RFC 2183. (unless (string= (car content-disposition) "inline") (setq content-disposition '("attachment"))) (save-restriction (narrow-to-region end (point-max)) (mime-handle content-type content-disposition content-transfer-encoding))))