code.delx.au - gnu-emacs/blob - lisp/mail/rmailmm.el

   1 ;;; rmailmm.el --- MIME decoding and display stuff for RMAIL
   2
   3 ;; Copyright (C) 2006, 2007, 2008, 2009, 2010  Free Software Foundation, Inc.
   4
   5 ;; Author: Alexander Pohoyda
   6 ;;      Alex Schroeder
   7 ;; Maintainer: FSF
   8 ;; Keywords: mail
   9 ;; Package: rmail
  10
  11 ;; This file is part of GNU Emacs.
  12
  13 ;; GNU Emacs is free software: you can redistribute it and/or modify
  14 ;; it under the terms of the GNU General Public License as published by
  15 ;; the Free Software Foundation, either version 3 of the License, or
  16 ;; (at your option) any later version.
  17
  18 ;; GNU Emacs is distributed in the hope that it will be useful,
  19 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;; GNU General Public License for more details.
  22
  23 ;; You should have received a copy of the GNU General Public License
  24 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  25
  26 ;;; Commentary:
  27
  28 ;; Essentially based on the design of Alexander Pohoyda's MIME
  29 ;; extensions (mime-display.el and mime.el).
  30 ;; Call `M-x rmail-mime' when viewing an Rmail message.
  31
  32 ;; Todo:
  33
  34 ;; Handle multipart/alternative.
  35 ;; Offer the option to call external/internal viewers (doc-view, xpdf, etc).
  36
  37 ;;; Code:
  38
  39 (require 'rmail)
  40 (require 'mail-parse)
  41
  42 ;;; User options.
  43
  44 (defgroup rmail-mime nil
  45   "Rmail MIME handling options."
  46   :prefix "rmail-mime-"
  47   :group 'rmail)
  48
  49 (defcustom rmail-mime-media-type-handlers-alist
  50   '(("multipart/.*" rmail-mime-multipart-handler)
  51     ("text/.*" rmail-mime-text-handler)
  52     ("text/\\(x-\\)?patch" rmail-mime-bulk-handler)
  53     ("\\(image\\|audio\\|video\\|application\\)/.*" rmail-mime-bulk-handler))
  54   "Functions to handle various content types.
  55 This is an alist with elements of the form (REGEXP FUNCTION ...).
  56 The first item is a regular expression matching a content-type.
  57 The remaining elements are handler functions to run, in order of
  58 decreasing preference.  These are called until one returns non-nil.
  59 Note that this only applies to items with an inline Content-Disposition,
  60 all others are handled by `rmail-mime-bulk-handler'."
  61   :type '(alist :key-type regexp :value-type (repeat function))
  62   :version "23.1"
  63   :group 'rmail-mime)
  64
  65 (defcustom rmail-mime-attachment-dirs-alist
  66   `(("text/.*" "~/Documents")
  67     ("image/.*" "~/Pictures")
  68     (".*" "~/Desktop" "~" ,temporary-file-directory))
  69   "Default directories to save attachments of various types into.
  70 This is an alist with elements of the form (REGEXP DIR ...).
  71 The first item is a regular expression matching a content-type.
  72 The remaining elements are directories, in order of decreasing preference.
  73 The first directory that exists is used."
  74   :type '(alist :key-type regexp :value-type (repeat directory))
  75   :version "23.1"
  76   :group 'rmail-mime)
  77
  78 (defcustom rmail-mime-show-images 'button
  79   "What to do with image attachments that Emacs is capable of displaying.
  80 If nil, do nothing special.  If `button', add an extra button
  81 that when pushed displays the image in the buffer.  If a number,
  82 automatically show images if they are smaller than that size (in
  83 bytes), otherwise add a display button.  Anything else means to
  84 automatically display the image in the buffer."
  85   :type '(choice (const :tag "Add button to view image" button)
  86                  (const :tag "No special treatment" nil)
  87                  (number :tag "Show if smaller than certain size")
  88                  (other :tag "Always show" show))
  89   :version "23.2"
  90   :group 'rmail-mime)
  91
  92 ;;; End of user options.
  93
  94
  95 ;;; Buttons
  96
  97 (defun rmail-mime-save (button)
  98   "Save the attachment using info in the BUTTON."
  99   (let* ((filename (button-get button 'filename))
 100          (directory (button-get button 'directory))
 101          (data (button-get button 'data))
 102          (ofilename filename))
 103     (setq filename (expand-file-name
 104                     (read-file-name (format "Save as (default: %s): " filename)
 105                                     directory
 106                                     (expand-file-name filename directory))
 107                     directory))
 108     ;; If arg is just a directory, use the default file name, but in
 109     ;; that directory (copied from write-file).
 110     (if (file-directory-p filename)
 111         (setq filename (expand-file-name
 112                         (file-name-nondirectory ofilename)
 113                         (file-name-as-directory filename))))
 114     (with-temp-buffer
 115       (set-buffer-file-coding-system 'no-conversion)
 116       ;; Needed e.g. by jka-compr, so if the attachment is a compressed
 117       ;; file, the magic signature compares equal with the unibyte
 118       ;; signature string recorded in jka-compr-compression-info-list.
 119       (set-buffer-multibyte nil)
 120       (insert data)
 121       (write-region nil nil filename nil nil nil t))))
 122
 123 (define-button-type 'rmail-mime-save 'action 'rmail-mime-save)
 124
 125 ;;; Handlers
 126
 127 (defun rmail-mime-text-handler (content-type
 128                                 content-disposition
 129                                 content-transfer-encoding)
 130   "Handle the current buffer as a plain text MIME part."
 131   (let* ((charset (cdr (assq 'charset (cdr content-type))))
 132          (coding-system (when charset
 133                           (intern (downcase charset)))))
 134     (when (coding-system-p coding-system)
 135       (decode-coding-region (point-min) (point-max) coding-system))))
 136
 137 ;; FIXME move to the test/ directory?
 138 (defun test-rmail-mime-handler ()
 139   "Test of a mail using no MIME parts at all."
 140   (let ((mail "To: alex@gnu.org
 141 Content-Type: text/plain; charset=koi8-r
 142 Content-Transfer-Encoding: 8bit
 143 MIME-Version: 1.0
 144
 145 \372\304\322\301\327\323\324\327\325\312\324\305\41"))
 146     (switch-to-buffer (get-buffer-create "*test*"))
 147     (erase-buffer)
 148     (set-buffer-multibyte nil)
 149     (insert mail)
 150     (rmail-mime-show t)
 151     (set-buffer-multibyte t)))
 152
 153
 154 (defun rmail-mime-insert-image (type data)
 155   "Insert an image of type TYPE, where DATA is the image data."
 156   (end-of-line)
 157   (insert ?\n)
 158   (insert-image (create-image data type t)))
 159
 160 (defun rmail-mime-image (button)
 161   "Display the image associated with BUTTON."
 162   (let ((inhibit-read-only t))
 163     (rmail-mime-insert-image (button-get button 'image-type)
 164                              (button-get button 'image-data))))
 165
 166 (define-button-type 'rmail-mime-image 'action 'rmail-mime-image)
 167
 168
 169 (defun rmail-mime-bulk-handler (content-type
 170                                 content-disposition
 171                                 content-transfer-encoding)
 172   "Handle the current buffer as an attachment to download.
 173 For images that Emacs is capable of displaying, the behavior
 174 depends upon the value of `rmail-mime-show-images'."
 175   ;; Find the default directory for this media type.
 176   (let* ((directory (catch 'directory
 177                       (dolist (entry rmail-mime-attachment-dirs-alist)
 178                         (when (string-match (car entry) (car content-type))
 179                           (dolist (dir (cdr entry))
 180                             (when (file-directory-p dir)
 181                               (throw 'directory dir)))))))
 182          (filename (or (cdr (assq 'name (cdr content-type)))
 183                        (cdr (assq 'filename (cdr content-disposition)))
 184                        "noname"))
 185          (label (format "\nAttached %s file: " (car content-type)))
 186          (data (buffer-string))
 187          (udata (string-as-unibyte data))
 188          (size (length udata))
 189          (osize size)
 190          (units '(B kB MB GB))
 191          type)
 192     (while (and (> size 1024.0) ; cribbed from gnus-agent-expire-done-message
 193                 (cdr units))
 194       (setq size (/ size 1024.0)
 195             units (cdr units)))
 196     (delete-region (point-min) (point-max))
 197     (insert label)
 198     (insert-button filename
 199                    :type 'rmail-mime-save
 200                    'help-echo "mouse-2, RET: Save attachment"
 201                    'filename filename
 202                    'directory (file-name-as-directory directory)
 203                    'data data)
 204     (insert (format " (%.0f%s)" size (car units)))
 205     (when (and rmail-mime-show-images
 206                (string-match "image/\\(.*\\)" (setq type (car content-type)))
 207                (setq type (concat "." (match-string 1 type))
 208                      type (image-type-from-file-name type))
 209                (memq type image-types)
 210                (image-type-available-p type))
 211       (insert " ")
 212       (cond ((or (eq rmail-mime-show-images 'button)
 213                  (and (numberp rmail-mime-show-images)
 214                       (>= osize rmail-mime-show-images)))
 215              (insert-button "Display"
 216                             :type 'rmail-mime-image
 217                             'help-echo "mouse-2, RET: Show image"
 218                             'image-type type
 219                             'image-data udata))
 220             (t
 221              (rmail-mime-insert-image type udata))))))
 222
 223 (defun test-rmail-mime-bulk-handler ()
 224   "Test of a mail used as an example in RFC 2183."
 225   (let ((mail "Content-Type: image/jpeg
 226 Content-Disposition: attachment; filename=genome.jpeg;
 227   modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
 228 Content-Description: a complete map of the human genome
 229 Content-Transfer-Encoding: base64
 230
 231 iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
 232 TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
 233 +ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
 234 WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
 235 9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
 236 UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
 237 lgAAAABJRU5ErkJggg==
 238 "))
 239     (switch-to-buffer (get-buffer-create "*test*"))
 240     (erase-buffer)
 241     (insert mail)
 242     (rmail-mime-show)))
 243
 244 (defun rmail-mime-multipart-handler (content-type
 245                                      content-disposition
 246                                      content-transfer-encoding)
 247   "Handle the current buffer as a multipart MIME body.
 248 The current buffer should be narrowed to the body.  CONTENT-TYPE,
 249 CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
 250 of the respective parsed headers.  See `rmail-mime-handle' for their
 251 format."
 252   ;; Some MUAs start boundaries with "--", while it should start
 253   ;; with "CRLF--", as defined by RFC 2046:
 254   ;;    The boundary delimiter MUST occur at the beginning of a line,
 255   ;;    i.e., following a CRLF, and the initial CRLF is considered to
 256   ;;    be attached to the boundary delimiter line rather than part
 257   ;;    of the preceding part.
 258   ;; We currently don't handle that.
 259   (let ((boundary (cdr (assq 'boundary content-type)))
 260         beg end next)
 261     (unless boundary
 262       (rmail-mm-get-boundary-error-message
 263        "No boundary defined" content-type content-disposition
 264        content-transfer-encoding))
 265     (setq boundary (concat "\n--" boundary))
 266     ;; Hide the body before the first bodypart
 267     (goto-char (point-min))
 268     (when (and (search-forward boundary nil t)
 269                (looking-at "[ \t]*\n"))
 270       (delete-region (point-min) (match-end 0)))
 271     ;; Loop over all body parts, where beg points at the beginning of
 272     ;; the part and end points at the end of the part.  next points at
 273     ;; the beginning of the next part.
 274     (setq beg (point-min))
 275     (while (search-forward boundary nil t)
 276       (setq end (match-beginning 0))
 277       ;; If this is the last boundary according to RFC 2046, hide the
 278       ;; epilogue, else hide the boundary only.  Use a marker for
 279       ;; `next' because `rmail-mime-show' may change the buffer.
 280       (cond ((looking-at "--[ \t]*$")
 281              (setq next (point-max-marker)))
 282             ((looking-at "[ \t]*\n")
 283              (setq next (copy-marker (match-end 0) t)))
 284             (t
 285              (rmail-mm-get-boundary-error-message
 286               "Malformed boundary" content-type content-disposition
 287               content-transfer-encoding)))
 288       (delete-region end next)
 289       ;; Handle the part.
 290       (save-restriction
 291         (narrow-to-region beg end)
 292         (rmail-mime-show))
 293       (goto-char (setq beg next)))))
 294
 295
 296 (defun test-rmail-mime-multipart-handler ()
 297   "Test of a mail used as an example in RFC 2046."
 298   (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
 299 To: Ned Freed <ned@innosoft.com>
 300 Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
 301 Subject: Sample message
 302 MIME-Version: 1.0
 303 Content-type: multipart/mixed; boundary=\"simple boundary\"
 304
 305 This is the preamble.  It is to be ignored, though it
 306 is a handy place for composition agents to include an
 307 explanatory note to non-MIME conformant readers.
 308
 309 --simple boundary
 310
 311 This is implicitly typed plain US-ASCII text.
 312 It does NOT end with a linebreak.
 313 --simple boundary
 314 Content-type: text/plain; charset=us-ascii
 315
 316 This is explicitly typed plain US-ASCII text.
 317 It DOES end with a linebreak.
 318
 319 --simple boundary--
 320
 321 This is the epilogue.  It is also to be ignored."))
 322     (switch-to-buffer (get-buffer-create "*test*"))
 323     (erase-buffer)
 324     (insert mail)
 325     (rmail-mime-show t)))
 326
 327 ;;; Main code
 328
 329 (defun rmail-mime-handle (content-type
 330                           content-disposition
 331                           content-transfer-encoding)
 332   "Handle the current buffer as a MIME part.
 333 The current buffer should be narrowed to the respective body, and
 334 point should be at the beginning of the body.
 335
 336 CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING
 337 are the values of the respective parsed headers.  The latter should
 338 be downcased.  The parsed headers for CONTENT-TYPE and CONTENT-DISPOSITION
 339 have the form
 340
 341   \(VALUE . ALIST)
 342
 343 In other words:
 344
 345   \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
 346
 347 VALUE is a string and ATTRIBUTE is a symbol.
 348
 349 Consider the following header, for example:
 350
 351 Content-Type: multipart/mixed;
 352         boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"
 353
 354 The parsed header value:
 355
 356 \(\"multipart/mixed\"
 357   \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
 358   ;; Handle the content transfer encodings we know.  Unknown transfer
 359   ;; encodings will be passed on to the various handlers.
 360   (cond ((string= content-transfer-encoding "base64")
 361          (when (ignore-errors
 362                  (base64-decode-region (point) (point-max)))
 363            (setq content-transfer-encoding nil)))
 364         ((string= content-transfer-encoding "quoted-printable")
 365          (quoted-printable-decode-region (point) (point-max))
 366          (setq content-transfer-encoding nil))
 367         ((string= content-transfer-encoding "8bit")
 368          ;; FIXME: Is this the correct way?
 369          ;; No, of course not, it just means there's no decoding to do.
 370          ;; (set-buffer-multibyte nil)
 371          (setq content-transfer-encoding nil)
 372          ))
 373   ;; Inline stuff requires work.  Attachments are handled by the bulk
 374   ;; handler.
 375   (if (string= "inline" (car content-disposition))
 376       (let ((stop nil))
 377         (dolist (entry rmail-mime-media-type-handlers-alist)
 378           (when (and (string-match (car entry) (car content-type)) (not stop))
 379             (progn
 380               (setq stop (funcall (cadr entry) content-type
 381                                   content-disposition
 382                                   content-transfer-encoding))))))
 383     ;; Everything else is an attachment.
 384     (rmail-mime-bulk-handler content-type
 385                        content-disposition
 386                        content-transfer-encoding)))
 387
 388 (defun rmail-mime-show (&optional show-headers)
 389   "Handle the current buffer as a MIME message.
 390 If SHOW-HEADERS is non-nil, then the headers of the current part
 391 will shown as usual for a MIME message.  The headers are also
 392 shown for the content type message/rfc822.  This function will be
 393 called recursively if multiple parts are available.
 394
 395 The current buffer must contain a single message.  It will be
 396 modified."
 397   (let ((end (point-min))
 398         content-type
 399         content-transfer-encoding
 400         content-disposition)
 401     ;; `point-min' returns the beginning and `end' points at the end
 402     ;; of the headers.
 403     (goto-char (point-min))
 404     ;; If we're showing a part without headers, then it will start
 405     ;; with a newline.
 406     (if (eq (char-after) ?\n)
 407         (setq end (1+ (point)))
 408       (when (search-forward "\n\n" nil t)
 409         (setq end (match-end 0))
 410         (save-restriction
 411           (narrow-to-region (point-min) end)
 412           ;; FIXME: Default disposition of the multipart entities should
 413           ;; be inherited.
 414           (setq content-type
 415                 (mail-fetch-field "Content-Type")
 416                 content-transfer-encoding
 417                 (mail-fetch-field "Content-Transfer-Encoding")
 418                 content-disposition
 419                 (mail-fetch-field "Content-Disposition")))))
 420     ;; Per RFC 2045, C-T-E is case insensitive (bug#5070), but the others
 421     ;; are not completely so.  Hopefully mail-header-parse-* DTRT.
 422     (if content-transfer-encoding
 423         (setq content-transfer-encoding (downcase content-transfer-encoding)))
 424     (setq content-type
 425           (if content-type
 426               (mail-header-parse-content-type content-type)
 427             ;; FIXME: Default "message/rfc822" in a "multipart/digest"
 428             ;; according to RFC 2046.
 429             '("text/plain")))
 430     (setq content-disposition
 431           (if content-disposition
 432               (mail-header-parse-content-disposition content-disposition)
 433             ;; If none specified, we are free to choose what we deem
 434             ;; suitable according to RFC 2183.  We like inline.
 435             '("inline")))
 436     ;; Unrecognized disposition types are to be treated like
 437     ;; attachment according to RFC 2183.
 438     (unless (member (car content-disposition) '("inline" "attachment"))
 439       (setq content-disposition '("attachment")))
 440     ;; Hide headers and handle the part.
 441     (save-restriction
 442       (cond ((string= (car content-type) "message/rfc822")
 443              (narrow-to-region end (point-max)))
 444             ((not show-headers)
 445              (delete-region (point-min) end)))
 446       (rmail-mime-handle content-type content-disposition
 447                          content-transfer-encoding))))
 448
 449 (define-derived-mode rmail-mime-mode fundamental-mode "RMIME"
 450   "Major mode used in `rmail-mime' buffers."
 451   (setq font-lock-defaults '(rmail-font-lock-keywords t t nil nil)))
 452
 453 ;;;###autoload
 454 (defun rmail-mime ()
 455   "Process the current Rmail message as a MIME message.
 456 This creates a temporary \"*RMAIL*\" buffer holding a decoded
 457 copy of the message.  Inline content-types are handled according to
 458 `rmail-mime-media-type-handlers-alist'.  By default, this
 459 displays text and multipart messages, and offers to download
 460 attachments as specfied by `rmail-mime-attachment-dirs-alist'."
 461   (interactive)
 462   (let ((data (rmail-apply-in-message rmail-current-message 'buffer-string))
 463         (buf (get-buffer-create "*RMAIL*")))
 464     (set-buffer buf)
 465     (setq buffer-undo-list t)
 466     (let ((inhibit-read-only t))
 467       ;; Decoding the message in fundamental mode for speed, only
 468       ;; switching to rmail-mime-mode at the end for display.  Eg
 469       ;; quoted-printable-decode-region gets very slow otherwise (Bug#4993).
 470       (fundamental-mode)
 471       (erase-buffer)
 472       (insert data)
 473       (rmail-mime-show t)
 474       (rmail-mime-mode)
 475       (set-buffer-modified-p nil))
 476     (view-buffer buf)))
 477
 478 (defun rmail-mm-get-boundary-error-message (message type disposition encoding)
 479   "Return MESSAGE with more information on the main mime components."
 480   (error "%s; type: %s; disposition: %s; encoding: %s"
 481          message type disposition encoding))
 482
 483 (provide 'rmailmm)
 484
 485 ;; Local Variables:
 486 ;; generated-autoload-file: "rmail.el"
 487 ;; End:
 488
 489 ;; arch-tag: 3f2c5e5d-1aef-4512-bc20-fd737c9d5dd9
 490 ;;; rmailmm.el ends here