# HG changeset patch # User Alex Schroeder # Date 1139008235 0 # Node ID b72b8d5365111a2c5a9c197de76f64696987f072 # Parent fa5dc8645397b74a25129cf14ae0a579aff116ef Renamed all symbols to rmail-mime-*. Rewrote code such as to modify the buffer instead of using display properties. Fixed bulk handler, and wrote simple test defun for it. diff -r fa5dc8645397 -r b72b8d536511 lisp/mail/rmailmm.el --- a/lisp/mail/rmailmm.el Wed Feb 01 19:26:54 2006 +0000 +++ b/lisp/mail/rmailmm.el Fri Feb 03 23:10:35 2006 +0000 @@ -25,29 +25,25 @@ ;;; 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. +;; extensions (mime-display.el and mime.el). To use, copy a complete +;; message into a new buffer and call (mime-show t). ;;; 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)) +(defcustom rmail-mime-media-type-handlers-alist + '(("multipart/.*" rmail-mime-multipart-handler) + ("message/rfc822" rmail-mime-toggler-handler) + ("message/delivery-status" rmail-mime-entity-hider-handler) + ("message/x-body" rmail-mime-entity-hider-handler) + ("message/x-command-input" rmail-mime-message/x-command-input-handler) + ("message/external-body" rmail-mime-message/external-body-handler) + ("text/.*" rmail-mime-text-handler) + ("text/\\(x-\\)?patch" rmail-mime-bulk-handler) + ("image/.*" rmail-mime-image-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 @@ -55,92 +51,112 @@ :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." +(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 mime-total-number-of-bulk-attachments 0 +(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 '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)) +(put 'rmail-mime-total-number-of-bulk-attachments 'permanent-local t) ;;; Buttons -(defun mime-save (button) +(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 "Save as: " - directory nil nil filename))) + (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 'mime-save - 'action 'mime-save) +(define-button-type 'rmail-mime-save + 'action 'rmail-mime-save) ;;; Handlers -(defun mime-text-handler (content-type - content-disposition - content-transfer-encoding) +(defun rmail-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) +(defun rmail-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)) + (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 mime-attachment-dirs-alist) - (when (string-match (car entry) (car content-type)) - (throw 'directory (cadr entry)))))) + (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")) - (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))) + (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 mime-multipart-handler (content-type - content-disposition - content-transfer-encoding) +(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 `mime-handle' for their +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: @@ -150,46 +166,45 @@ ;; of the preceding part. ;; We currently don't handle that. (let ((boundary (cdr (assq 'boundary content-type))) - (beg (point-min)) - next) + beg 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) + (goto-char (point-min)) (when (and (search-forward boundary nil t) (looking-at "[ \t]*\n")) - (mime-hide-region beg (match-end 0)) - (setq beg (match-end 0))) + (delete-region (point-min) (match-end 0))) ;; Reset the counter - (setq mime-total-number-of-bulk-attachments 0) + (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. + ;; 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))) + (setq next (point-max-marker))) ((looking-at "[ \t]*\n") - (setq next (match-end 0))) + (setq next (copy-marker (match-end 0)))) (t (error "Malformed boundary" content-type content-disposition content-transfer-encoding))) - (mime-hide-region end next) + (delete-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)))) + (rmail-mime-show)))) (setq beg next) (goto-char beg)))) -(defun test-mime-multipart-handler () +(defun test-rmail-mime-multipart-handler () "Test of a mail used as an example in RFC 2046." (let ((mail "From: Nathaniel Borenstein To: Ned Freed @@ -218,12 +233,13 @@ (switch-to-buffer (get-buffer-create "*test*")) (erase-buffer) (insert mail) - (mime-show t) - (buffer-string))) + (rmail-mime-show t))) ;;; Main code -(defun mime-handle (content-type content-disposition content-transfer-encoding) +(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. CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING @@ -247,29 +263,38 @@ \(\"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") + (base64-decode-region (point-min) (point-max)) + (setq content-transfer-encoding nil)) + ((string= content-transfer-encoding "quoted-printable") + (quoted-printable-decode-region (point-min) (point-max)) + (setq content-transfer-encoding nil))) + ;; Inline stuff requires work. Attachments are handled by the bulk + ;; handler. (if (string= "inline" (car content-disposition)) (let ((stop nil)) - (dolist (entry mime-media-type-handlers-alist) + (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)))))) - ;; treat everything else as an attachment - (mime-bulk-handler content-type + ;; Everything else is an attachment. + (rmail-mime-bulk-handler content-type content-disposition content-transfer-encoding))) -(defun mime-show (&optional show-headers) +(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 -are not all hidden, as they usually are \(except for -message/rfc822 content types\). This is usually only used for -the top-level call. +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 be narrowed to a single message. -This function will be called recursively if multiple parts -are available." +The current buffer must contain a single message. It will be +modifed." (let ((end (point-min)) content-type content-transfer-encoding @@ -307,16 +332,17 @@ ;; 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") + (unless (member (car content-disposition) '("inline" "attachment")) (setq content-disposition '("attachment"))) + ;; Hide headers and handle the part. (save-restriction - (narrow-to-region end (point-max)) - (mime-handle content-type content-disposition - content-transfer-encoding)))) + (if (or show-headers + (string= (car content-type) "message/rfc822")) + (progn + (rmail-header-hide-headers) + (narrow-to-region end (point-max))) + (delete-region (point-min) end)) + (rmail-mime-handle content-type content-disposition + content-transfer-encoding))))