git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-decode.el

   1 ;;; mm-decode.el --- Functions for decoding MIME things
   2 ;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   6 ;; This file is part of GNU Emacs.
   7
   8 ;; GNU Emacs is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; GNU Emacs is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  20 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Code:
  26
  27 (require 'mail-parse)
  28 (require 'gnus-mailcap)
  29 (require 'mm-bodies)
  30 (eval-when-compile (require 'cl))
  31
  32 (eval-and-compile
  33   (autoload 'mm-inline-partial "mm-partial")
  34   (autoload 'mm-inline-external-body "mm-extern")
  35   (autoload 'mm-insert-inline "mm-view"))
  36
  37 (defgroup mime-display ()
  38   "Display of MIME in mail and news articles."
  39   :link '(custom-manual "(emacs-mime)Customization")
  40   :version "21.1"
  41   :group 'mail
  42   :group 'news
  43   :group 'multimedia)
  44
  45 (defgroup mime-security ()
  46   "MIME security in mail and news articles."
  47   :link '(custom-manual "(emacs-mime)Customization")
  48   :group 'mail
  49   :group 'news
  50   :group 'multimedia)
  51
  52 ;;; Convenience macros.
  53
  54 (defmacro mm-handle-buffer (handle)
  55   `(nth 0 ,handle))
  56 (defmacro mm-handle-type (handle)
  57   `(nth 1 ,handle))
  58 (defsubst mm-handle-media-type (handle)
  59   (if (stringp (car handle))
  60       (car handle)
  61     (car (mm-handle-type handle))))
  62 (defsubst mm-handle-media-supertype (handle)
  63   (car (split-string (mm-handle-media-type handle) "/")))
  64 (defsubst mm-handle-media-subtype (handle)
  65   (cadr (split-string (mm-handle-media-type handle) "/")))
  66 (defmacro mm-handle-encoding (handle)
  67   `(nth 2 ,handle))
  68 (defmacro mm-handle-undisplayer (handle)
  69   `(nth 3 ,handle))
  70 (defmacro mm-handle-set-undisplayer (handle function)
  71   `(setcar (nthcdr 3 ,handle) ,function))
  72 (defmacro mm-handle-disposition (handle)
  73   `(nth 4 ,handle))
  74 (defmacro mm-handle-description (handle)
  75   `(nth 5 ,handle))
  76 (defmacro mm-handle-cache (handle)
  77   `(nth 6 ,handle))
  78 (defmacro mm-handle-set-cache (handle contents)
  79   `(setcar (nthcdr 6 ,handle) ,contents))
  80 (defmacro mm-handle-id (handle)
  81   `(nth 7 ,handle))
  82 (defmacro mm-handle-multipart-original-buffer (handle)
  83   `(get-text-property 0 'buffer (car ,handle)))
  84 (defmacro mm-handle-multipart-from (handle)
  85   `(get-text-property 0 'from (car ,handle)))
  86 (defmacro mm-handle-multipart-ctl-parameter (handle parameter)
  87   `(get-text-property 0 ,parameter (car ,handle)))
  88
  89 (defmacro mm-make-handle (&optional buffer type encoding undisplayer
  90                                     disposition description cache
  91                                     id)
  92   `(list ,buffer ,type ,encoding ,undisplayer
  93          ,disposition ,description ,cache ,id))
  94
  95 (defcustom mm-inline-media-tests
  96   '(("image/jpeg"
  97      mm-inline-image
  98      (lambda (handle)
  99        (mm-valid-and-fit-image-p 'jpeg handle)))
 100     ("image/png"
 101      mm-inline-image
 102      (lambda (handle)
 103        (mm-valid-and-fit-image-p 'png handle)))
 104     ("image/gif"
 105      mm-inline-image
 106      (lambda (handle)
 107        (mm-valid-and-fit-image-p 'gif handle)))
 108     ("image/tiff"
 109      mm-inline-image
 110      (lambda (handle)
 111        (mm-valid-and-fit-image-p 'tiff handle)) )
 112     ("image/xbm"
 113      mm-inline-image
 114      (lambda (handle)
 115        (mm-valid-and-fit-image-p 'xbm handle)))
 116     ("image/x-xbitmap"
 117      mm-inline-image
 118      (lambda (handle)
 119        (mm-valid-and-fit-image-p 'xbm handle)))
 120     ("image/xpm"
 121      mm-inline-image
 122      (lambda (handle)
 123        (mm-valid-and-fit-image-p 'xpm handle)))
 124     ("image/x-pixmap"
 125      mm-inline-image
 126      (lambda (handle)
 127        (mm-valid-and-fit-image-p 'xpm handle)))
 128     ("image/bmp"
 129      mm-inline-image
 130      (lambda (handle)
 131        (mm-valid-and-fit-image-p 'bmp handle)))
 132     ("image/x-portable-bitmap"
 133      mm-inline-image
 134      (lambda (handle)
 135        (mm-valid-and-fit-image-p 'pbm handle)))
 136     ("text/plain" mm-inline-text identity)
 137     ("text/enriched" mm-inline-text identity)
 138     ("text/richtext" mm-inline-text identity)
 139     ("text/x-patch" mm-display-patch-inline
 140      (lambda (handle)
 141        (locate-library "diff-mode")))
 142     ("application/emacs-lisp" mm-display-elisp-inline identity)
 143     ("text/html"
 144      mm-inline-text
 145      (lambda (handle)
 146        (locate-library "w3")))
 147     ("text/x-vcard"
 148      mm-inline-text
 149      (lambda (handle)
 150        (or (featurep 'vcard)
 151            (locate-library "vcard"))))
 152     ("message/delivery-status" mm-inline-text identity)
 153     ("message/rfc822" mm-inline-message identity)
 154     ("message/partial" mm-inline-partial identity)
 155     ("message/external-body" mm-inline-external-body identity)
 156     ("text/.*" mm-inline-text identity)
 157     ("audio/wav" mm-inline-audio
 158      (lambda (handle)
 159        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 160             (device-sound-enabled-p))))
 161     ("audio/au"
 162      mm-inline-audio
 163      (lambda (handle)
 164        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 165             (device-sound-enabled-p))))
 166     ("application/pgp-signature" ignore identity)
 167     ("application/x-pkcs7-signature" ignore identity)
 168     ("application/pkcs7-signature" ignore identity)
 169     ("multipart/alternative" ignore identity)
 170     ("multipart/mixed" ignore identity)
 171     ("multipart/related" ignore identity))
 172   "Alist of media types/tests saying whether types can be displayed inline."
 173   :type '(repeat (list (string :tag "MIME type")
 174                        (function :tag "Display function")
 175                        (function :tag "Display test")))
 176   :group 'mime-display)
 177
 178 (defcustom mm-inlined-types
 179   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
 180     "message/partial" "message/external-body" "application/emacs-lisp"
 181     "application/pgp-signature" "application/x-pkcs7-signature"
 182     "application/pkcs7-signature")
 183   "List of media types that are to be displayed inline."
 184   :type '(repeat string)
 185   :group 'mime-display)
 186
 187 (defcustom mm-automatic-display
 188   '("text/plain" "text/enriched" "text/richtext" "text/html"
 189     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
 190     "message/rfc822" "text/x-patch" "application/pgp-signature"
 191     "application/emacs-lisp" "application/x-pkcs7-signature"
 192     "application/pkcs7-signature")
 193   "A list of MIME types to be displayed automatically."
 194   :type '(repeat string)
 195   :group 'mime-display)
 196
 197 (defcustom mm-attachment-override-types '("text/x-vcard")
 198   "Types to have \"attachment\" ignored if they can be displayed inline."
 199   :type '(repeat string)
 200   :group 'mime-display)
 201
 202 (defcustom mm-inline-override-types nil
 203   "Types to be treated as attachments even if they can be displayed inline."
 204   :type '(repeat string)
 205   :group 'mime-display)
 206
 207 (defcustom mm-automatic-external-display nil
 208   "List of MIME type regexps that will be displayed externally automatically."
 209   :type '(repeat string)
 210   :group 'mime-display)
 211
 212 (defcustom mm-discouraged-alternatives nil
 213   "List of MIME types that are discouraged when viewing multipart/alternative.
 214 Viewing agents are supposed to view the last possible part of a message,
 215 as that is supposed to be the richest.  However, users may prefer other
 216 types instead, and this list says what types are most unwanted.  If,
 217 for instance, text/html parts are very unwanted, and text/richtext are
 218 somewhat unwanted, then the value of this variable should be set
 219 to:
 220
 221  (\"text/html\" \"text/richtext\")"
 222   :type '(repeat string)
 223   :group 'mime-display)
 224
 225 (defvar mm-tmp-directory
 226   (cond ((fboundp 'temp-directory) (temp-directory))
 227         ((boundp 'temporary-file-directory) temporary-file-directory)
 228         ("/tmp/"))
 229   "Where mm will store its temporary files.")
 230
 231 (defcustom mm-inline-large-images nil
 232   "If non-nil, then all images fit in the buffer."
 233   :type 'boolean
 234   :group 'mime-display)
 235
 236 ;;; Internal variables.
 237
 238 (defvar mm-dissection-list nil)
 239 (defvar mm-last-shell-command "")
 240 (defvar mm-content-id-alist nil)
 241
 242 ;; According to RFC2046, in particular, in a digest, the default
 243 ;; Content-Type value for a body part is changed from "text/plain" to
 244 ;; "message/rfc822".
 245 (defvar mm-dissect-default-type "text/plain")
 246
 247 (autoload 'mml2015-verify "mml2015")
 248 (autoload 'mml2015-verify-test "mml2015")
 249 (autoload 'mml-smime-verify "mml-smime")
 250 (autoload 'mml-smime-verify-test "mml-smime")
 251
 252 (defvar mm-verify-function-alist
 253   '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
 254     ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
 255      mm-uu-pgp-signed-test)
 256     ("application/pkcs7-signature" mml-smime-verify "S/MIME"
 257      mml-smime-verify-test)
 258     ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
 259      mml-smime-verify-test)))
 260
 261 (defcustom mm-verify-option 'never
 262   "Option of verifying signed parts.
 263 `never', not verify; `always', always verify;
 264 `known', only verify known protocols. Otherwise, ask user."
 265   :type '(choice (item always)
 266                  (item never)
 267                  (item :tag "only known protocols" known)
 268                  (item :tag "ask" nil))
 269   :group 'mime-security)
 270
 271 (autoload 'mml2015-decrypt "mml2015")
 272 (autoload 'mml2015-decrypt-test "mml2015")
 273
 274 (defvar mm-decrypt-function-alist
 275   '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
 276     ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
 277      mm-uu-pgp-encrypted-test)))
 278
 279 (defcustom mm-decrypt-option nil
 280   "Option of decrypting encrypted parts.
 281 `never', not decrypt; `always', always decrypt;
 282 `known', only decrypt known protocols. Otherwise, ask user."
 283   :type '(choice (item always)
 284                  (item never)
 285                  (item :tag "only known protocols" known)
 286                  (item :tag "ask" nil))
 287   :group 'mime-security)
 288
 289 (defvar mm-viewer-completion-map
 290   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 291     (set-keymap-parent map minibuffer-local-completion-map)
 292     map)
 293   "Keymap for input viewer with completion.")
 294
 295 ;; Should we bind other key to minibuffer-complete-word?
 296 (define-key mm-viewer-completion-map " " 'self-insert-command)
 297
 298 (defvar mm-viewer-completion-map
 299   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 300     (set-keymap-parent map minibuffer-local-completion-map)
 301     map)
 302   "Keymap for input viewer with completion.")
 303
 304 ;; Should we bind other key to minibuffer-complete-word?
 305 (define-key mm-viewer-completion-map " " 'self-insert-command)
 306
 307 ;;; The functions.
 308
 309 (defun mm-alist-to-plist (alist)
 310   "Convert association list ALIST into the equivalent property-list form.
 311 The plist is returned.  This converts from
 312
 313 \((a . 1) (b . 2) (c . 3))
 314
 315 into
 316
 317 \(a 1 b 2 c 3)
 318
 319 The original alist is not modified.  See also `destructive-alist-to-plist'."
 320   (let (plist)
 321     (while alist
 322       (let ((el (car alist)))
 323         (setq plist (cons (cdr el) (cons (car el) plist))))
 324       (setq alist (cdr alist)))
 325     (nreverse plist)))
 326
 327 (defun mm-dissect-buffer (&optional no-strict-mime)
 328   "Dissect the current buffer and return a list of MIME handles."
 329   (save-excursion
 330     (let (ct ctl type subtype cte cd description id result from)
 331       (save-restriction
 332         (mail-narrow-to-head)
 333         (when (or no-strict-mime
 334                   (mail-fetch-field "mime-version"))
 335           (setq ct (mail-fetch-field "content-type")
 336                 ctl (ignore-errors (mail-header-parse-content-type ct))
 337                 cte (mail-fetch-field "content-transfer-encoding")
 338                 cd (mail-fetch-field "content-disposition")
 339                 description (mail-fetch-field "content-description")
 340                 from (mail-fetch-field "from")
 341                 id (mail-fetch-field "content-id"))
 342           ;; FIXME: In some circumstances, this code is running within
 343           ;; an unibyte macro.  mail-extract-address-components
 344           ;; creates unibyte buffers. This `if', though not a perfect
 345           ;; solution, avoids most of them.
 346           (if from
 347               (setq from (cadr (mail-extract-address-components from))))))
 348       (when cte
 349         (setq cte (mail-header-strip cte)))
 350       (if (or (not ctl)
 351               (not (string-match "/" (car ctl))))
 352           (mm-dissect-singlepart
 353            (list mm-dissect-default-type)
 354            (and cte (intern (downcase (mail-header-remove-whitespace
 355                                        (mail-header-remove-comments
 356                                         cte)))))
 357            no-strict-mime
 358            (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
 359            description)
 360         (setq type (split-string (car ctl) "/"))
 361         (setq subtype (cadr type)
 362               type (pop type))
 363         (setq
 364          result
 365          (cond
 366           ((equal type "multipart")
 367            (let ((mm-dissect-default-type (if (equal subtype "digest")
 368                                               "message/rfc822"
 369                                             "text/plain")))
 370              (add-text-properties 0 (length (car ctl))
 371                                   (mm-alist-to-plist (cdr ctl)) (car ctl))
 372
 373              ;; what really needs to be done here is a way to link a
 374              ;; MIME handle back to it's parent MIME handle (in a multilevel
 375              ;; MIME article).  That would probably require changing
 376              ;; the mm-handle API so we simply store the multipart buffert
 377              ;; name as a text property of the "multipart/whatever" string.
 378              (add-text-properties 0 (length (car ctl))
 379                                   (list 'buffer (mm-copy-to-buffer))
 380                                   (car ctl))
 381              (add-text-properties 0 (length (car ctl))
 382                                   (list 'from from)
 383                                   (car ctl))
 384              (cons (car ctl) (mm-dissect-multipart ctl))))
 385           (t
 386            (mm-dissect-singlepart
 387             ctl
 388             (and cte (intern (downcase (mail-header-remove-whitespace
 389                                         (mail-header-remove-comments
 390                                          cte)))))
 391             no-strict-mime
 392             (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
 393             description id))))
 394         (when id
 395           (when (string-match " *<\\(.*\\)> *" id)
 396             (setq id (match-string 1 id)))
 397           (push (cons id result) mm-content-id-alist))
 398         result))))
 399
 400 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 401   (when (or force
 402             (if (equal "text/plain" (car ctl))
 403                 (assoc 'format ctl)
 404               t))
 405     (let ((res (mm-make-handle
 406                 (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 407       (push (car res) mm-dissection-list)
 408       res)))
 409
 410 (defun mm-remove-all-parts ()
 411   "Remove all MIME handles."
 412   (interactive)
 413   (mapcar 'mm-remove-part mm-dissection-list)
 414   (setq mm-dissection-list nil))
 415
 416 (defun mm-dissect-multipart (ctl)
 417   (goto-char (point-min))
 418   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 419          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 420          start parts
 421          (end (save-excursion
 422                 (goto-char (point-max))
 423                 (if (re-search-backward close-delimiter nil t)
 424                     (match-beginning 0)
 425                   (point-max)))))
 426     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
 427     (while (and (< (point) end) (re-search-forward boundary end t))
 428       (goto-char (match-beginning 0))
 429       (when start
 430         (save-excursion
 431           (save-restriction
 432             (narrow-to-region start (point))
 433             (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
 434       (forward-line 2)
 435       (setq start (point)))
 436     (when (and start (< start end))
 437       (save-excursion
 438         (save-restriction
 439           (narrow-to-region start end)
 440           (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
 441     (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
 442
 443 (defun mm-copy-to-buffer ()
 444   "Copy the contents of the current buffer to a fresh buffer."
 445   (save-excursion
 446     (let ((flag enable-multibyte-characters)
 447           (new-buffer (generate-new-buffer " *mm*")))
 448       (goto-char (point-min))
 449       (search-forward-regexp "^\n" nil t)
 450       (save-restriction
 451         (narrow-to-region (point) (point-max))
 452         (when flag
 453           (set-buffer-multibyte nil))
 454         (copy-to-buffer new-buffer (point-min) (point-max))
 455         (when flag
 456           (set-buffer-multibyte t)))
 457       new-buffer)))
 458
 459 (defun mm-display-parts (handle &optional no-default)
 460   (if (stringp (car handle))
 461       (mapcar 'mm-display-parts (cdr handle))
 462     (if (bufferp (car handle))
 463         (save-restriction
 464           (narrow-to-region (point) (point))
 465           (mm-display-part handle)
 466           (goto-char (point-max)))
 467       (mapcar 'mm-display-parts handle))))
 468
 469 (defun mm-display-part (handle &optional no-default)
 470   "Display the MIME part represented by HANDLE.
 471 Returns nil if the part is removed; inline if displayed inline;
 472 external if displayed external."
 473   (save-excursion
 474     (mailcap-parse-mailcaps)
 475     (if (mm-handle-displayed-p handle)
 476         (mm-remove-part handle)
 477       (let* ((type (mm-handle-media-type handle))
 478              (method (mailcap-mime-info type)))
 479         (if (mm-inlined-p handle)
 480             (progn
 481               (forward-line 1)
 482               (mm-display-inline handle)
 483               'inline)
 484           (when (or method
 485                     (not no-default))
 486             (if (and (not method)
 487                      (equal "text" (car (split-string type))))
 488                 (progn
 489                   (forward-line 1)
 490                   (mm-insert-inline handle (mm-get-part handle))
 491                   'inline)
 492               (mm-display-external
 493                handle (or method 'mailcap-save-binary-file)))))))))
 494
 495 (defun mm-display-external (handle method)
 496   "Display HANDLE using METHOD."
 497   (let ((outbuf (current-buffer)))
 498     (mm-with-unibyte-buffer
 499       (if (functionp method)
 500           (let ((cur (current-buffer)))
 501             (if (eq method 'mailcap-save-binary-file)
 502                 (progn
 503                   (set-buffer (generate-new-buffer " *mm*"))
 504                   (setq method nil))
 505               (mm-insert-part handle)
 506               (let ((win (get-buffer-window cur t)))
 507                 (when win
 508                   (select-window win)))
 509               (switch-to-buffer (generate-new-buffer " *mm*")))
 510             (buffer-disable-undo)
 511             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 512             (insert-buffer-substring cur)
 513             (goto-char (point-min))
 514             (message "Viewing with %s" method)
 515             (let ((mm (current-buffer))
 516                   (non-viewer (assq 'non-viewer
 517                                     (mailcap-mime-info
 518                                      (mm-handle-media-type handle) t))))
 519               (unwind-protect
 520                   (if method
 521                       (funcall method)
 522                     (mm-save-part handle))
 523                 (when (and (not non-viewer)
 524                            method)
 525                   (mm-handle-set-undisplayer handle mm)))))
 526         ;; The function is a string to be executed.
 527         (mm-insert-part handle)
 528         (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 529                (filename (mail-content-type-get
 530                           (mm-handle-disposition handle) 'filename))
 531                (mime-info (mailcap-mime-info
 532                            (mm-handle-media-type handle) t))
 533                (needsterm (or (assoc "needsterm" mime-info)
 534                               (assoc "needsterminal" mime-info)))
 535                (copiousoutput (assoc "copiousoutput" mime-info))
 536                file buffer)
 537           ;; We create a private sub-directory where we store our files.
 538           (make-directory dir)
 539           (set-file-modes dir 448)
 540           (if filename
 541               (setq file (expand-file-name (file-name-nondirectory filename)
 542                                            dir))
 543             (setq file (make-temp-name (expand-file-name "mm." dir))))
 544           (let ((coding-system-for-write mm-binary-coding-system))
 545             (write-region (point-min) (point-max) file nil 'nomesg))
 546           (message "Viewing with %s" method)
 547           (cond (needsterm
 548                  (unwind-protect
 549                      (start-process "*display*" nil
 550                                     "xterm"
 551                                     "-e" shell-file-name
 552                                     shell-command-switch
 553                                     (mm-mailcap-command
 554                                      method file (mm-handle-type handle)))
 555                    (mm-handle-set-undisplayer handle (cons file buffer)))
 556                  (message "Displaying %s..." (format method file))
 557                  'external)
 558                 (copiousoutput
 559                  (with-current-buffer outbuf
 560                    (forward-line 1)
 561                    (mm-insert-inline
 562                     handle
 563                     (unwind-protect
 564                         (progn
 565                           (call-process shell-file-name nil
 566                                         (setq buffer
 567                                               (generate-new-buffer " *mm*"))
 568                                         nil
 569                                         shell-command-switch
 570                                         (mm-mailcap-command
 571                                          method file (mm-handle-type handle)))
 572                           (if (buffer-live-p buffer)
 573                               (save-excursion
 574                                 (set-buffer buffer)
 575                                 (buffer-string))))
 576                       (progn
 577                         (ignore-errors (delete-file file))
 578                         (ignore-errors (delete-directory
 579                                         (file-name-directory file)))
 580                         (ignore-errors (kill-buffer buffer))))))
 581                  'inline)
 582                 (t
 583                  (unwind-protect
 584                      (start-process "*display*"
 585                                     (setq buffer
 586                                           (generate-new-buffer " *mm*"))
 587                                     shell-file-name
 588                                     shell-command-switch
 589                                     (mm-mailcap-command
 590                                      method file (mm-handle-type handle)))
 591                    (mm-handle-set-undisplayer handle (cons file buffer)))
 592                  (message "Displaying %s..." (format method file))
 593                  'external)))))))
 594
 595 (defun mm-mailcap-command (method file type-list)
 596   (let ((ctl (cdr type-list))
 597         (beg 0)
 598         (uses-stdin t)
 599         out sub total)
 600     (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg)
 601       (push (substring method beg (match-beginning 0)) out)
 602       (setq beg (match-end 0)
 603             total (match-string 0 method)
 604             sub (match-string 1 method))
 605       (cond
 606        ((string= total "%%")
 607         (push "%" out))
 608        ((string= total "%s")
 609         (setq uses-stdin nil)
 610         (push (mm-quote-arg file) out))
 611        ((string= total "%t")
 612         (push (mm-quote-arg (car type-list)) out))
 613        (t
 614         (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
 615     (push (substring method beg (length method)) out)
 616     (if uses-stdin
 617         (progn
 618           (push "<" out)
 619           (push (mm-quote-arg file) out)))
 620     (mapconcat 'identity (nreverse out) "")))
 621
 622 (defun mm-remove-parts (handles)
 623   "Remove the displayed MIME parts represented by HANDLES."
 624   (if (and (listp handles)
 625            (bufferp (car handles)))
 626       (mm-remove-part handles)
 627     (let (handle)
 628       (while (setq handle (pop handles))
 629         (cond
 630          ((stringp handle)
 631           (when (buffer-live-p (get-text-property 0 'buffer handle))
 632             (kill-buffer (get-text-property 0 'buffer handle))))
 633          ((and (listp handle)
 634                (stringp (car handle)))
 635           (mm-remove-parts (cdr handle)))
 636          (t
 637           (mm-remove-part handle)))))))
 638
 639 (defun mm-destroy-parts (handles)
 640   "Remove the displayed MIME parts represented by HANDLES."
 641   (if (and (listp handles)
 642            (bufferp (car handles)))
 643       (mm-destroy-part handles)
 644     (let (handle)
 645       (while (setq handle (pop handles))
 646         (cond
 647          ((stringp handle)
 648           (when (buffer-live-p (get-text-property 0 'buffer handle))
 649             (kill-buffer (get-text-property 0 'buffer handle))))
 650          ((and (listp handle)
 651                (stringp (car handle)))
 652           (mm-destroy-parts handle))
 653          (t
 654           (mm-destroy-part handle)))))))
 655
 656 (defun mm-remove-part (handle)
 657   "Remove the displayed MIME part represented by HANDLE."
 658   (when (listp handle)
 659     (let ((object (mm-handle-undisplayer handle)))
 660       (ignore-errors
 661         (cond
 662          ;; Internally displayed part.
 663          ((mm-annotationp object)
 664           (delete-annotation object))
 665          ((or (functionp object)
 666               (and (listp object)
 667                    (eq (car object) 'lambda)))
 668           (funcall object))
 669          ;; Externally displayed part.
 670          ((consp object)
 671           (ignore-errors (delete-file (car object)))
 672           (ignore-errors (delete-directory (file-name-directory (car object))))
 673           (ignore-errors (kill-buffer (cdr object))))
 674          ((bufferp object)
 675           (when (buffer-live-p object)
 676             (kill-buffer object)))))
 677       (mm-handle-set-undisplayer handle nil))))
 678
 679 (defun mm-display-inline (handle)
 680   (let* ((type (mm-handle-media-type handle))
 681          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 682     (funcall function handle)
 683     (goto-char (point-min))))
 684
 685 (defun mm-assoc-string-match (alist type)
 686   (dolist (elem alist)
 687     (when (string-match (car elem) type)
 688       (return elem))))
 689
 690 (defun mm-inlinable-p (handle)
 691   "Say whether HANDLE can be displayed inline."
 692   (let ((alist mm-inline-media-tests)
 693         (type (mm-handle-media-type handle))
 694         test)
 695     (while alist
 696       (when (string-match (caar alist) type)
 697         (setq test (caddar alist)
 698               alist nil)
 699         (setq test (funcall test handle)))
 700       (pop alist))
 701     test))
 702
 703 (defun mm-automatic-display-p (handle)
 704   "Say whether the user wants HANDLE to be displayed automatically."
 705   (let ((methods mm-automatic-display)
 706         (type (mm-handle-media-type handle))
 707         method result)
 708     (while (setq method (pop methods))
 709       (when (and (not (mm-inline-override-p handle))
 710                  (string-match method type)
 711                  (mm-inlinable-p handle))
 712         (setq result t
 713               methods nil)))
 714     result))
 715
 716 (defun mm-inlined-p (handle)
 717   "Say whether the user wants HANDLE to be displayed automatically."
 718   (let ((methods mm-inlined-types)
 719         (type (mm-handle-media-type handle))
 720         method result)
 721     (while (setq method (pop methods))
 722       (when (and (not (mm-inline-override-p handle))
 723                  (string-match method type)
 724                  (mm-inlinable-p handle))
 725         (setq result t
 726               methods nil)))
 727     result))
 728
 729 (defun mm-attachment-override-p (handle)
 730   "Say whether HANDLE should have attachment behavior overridden."
 731   (let ((types mm-attachment-override-types)
 732         (type (mm-handle-media-type handle))
 733         ty)
 734     (catch 'found
 735       (while (setq ty (pop types))
 736         (when (and (string-match ty type)
 737                    (mm-inlinable-p handle))
 738           (throw 'found t))))))
 739
 740 (defun mm-inline-override-p (handle)
 741   "Say whether HANDLE should have inline behavior overridden."
 742   (let ((types mm-inline-override-types)
 743         (type (mm-handle-media-type handle))
 744         ty)
 745     (catch 'found
 746       (while (setq ty (pop types))
 747         (when (string-match ty type)
 748           (throw 'found t))))))
 749
 750 (defun mm-automatic-external-display-p (type)
 751   "Return the user-defined method for TYPE."
 752   (let ((methods mm-automatic-external-display)
 753         method result)
 754     (while (setq method (pop methods))
 755       (when (string-match method type)
 756         (setq result t
 757               methods nil)))
 758     result))
 759
 760 (defun mm-destroy-part (handle)
 761   "Destroy the data structures connected to HANDLE."
 762   (when (listp handle)
 763     (mm-remove-part handle)
 764     (when (buffer-live-p (mm-handle-buffer handle))
 765       (kill-buffer (mm-handle-buffer handle)))))
 766
 767 (defun mm-handle-displayed-p (handle)
 768   "Say whether HANDLE is displayed or not."
 769   (mm-handle-undisplayer handle))
 770
 771 ;;;
 772 ;;; Functions for outputting parts
 773 ;;;
 774
 775 (defun mm-get-part (handle)
 776   "Return the contents of HANDLE as a string."
 777   (mm-with-unibyte-buffer
 778     (insert (with-current-buffer (mm-handle-buffer handle)
 779               (mm-with-unibyte-current-buffer-mule4
 780                 (buffer-string))))
 781     (mm-decode-content-transfer-encoding
 782      (mm-handle-encoding handle)
 783      (mm-handle-media-type handle))
 784     (buffer-string)))
 785
 786 (defun mm-insert-part (handle)
 787   "Insert the contents of HANDLE in the current buffer."
 788   (let ((cur (current-buffer)))
 789     (save-excursion
 790       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 791           (with-temp-buffer
 792             (insert-buffer-substring (mm-handle-buffer handle))
 793             (mm-decode-content-transfer-encoding
 794              (mm-handle-encoding handle)
 795              (mm-handle-media-type handle))
 796             (let ((temp (current-buffer)))
 797               (set-buffer cur)
 798               (insert-buffer-substring temp)))
 799         (mm-with-unibyte-buffer
 800           (insert-buffer-substring (mm-handle-buffer handle))
 801           (mm-decode-content-transfer-encoding
 802            (mm-handle-encoding handle)
 803            (mm-handle-media-type handle))
 804           (let ((temp (current-buffer)))
 805             (set-buffer cur)
 806             (insert-buffer-substring temp)))))))
 807
 808 (defvar mm-default-directory nil)
 809
 810 (defun mm-save-part (handle)
 811   "Write HANDLE to a file."
 812   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 813          (filename (mail-content-type-get
 814                     (mm-handle-disposition handle) 'filename))
 815          file)
 816     (when filename
 817       (setq filename (file-name-nondirectory filename)))
 818     (setq file
 819           (read-file-name "Save MIME part to: "
 820                           (expand-file-name
 821                            (or filename name "")
 822                            (or mm-default-directory default-directory))))
 823     (setq mm-default-directory (file-name-directory file))
 824     (and (or (not (file-exists-p file))
 825              (yes-or-no-p (format "File %s already exists; overwrite? "
 826                                   file)))
 827          (progn
 828            (mm-save-part-to-file handle file)
 829            file))))
 830
 831 (defun mm-save-part-to-file (handle file)
 832   (mm-with-unibyte-buffer
 833     (mm-insert-part handle)
 834     (let ((coding-system-for-write 'binary)
 835           ;; Don't re-compress .gz & al.  Arguably we should make
 836           ;; `file-name-handler-alist' nil, but that would chop
 837           ;; ange-ftp, which is reasonable to use here.
 838           (inhibit-file-name-operation 'write-region)
 839           (inhibit-file-name-handlers
 840            (cons 'jka-compr-handler inhibit-file-name-handlers)))
 841       (write-region (point-min) (point-max) file))))
 842
 843 (defun mm-pipe-part (handle)
 844   "Pipe HANDLE to a process."
 845   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 846          (command
 847           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 848     (mm-with-unibyte-buffer
 849       (mm-insert-part handle)
 850       (shell-command-on-region (point-min) (point-max) command nil))))
 851
 852 (defun mm-interactively-view-part (handle)
 853   "Display HANDLE using METHOD."
 854   (let* ((type (mm-handle-media-type handle))
 855          (methods
 856           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 857                   (mailcap-mime-info type 'all)))
 858          (method (let ((minibuffer-local-completion-map
 859                         mm-viewer-completion-map))
 860                    (completing-read "Viewer: " methods))))
 861     (when (string= method "")
 862       (error "No method given"))
 863     (if (string-match "^[^% \t]+$" method)
 864         (setq method (concat method " %s")))
 865     (mm-display-external handle method)))
 866
 867 (defun mm-preferred-alternative (handles &optional preferred)
 868   "Say which of HANDLES are preferred."
 869   (let ((prec (if preferred (list preferred)
 870                 (mm-preferred-alternative-precedence handles)))
 871         p h result type handle)
 872     (while (setq p (pop prec))
 873       (setq h handles)
 874       (while h
 875         (setq handle (car h))
 876         (setq type (mm-handle-media-type handle))
 877         (when (and (equal p type)
 878                    (mm-automatic-display-p handle)
 879                    (or (stringp (car handle))
 880                        (not (mm-handle-disposition handle))
 881                        (equal (car (mm-handle-disposition handle))
 882                               "inline")))
 883           (setq result handle
 884                 h nil
 885                 prec nil))
 886         (pop h)))
 887     result))
 888
 889 (defun mm-preferred-alternative-precedence (handles)
 890   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
 891   (let ((seq (nreverse (mapcar #'mm-handle-media-type
 892                                handles))))
 893     (dolist (disc (reverse mm-discouraged-alternatives))
 894       (dolist (elem (copy-sequence seq))
 895         (when (string-match disc elem)
 896           (setq seq (nconc (delete elem seq) (list elem))))))
 897     seq))
 898
 899 (defun mm-get-content-id (id)
 900   "Return the handle(s) referred to by ID."
 901   (cdr (assoc id mm-content-id-alist)))
 902
 903 (defun mm-get-image (handle)
 904   "Return an image instance based on HANDLE."
 905   (let ((type (mm-handle-media-subtype handle))
 906         spec)
 907     ;; Allow some common translations.
 908     (setq type
 909           (cond
 910            ((equal type "x-pixmap")
 911             "xpm")
 912            ((equal type "x-xbitmap")
 913             "xbm")
 914            ((equal type "x-portable-bitmap")
 915             "pbm")
 916            (t type)))
 917     (or (mm-handle-cache handle)
 918         (mm-with-unibyte-buffer
 919           (mm-insert-part handle)
 920           (prog1
 921               (setq spec
 922                     (ignore-errors
 923                      ;; Avoid testing `make-glyph' since W3 may define
 924                      ;; a bogus version of it.
 925                       (if (fboundp 'create-image)
 926                           (create-image (buffer-string) (intern type) 'data-p)
 927                         (cond
 928                          ((equal type "xbm")
 929                           ;; xbm images require special handling, since
 930                           ;; the only way to create glyphs from these
 931                           ;; (without a ton of work) is to write them
 932                           ;; out to a file, and then create a file
 933                           ;; specifier.
 934                           (let ((file (make-temp-name
 935                                        (expand-file-name "emm.xbm"
 936                                                          mm-tmp-directory))))
 937                             (unwind-protect
 938                                 (progn
 939                                   (write-region (point-min) (point-max) file)
 940                                   (make-glyph (list (cons 'x file))))
 941                               (ignore-errors
 942                                (delete-file file)))))
 943                          (t
 944                           (make-glyph
 945                            (vector (intern type) :data (buffer-string))))))))
 946             (mm-handle-set-cache handle spec))))))
 947
 948 (defun mm-image-fit-p (handle)
 949   "Say whether the image in HANDLE will fit the current window."
 950   (let ((image (mm-get-image handle)))
 951     (if (fboundp 'glyph-width)
 952         ;; XEmacs' glyphs can actually tell us about their width, so
 953         ;; lets be nice and smart about them.
 954         (or mm-inline-large-images
 955             (and (< (glyph-width image) (window-pixel-width))
 956                  (< (glyph-height image) (window-pixel-height))))
 957       (let* ((size (image-size image))
 958              (w (car size))
 959              (h (cdr size)))
 960         (or mm-inline-large-images
 961             (and (< h (1- (window-height))) ; Don't include mode line.
 962                  (< w (window-width))))))))
 963
 964 (defun mm-valid-image-format-p (format)
 965   "Say whether FORMAT can be displayed natively by Emacs."
 966   (cond
 967    ;; Handle XEmacs
 968    ((fboundp 'valid-image-instantiator-format-p)
 969     (valid-image-instantiator-format-p format))
 970    ;; Handle Emacs 21
 971    ((fboundp 'image-type-available-p)
 972     (and (display-graphic-p)
 973          (image-type-available-p format)))
 974    ;; Nobody else can do images yet.
 975    (t
 976     nil)))
 977
 978 (defun mm-valid-and-fit-image-p (format handle)
 979   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
 980   (and (mm-valid-image-format-p format)
 981        (mm-image-fit-p handle)))
 982
 983 (defun mm-find-part-by-type (handles type &optional notp recursive)
 984   "Search in HANDLES for part with TYPE.
 985 If NOTP, returns first non-matching part.
 986 If RECURSIVE, search recursively."
 987   (let (handle)
 988     (while handles
 989       (if (and recursive (stringp (caar handles)))
 990           (if (setq handle (mm-find-part-by-type (cdar handles) type
 991                                                  notp recursive))
 992               (setq handles nil))
 993         (if (if notp
 994                 (not (equal (mm-handle-media-type (car handles)) type))
 995               (equal (mm-handle-media-type (car handles)) type))
 996             (setq handle (car handles)
 997                   handles nil)))
 998       (setq handles (cdr handles)))
 999     handle))
1000
1001 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1002   (goto-char (point-min))
1003   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1004                                                                    'boundary)))
1005          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1006          start
1007          (end (save-excursion
1008                 (goto-char (point-max))
1009                 (if (re-search-backward close-delimiter nil t)
1010                     (match-beginning 0)
1011                   (point-max))))
1012          result)
1013     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1014     (while (and (not result)
1015                 (re-search-forward boundary end t))
1016       (goto-char (match-beginning 0))
1017       (when start
1018         (save-excursion
1019           (save-restriction
1020             (narrow-to-region start (1- (point)))
1021             (when (let ((ctl (ignore-errors
1022                                (mail-header-parse-content-type
1023                                 (mail-fetch-field "content-type")))))
1024                     (if notp
1025                         (not (equal (car ctl) type))
1026                       (equal (car ctl) type)))
1027               (setq result (buffer-substring (point-min) (point-max)))))))
1028       (forward-line 1)
1029       (setq start (point)))
1030     (when (and (not result) start)
1031       (save-excursion
1032         (save-restriction
1033           (narrow-to-region start end)
1034           (when (let ((ctl (ignore-errors
1035                              (mail-header-parse-content-type
1036                               (mail-fetch-field "content-type")))))
1037                   (if notp
1038                       (not (equal (car ctl) type))
1039                     (equal (car ctl) type)))
1040             (setq result (buffer-substring (point-min) (point-max)))))))
1041     result))
1042
1043 (defvar mm-security-handle nil)
1044
1045 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1046   ;; HANDLE could be a CTL.
1047   (if handle
1048       (put-text-property 0 (length (car handle)) parameter value
1049                          (car handle))))
1050
1051 (defun mm-possibly-verify-or-decrypt (parts ctl)
1052   (let ((subtype (cadr (split-string (car ctl) "/")))
1053         (mm-security-handle ctl) ;; (car CTL) is the type.
1054         protocol func functest)
1055     (cond
1056      ((equal subtype "signed")
1057       (unless (and (setq protocol
1058                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1059                    (not (equal protocol "multipart/mixed")))
1060         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1061         (let ((protocols mm-verify-function-alist))
1062           (while protocols
1063             (if (and (or (not (setq functest (nth 3 (car protocols))))
1064                          (funcall functest parts ctl))
1065                      (mm-find-part-by-type parts (caar protocols) nil t))
1066                 (setq protocol (caar protocols)
1067                       protocols nil)
1068               (setq protocols (cdr protocols))))))
1069       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1070       (if (cond
1071            ((eq mm-verify-option 'never) nil)
1072            ((eq mm-verify-option 'always) t)
1073            ((eq mm-verify-option 'known)
1074             (and func
1075                  (or (not (setq functest
1076                                 (nth 3 (assoc protocol
1077                                               mm-verify-function-alist))))
1078                      (funcall functest parts ctl))))
1079            (t (y-or-n-p
1080                (format "Verify signed (%s) part? "
1081                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1082                            (format "protocol=%s" protocol))))))
1083           (save-excursion
1084             (if func
1085                 (funcall func parts ctl)
1086               (mm-set-handle-multipart-parameter
1087                mm-security-handle 'gnus-details
1088                (format "Unknown sign protocol (%s)" protocol))))))
1089      ((equal subtype "encrypted")
1090       (unless (setq protocol
1091                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1092         ;; The message is broken.
1093         (let ((parts parts))
1094           (while parts
1095             (if (assoc (mm-handle-media-type (car parts))
1096                        mm-decrypt-function-alist)
1097                 (setq protocol (mm-handle-media-type (car parts))
1098                       parts nil)
1099               (setq parts (cdr parts))))))
1100       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1101       (if (cond
1102            ((eq mm-decrypt-option 'never) nil)
1103            ((eq mm-decrypt-option 'always) t)
1104            ((eq mm-decrypt-option 'known)
1105             (and func
1106                  (or (not (setq functest
1107                                 (nth 3 (assoc protocol
1108                                               mm-decrypt-function-alist))))
1109                      (funcall functest parts ctl))))
1110            (t (y-or-n-p
1111                (format "Decrypt (%s) part? "
1112                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1113                            (format "protocol=%s" protocol))))))
1114           (save-excursion
1115             (if func
1116                 (setq parts (funcall func parts ctl))
1117               (mm-set-handle-multipart-parameter
1118                mm-security-handle 'gnus-details
1119                (format "Unknown encrypt protocol (%s)" protocol))))))
1120      (t nil))
1121     parts))
1122
1123 (defun mm-multiple-handles (handles)
1124    (and (listp (car handles))
1125         (> (length handles) 1)))
1126
1127 (defun mm-merge-handles (handles1 handles2)
1128   (append
1129    (if (listp (car handles1))
1130        handles1
1131      (list handles1))
1132    (if (listp (car handles2))
1133        handles2
1134      (list handles2))))
1135
1136 (provide 'mm-decode)
1137
1138 ;;; mm-decode.el ends here