lisp/mail/pmailmm.el

   1 ;;; pmailmm.el --- MIME decoding and display stuff for PMAIL
   2
   3 ;; Copyright (C) 2006, 2007, 2008  Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: mail
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  23 ;; Boston, MA 02110-1301, USA.
  24
  25 ;;; Commentary:
  26
  27 ;; Essentially based on the design of Alexander Pohoyda's MIME
  28 ;; extensions (mime-display.el and mime.el).  To use, copy a complete
  29 ;; message into a new buffer and call (mime-show t).
  30
  31 ;; To use:
  32
  33 ;; (autoload 'pmail-mime "pmailmm"
  34 ;;   "Show MIME message." t)
  35 ;; (add-hook 'pmail-mode-hook
  36 ;;           (lambda ()
  37 ;;             (define-key pmail-mode-map (kbd "v")
  38 ;;               'pmail-mime)))
  39
  40 ;;; Code:
  41
  42 ;;; Variables
  43
  44 (defcustom pmail-mime-media-type-handlers-alist
  45   '(("multipart/.*" pmail-mime-multipart-handler)
  46     ("text/.*" pmail-mime-text-handler)
  47     ("text/\\(x-\\)?patch" pmail-mime-bulk-handler)
  48     ("application/pgp-signature" pmail-mime-application/pgp-signature-handler)
  49     ("\\(image\\|audio\\|video\\|application\\)/.*" pmail-mime-bulk-handler))
  50   "Alist of media type handlers, also known as agents.
  51 Every handler is a list of type (string symbol) where STRING is a
  52 regular expression to match the media type with and SYMBOL is a
  53 function to run.  Handlers should return a non-nil value if the
  54 job is done."
  55   :type 'list
  56   :group 'mime)
  57
  58 (defcustom pmail-mime-attachment-dirs-alist
  59   '(("text/.*" "~/Documents")
  60     ("image/.*" "~/Pictures")
  61     (".*" "~/Desktop" "~" "/tmp"))
  62   "Default directories to save attachments into.
  63 Each media type may have it's own list of directories in order of
  64 preference.  The first existing directory in the list will be
  65 used."
  66   :type 'list
  67   :group 'mime)
  68
  69 (defvar pmail-mime-total-number-of-bulk-attachments 0
  70   "A total number of attached bulk bodyparts in the message.  If more than 3,
  71 offer a way to save all attachments at once.")
  72 (put 'pmail-mime-total-number-of-bulk-attachments 'permanent-local t)
  73
  74 ;;; Buttons
  75
  76 (defun pmail-mime-save (button)
  77   "Save the attachment using info in the BUTTON."
  78   (let* ((filename (button-get button 'filename))
  79          (directory (button-get button 'directory))
  80          (data (button-get button 'data)))
  81     (while (file-exists-p (expand-file-name filename directory))
  82       (let* ((f (file-name-sans-extension filename))
  83              (i 1))
  84         (when (string-match "-\\([0-9]+\\)$" f)
  85           (setq i (1+ (string-to-number (match-string 1 f)))
  86                 f (substring f 0 (match-beginning 0))))
  87         (setq filename (concat f "-" (number-to-string i) "."
  88                                (file-name-extension filename)))))
  89     (setq filename (expand-file-name
  90                     (read-file-name (format "Save as (default: %s): " filename)
  91                                     directory
  92                                     (expand-file-name filename directory))
  93                     directory))
  94     (when (file-regular-p filename)
  95       (error (message "File `%s' already exists" filename)))
  96     (with-temp-file filename
  97       (set-buffer-file-coding-system 'no-conversion)
  98       (insert data))))
  99
 100 (define-button-type 'pmail-mime-save
 101   'action 'pmail-mime-save)
 102
 103 ;;; Handlers
 104
 105 (defun pmail-mime-text-handler (content-type
 106                                 content-disposition
 107                                 content-transfer-encoding)
 108   "Handle the current buffer as a plain text MIME part."
 109   (let* ((charset (cdr (assq 'charset (cdr content-type))))
 110          (coding-system (when charset
 111                           (intern (downcase charset)))))
 112     (when (coding-system-p coding-system)
 113       (decode-coding-region (point-min) (point-max) coding-system))))
 114
 115 (defun test-pmail-mime-handler ()
 116   "Test of a mail using no MIME parts at all."
 117   (let ((mail "To: alex@gnu.org
 118 Content-Type: text/plain; charset=koi8-r
 119 Content-Transfer-Encoding: 8bit
 120 MIME-Version: 1.0
 121
 122 \372\304\322\301\327\323\324\327\325\312\324\305\41"))
 123     (switch-to-buffer (get-buffer-create "*test*"))
 124     (erase-buffer)
 125     (set-buffer-multibyte nil)
 126     (insert mail)
 127     (pmail-mime-show t)
 128     (set-buffer-multibyte t)))
 129
 130 (defun pmail-mime-bulk-handler (content-type
 131                                 content-disposition
 132                                 content-transfer-encoding)
 133   "Handle the current buffer as an attachment to download."
 134   (setq pmail-mime-total-number-of-bulk-attachments
 135         (1+ pmail-mime-total-number-of-bulk-attachments))
 136   ;; Find the default directory for this media type
 137   (let* ((directory (catch 'directory
 138                       (dolist (entry pmail-mime-attachment-dirs-alist)
 139                         (when (string-match (car entry) (car content-type))
 140                           (dolist (dir (cdr entry))
 141                             (when (file-directory-p dir)
 142                               (throw 'directory dir)))))))
 143          (filename (or (cdr (assq 'name (cdr content-type)))
 144                        (cdr (assq 'filename (cdr content-disposition)))
 145                        "noname"))
 146          (label (format "\nAttached %s file: " (car content-type)))
 147          (data (buffer-string)))
 148     (delete-region (point-min) (point-max))
 149     (insert label)
 150     (insert-button filename
 151                    :type 'pmail-mime-save
 152                    'filename filename
 153                    'directory directory
 154                    'data data)))
 155
 156 (defun test-pmail-mime-bulk-handler ()
 157   "Test of a mail used as an example in RFC 2183."
 158   (let ((mail "Content-Type: image/jpeg
 159 Content-Disposition: attachment; filename=genome.jpeg;
 160   modification-date=\"Wed, 12 Feb 1997 16:29:51 -0500\";
 161 Content-Description: a complete map of the human genome
 162 Content-Transfer-Encoding: base64
 163
 164 iVBORw0KGgoAAAANSUhEUgAAADAAAAAwCAMAAABg3Am1AAAABGdBTUEAALGPC/xhBQAAAAZQ
 165 TFRF////AAAAVcLTfgAAAPZJREFUeNq9ldsOwzAIQ+3//+l1WlvA5ZLsoUiTto4TB+ISoAjy
 166 +ITfRBfcAmgRFFeAm+J6uhdKdFhFWUgDkFsK0oUp/9G2//Kj7Jx+5tSKOdBscgUYiKHRS/me
 167 WATQdRUvAK0Bnmshmtn79PpaLBbbOZkjKvRnjRZoRswOkG1wFchKew2g9wXVJVZL/m4+B+vv
 168 9AxQQR2Q33SgAYJzzVACdAWjAfRYzYFO9n6SLnydtQHSMxYDMAKqZ/8FS/lTK+zuq3CtK64L
 169 UDwbgUEAUmk2Zyg101d6PhCDySgAvTvDgKiuOrc4dLxUb7UMnhGIexyI+d6U+ABuNAP4Simx
 170 lgAAAABJRU5ErkJggg==
 171 "))
 172     (switch-to-buffer (get-buffer-create "*test*"))
 173     (erase-buffer)
 174     (insert mail)
 175     (pmail-mime-show)))
 176
 177 (defun pmail-mime-multipart-handler (content-type
 178                                      content-disposition
 179                                      content-transfer-encoding)
 180   "Handle the current buffer as a multipart MIME body.
 181 The current buffer should be narrowed to the body.  CONTENT-TYPE,
 182 CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING are the values
 183 of the respective parsed headers.  See `pmail-mime-handle' for their
 184 format."
 185   ;; Some MUAs start boundaries with "--", while it should start
 186   ;; with "CRLF--", as defined by RFC 2046:
 187   ;;    The boundary delimiter MUST occur at the beginning of a line,
 188   ;;    i.e., following a CRLF, and the initial CRLF is considered to
 189   ;;    be attached to the boundary delimiter line rather than part
 190   ;;    of the preceding part.
 191   ;; We currently don't handle that.
 192   (let ((boundary (cdr (assq 'boundary content-type)))
 193         beg next)
 194     (unless boundary
 195       (error "No boundary defined" content-type content-disposition
 196              content-transfer-encoding))
 197     (setq boundary (concat "\n--" boundary))
 198     ;; Hide the body before the first bodypart
 199     (goto-char (point-min))
 200     (when (and (search-forward boundary nil t)
 201                (looking-at "[ \t]*\n"))
 202       (delete-region (point-min) (match-end 0)))
 203     ;; Reset the counter
 204     (setq pmail-mime-total-number-of-bulk-attachments 0)
 205     ;; Loop over all body parts, where beg points at the beginning of
 206     ;; the part and end points at the end of the part.  next points at
 207     ;; the beginning of the next part.
 208     (setq beg (point-min))
 209     (while (search-forward boundary nil t)
 210       (setq end (match-beginning 0))
 211       ;; If this is the last boundary according to RFC 2046, hide the
 212       ;; epilogue, else hide the boundary only.  Use a marker for
 213       ;; `next' because `pmail-mime-show' may change the buffer.
 214       (cond ((looking-at "--[ \t]*\n")
 215              (setq next (point-max-marker)))
 216             ((looking-at "[ \t]*\n")
 217              (setq next (copy-marker (match-end 0))))
 218             (t
 219              (error "Malformed boundary" content-type
 220                     content-disposition content-transfer-encoding)))
 221       (delete-region end next)
 222       ;; Handle the part.
 223       (save-match-data
 224         (save-excursion
 225           (save-restriction
 226             (narrow-to-region beg end)
 227             (pmail-mime-show))))
 228       (setq beg next)
 229       (goto-char beg))))
 230
 231 (defun test-pmail-mime-multipart-handler ()
 232   "Test of a mail used as an example in RFC 2046."
 233   (let ((mail "From: Nathaniel Borenstein <nsb@bellcore.com>
 234 To: Ned Freed <ned@innosoft.com>
 235 Date: Sun, 21 Mar 1993 23:56:48 -0800 (PST)
 236 Subject: Sample message
 237 MIME-Version: 1.0
 238 Content-type: multipart/mixed; boundary=\"simple boundary\"
 239
 240 This is the preamble.  It is to be ignored, though it
 241 is a handy place for composition agents to include an
 242 explanatory note to non-MIME conformant readers.
 243
 244 --simple boundary
 245
 246 This is implicitly typed plain US-ASCII text.
 247 It does NOT end with a linebreak.
 248 --simple boundary
 249 Content-type: text/plain; charset=us-ascii
 250
 251 This is explicitly typed plain US-ASCII text.
 252 It DOES end with a linebreak.
 253
 254 --simple boundary--
 255
 256 This is the epilogue.  It is also to be ignored."))
 257     (switch-to-buffer (get-buffer-create "*test*"))
 258     (erase-buffer)
 259     (insert mail)
 260     (pmail-mime-show t)))
 261
 262 ;;; Main code
 263
 264 (defun pmail-mime-handle (content-type
 265                           content-disposition
 266                           content-transfer-encoding)
 267   "Handle the current buffer as a MIME part.
 268 The current buffer should be narrowed to the respective body, and
 269 point should be at the beginning of the body.
 270
 271 CONTENT-TYPE, CONTENT-DISPOSITION, and CONTENT-TRANSFER-ENCODING
 272 are the values of the respective parsed headers.  The parsed
 273 headers for CONTENT-TYPE and CONTENT-DISPOSITION have the form
 274
 275   \(VALUE . ALIST)
 276
 277 In other words:
 278
 279   \(VALUE (ATTRIBUTE . VALUE) (ATTRIBUTE . VALUE) ...)
 280
 281 VALUE is a string and ATTRIBUTE is a symbol.
 282
 283 Consider the following header, for example:
 284
 285 Content-Type: multipart/mixed;
 286         boundary=\"----=_NextPart_000_0104_01C617E4.BDEC4C40\"
 287
 288 The parsed header value:
 289
 290 \(\"multipart/mixed\"
 291   \(\"boundary\" . \"----=_NextPart_000_0104_01C617E4.BDEC4C40\"))"
 292   ;; Handle the content transfer encodings we know.  Unknown transfer
 293   ;; encodings will be passed on to the various handlers.
 294   (cond ((string= content-transfer-encoding "base64")
 295          (when (ignore-errors
 296                  (base64-decode-region (point) (point-max)))
 297            (setq content-transfer-encoding nil)))
 298         ((string= content-transfer-encoding "quoted-printable")
 299          (quoted-printable-decode-region (point) (point-max))
 300          (setq content-transfer-encoding nil))
 301         ((string= content-transfer-encoding "8bit")
 302          ;; FIXME: Is this the correct way?
 303          (set-buffer-multibyte nil)))
 304   ;; Inline stuff requires work.  Attachments are handled by the bulk
 305   ;; handler.
 306   (if (string= "inline" (car content-disposition))
 307       (let ((stop nil))
 308         (dolist (entry pmail-mime-media-type-handlers-alist)
 309           (when (and (string-match (car entry) (car content-type)) (not stop))
 310             (progn
 311               (setq stop (funcall (cadr entry) content-type
 312                                   content-disposition
 313                                   content-transfer-encoding))))))
 314     ;; Everything else is an attachment.
 315     (pmail-mime-bulk-handler content-type
 316                        content-disposition
 317                        content-transfer-encoding)))
 318
 319 (defun pmail-mime-show (&optional show-headers)
 320   "Handle the current buffer as a MIME message.
 321 If SHOW-HEADERS is non-nil, then the headers of the current part
 322 will shown as usual for a MIME message.  The headers are also
 323 shown for the content type message/rfc822.  This function will be
 324 called recursively if multiple parts are available.
 325
 326 The current buffer must contain a single message.  It will be
 327 modified."
 328   (let ((end (point-min))
 329         content-type
 330         content-transfer-encoding
 331         content-disposition)
 332     ;; `point-min' returns the beginning and `end' points at the end
 333     ;; of the headers.  We're not using `pmail-header-get-header'
 334     ;; because we must be able to handle the case of no headers
 335     ;; existing in a part.  In this case end is at point-min.
 336     (goto-char (point-min))
 337     ;; If we're showing a part without headers, then it will start
 338     ;; with a newline.
 339     (if (eq (char-after) ?\n)
 340         (setq end (1+ (point)))
 341       (when (search-forward "\n\n" nil t)
 342         (setq end (match-end 0))
 343         (save-restriction
 344           (narrow-to-region (point-min) end)
 345           ;; FIXME: Default disposition of the multipart entities should
 346           ;; be inherited.
 347           (setq content-type
 348                 (mail-fetch-field "Content-Type")
 349                 content-transfer-encoding
 350                 (mail-fetch-field "Content-Transfer-Encoding")
 351                 content-disposition
 352                 (mail-fetch-field "Content-Disposition")))))
 353     (if content-type
 354         (setq content-type (mail-header-parse-content-type
 355                             content-type))
 356       ;; FIXME: Default "message/rfc822" in a "multipart/digest"
 357       ;; according to RFC 2046.
 358       (setq content-type '("text/plain")))
 359     (setq content-disposition
 360           (if content-disposition
 361               (mail-header-parse-content-disposition content-disposition)
 362             ;; If none specified, we are free to choose what we deem
 363             ;; suitable according to RFC 2183.  We like inline.
 364             '("inline")))
 365     ;; Unrecognized disposition types are to be treated like
 366     ;; attachment according to RFC 2183.
 367     (unless (member (car content-disposition) '("inline" "attachment"))
 368       (setq content-disposition '("attachment")))
 369     ;; Hide headers and handle the part.
 370     (save-restriction
 371       (cond ((string= (car content-type) "message/rfc822")
 372              (pmail-header-hide-headers)
 373              (narrow-to-region end (point-max)))
 374             (show-headers
 375              (pmail-header-hide-headers))
 376             (t
 377              (delete-region (point-min) end)))
 378       (pmail-mime-handle content-type content-disposition
 379                          content-transfer-encoding))))
 380
 381 (defun pmail-mime ()
 382   "Copy buffer contents to a temporary buffer and handle MIME.
 383 This calls `pmail-mime-show' to do the real job."
 384   (interactive)
 385   (let ((data (with-current-buffer pmail-buffer
 386                 (save-restriction
 387                   (widen)
 388                   (buffer-substring
 389                    (pmail-desc-get-start pmail-current-message)
 390                    (pmail-desc-get-end pmail-current-message)))))
 391         (buf (get-buffer-create "*PMAIL*")))
 392     (set-buffer buf)
 393     (let ((inhibit-read-only t))
 394       (erase-buffer)
 395       (insert data)
 396       (pmail-mime-show t))
 397     (view-buffer buf)))
 398
 399 (provide 'pmailmm)
 400
 401 ;; pmailmm.el ends here