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 (defcustom 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   :type 'directory
 231   :group 'mime-display)
 232
 233 (defcustom mm-inline-large-images nil
 234   "If non-nil, then all images fit in the buffer."
 235   :type 'boolean
 236   :group 'mime-display)
 237
 238 (defcustom mm-default-directory nil
 239   "The default directory where mm will save files.
 240 If not set, `default-directory' will be used."
 241   :type 'directory
 242   :group 'mime-display)
 243
 244 ;;; Internal variables.
 245
 246 (defvar mm-dissection-list nil)
 247 (defvar mm-last-shell-command "")
 248 (defvar mm-content-id-alist nil)
 249
 250 ;; According to RFC2046, in particular, in a digest, the default
 251 ;; Content-Type value for a body part is changed from "text/plain" to
 252 ;; "message/rfc822".
 253 (defvar mm-dissect-default-type "text/plain")
 254
 255 (autoload 'mml2015-verify "mml2015")
 256 (autoload 'mml2015-verify-test "mml2015")
 257 (autoload 'mml-smime-verify "mml-smime")
 258 (autoload 'mml-smime-verify-test "mml-smime")
 259
 260 (defvar mm-verify-function-alist
 261   '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
 262     ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
 263      mm-uu-pgp-signed-test)
 264     ("application/pkcs7-signature" mml-smime-verify "S/MIME"
 265      mml-smime-verify-test)
 266     ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
 267      mml-smime-verify-test)))
 268
 269 (defcustom mm-verify-option 'never
 270   "Option of verifying signed parts.
 271 `never', not verify; `always', always verify;
 272 `known', only verify known protocols. Otherwise, ask user."
 273   :type '(choice (item always)
 274                  (item never)
 275                  (item :tag "only known protocols" known)
 276                  (item :tag "ask" nil))
 277   :group 'mime-security)
 278
 279 (autoload 'mml2015-decrypt "mml2015")
 280 (autoload 'mml2015-decrypt-test "mml2015")
 281
 282 (defvar mm-decrypt-function-alist
 283   '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
 284     ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
 285      mm-uu-pgp-encrypted-test)))
 286
 287 (defcustom mm-decrypt-option nil
 288   "Option of decrypting encrypted parts.
 289 `never', not decrypt; `always', always decrypt;
 290 `known', only decrypt known protocols. Otherwise, ask user."
 291   :type '(choice (item always)
 292                  (item never)
 293                  (item :tag "only known protocols" known)
 294                  (item :tag "ask" nil))
 295   :group 'mime-security)
 296
 297 (defvar mm-viewer-completion-map
 298   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 299     (set-keymap-parent map minibuffer-local-completion-map)
 300     map)
 301   "Keymap for input viewer with completion.")
 302
 303 ;; Should we bind other key to minibuffer-complete-word?
 304 (define-key mm-viewer-completion-map " " 'self-insert-command)
 305
 306 (defvar mm-viewer-completion-map
 307   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 308     (set-keymap-parent map minibuffer-local-completion-map)
 309     map)
 310   "Keymap for input viewer with completion.")
 311
 312 ;; Should we bind other key to minibuffer-complete-word?
 313 (define-key mm-viewer-completion-map " " 'self-insert-command)
 314
 315 ;;; The functions.
 316
 317 (defun mm-alist-to-plist (alist)
 318   "Convert association list ALIST into the equivalent property-list form.
 319 The plist is returned.  This converts from
 320
 321 \((a . 1) (b . 2) (c . 3))
 322
 323 into
 324
 325 \(a 1 b 2 c 3)
 326
 327 The original alist is not modified.  See also `destructive-alist-to-plist'."
 328   (let (plist)
 329     (while alist
 330       (let ((el (car alist)))
 331         (setq plist (cons (cdr el) (cons (car el) plist))))
 332       (setq alist (cdr alist)))
 333     (nreverse plist)))
 334
 335 (defun mm-dissect-buffer (&optional no-strict-mime)
 336   "Dissect the current buffer and return a list of MIME handles."
 337   (save-excursion
 338     (let (ct ctl type subtype cte cd description id result from)
 339       (save-restriction
 340         (mail-narrow-to-head)
 341         (when (or no-strict-mime
 342                   (mail-fetch-field "mime-version"))
 343           (setq ct (mail-fetch-field "content-type")
 344                 ctl (ignore-errors (mail-header-parse-content-type ct))
 345                 cte (mail-fetch-field "content-transfer-encoding")
 346                 cd (mail-fetch-field "content-disposition")
 347                 description (mail-fetch-field "content-description")
 348                 from (mail-fetch-field "from")
 349                 id (mail-fetch-field "content-id"))
 350           ;; FIXME: In some circumstances, this code is running within
 351           ;; an unibyte macro.  mail-extract-address-components
 352           ;; creates unibyte buffers. This `if', though not a perfect
 353           ;; solution, avoids most of them.
 354           (if from
 355               (setq from (cadr (mail-extract-address-components from))))))
 356       (when cte
 357         (setq cte (mail-header-strip cte)))
 358       (if (or (not ctl)
 359               (not (string-match "/" (car ctl))))
 360           (mm-dissect-singlepart
 361            (list mm-dissect-default-type)
 362            (and cte (intern (downcase (mail-header-remove-whitespace
 363                                        (mail-header-remove-comments
 364                                         cte)))))
 365            no-strict-mime
 366            (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
 367            description)
 368         (setq type (split-string (car ctl) "/"))
 369         (setq subtype (cadr type)
 370               type (pop type))
 371         (setq
 372          result
 373          (cond
 374           ((equal type "multipart")
 375            (let ((mm-dissect-default-type (if (equal subtype "digest")
 376                                               "message/rfc822"
 377                                             "text/plain")))
 378              (add-text-properties 0 (length (car ctl))
 379                                   (mm-alist-to-plist (cdr ctl)) (car ctl))
 380
 381              ;; what really needs to be done here is a way to link a
 382              ;; MIME handle back to it's parent MIME handle (in a multilevel
 383              ;; MIME article).  That would probably require changing
 384              ;; the mm-handle API so we simply store the multipart buffert
 385              ;; name as a text property of the "multipart/whatever" string.
 386              (add-text-properties 0 (length (car ctl))
 387                                   (list 'buffer (mm-copy-to-buffer))
 388                                   (car ctl))
 389              (add-text-properties 0 (length (car ctl))
 390                                   (list 'from from)
 391                                   (car ctl))
 392              (cons (car ctl) (mm-dissect-multipart ctl))))
 393           (t
 394            (mm-dissect-singlepart
 395             ctl
 396             (and cte (intern (downcase (mail-header-remove-whitespace
 397                                         (mail-header-remove-comments
 398                                          cte)))))
 399             no-strict-mime
 400             (and cd (ignore-errors (mail-header-parse-content-disposition cd)))
 401             description id))))
 402         (when id
 403           (when (string-match " *<\\(.*\\)> *" id)
 404             (setq id (match-string 1 id)))
 405           (push (cons id result) mm-content-id-alist))
 406         result))))
 407
 408 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 409   (when (or force
 410             (if (equal "text/plain" (car ctl))
 411                 (assoc 'format ctl)
 412               t))
 413     (let ((res (mm-make-handle
 414                 (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 415       (push (car res) mm-dissection-list)
 416       res)))
 417
 418 (defun mm-remove-all-parts ()
 419   "Remove all MIME handles."
 420   (interactive)
 421   (mapcar 'mm-remove-part mm-dissection-list)
 422   (setq mm-dissection-list nil))
 423
 424 (defun mm-dissect-multipart (ctl)
 425   (goto-char (point-min))
 426   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 427          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 428          start parts
 429          (end (save-excursion
 430                 (goto-char (point-max))
 431                 (if (re-search-backward close-delimiter nil t)
 432                     (match-beginning 0)
 433                   (point-max)))))
 434     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
 435     (while (and (< (point) end) (re-search-forward boundary end t))
 436       (goto-char (match-beginning 0))
 437       (when start
 438         (save-excursion
 439           (save-restriction
 440             (narrow-to-region start (point))
 441             (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
 442       (forward-line 2)
 443       (setq start (point)))
 444     (when (and start (< start end))
 445       (save-excursion
 446         (save-restriction
 447           (narrow-to-region start end)
 448           (setq parts (nconc (list (mm-dissect-buffer t)) parts)))))
 449     (mm-possibly-verify-or-decrypt (nreverse parts) ctl)))
 450
 451 (defun mm-copy-to-buffer ()
 452   "Copy the contents of the current buffer to a fresh buffer."
 453   (save-excursion
 454     (let ((flag enable-multibyte-characters)
 455           (new-buffer (generate-new-buffer " *mm*")))
 456       (goto-char (point-min))
 457       (search-forward-regexp "^\n" nil t)
 458       (save-restriction
 459         (narrow-to-region (point) (point-max))
 460         (when flag
 461           (set-buffer-multibyte nil))
 462         (copy-to-buffer new-buffer (point-min) (point-max))
 463         (when flag
 464           (set-buffer-multibyte t)))
 465       new-buffer)))
 466
 467 (defun mm-display-parts (handle &optional no-default)
 468   (if (stringp (car handle))
 469       (mapcar 'mm-display-parts (cdr handle))
 470     (if (bufferp (car handle))
 471         (save-restriction
 472           (narrow-to-region (point) (point))
 473           (mm-display-part handle)
 474           (goto-char (point-max)))
 475       (mapcar 'mm-display-parts handle))))
 476
 477 (defun mm-display-part (handle &optional no-default)
 478   "Display the MIME part represented by HANDLE.
 479 Returns nil if the part is removed; inline if displayed inline;
 480 external if displayed external."
 481   (save-excursion
 482     (mailcap-parse-mailcaps)
 483     (if (mm-handle-displayed-p handle)
 484         (mm-remove-part handle)
 485       (let* ((type (mm-handle-media-type handle))
 486              (method (mailcap-mime-info type)))
 487         (if (mm-inlined-p handle)
 488             (progn
 489               (forward-line 1)
 490               (mm-display-inline handle)
 491               'inline)
 492           (when (or method
 493                     (not no-default))
 494             (if (and (not method)
 495                      (equal "text" (car (split-string type))))
 496                 (progn
 497                   (forward-line 1)
 498                   (mm-insert-inline handle (mm-get-part handle))
 499                   'inline)
 500               (mm-display-external
 501                handle (or method 'mailcap-save-binary-file)))))))))
 502
 503 (defun mm-display-external (handle method)
 504   "Display HANDLE using METHOD."
 505   (let ((outbuf (current-buffer)))
 506     (mm-with-unibyte-buffer
 507       (if (functionp method)
 508           (let ((cur (current-buffer)))
 509             (if (eq method 'mailcap-save-binary-file)
 510                 (progn
 511                   (set-buffer (generate-new-buffer " *mm*"))
 512                   (setq method nil))
 513               (mm-insert-part handle)
 514               (let ((win (get-buffer-window cur t)))
 515                 (when win
 516                   (select-window win)))
 517               (switch-to-buffer (generate-new-buffer " *mm*")))
 518             (buffer-disable-undo)
 519             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 520             (insert-buffer-substring cur)
 521             (goto-char (point-min))
 522             (message "Viewing with %s" method)
 523             (let ((mm (current-buffer))
 524                   (non-viewer (assq 'non-viewer
 525                                     (mailcap-mime-info
 526                                      (mm-handle-media-type handle) t))))
 527               (unwind-protect
 528                   (if method
 529                       (funcall method)
 530                     (mm-save-part handle))
 531                 (when (and (not non-viewer)
 532                            method)
 533                   (mm-handle-set-undisplayer handle mm)))))
 534         ;; The function is a string to be executed.
 535         (mm-insert-part handle)
 536         (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 537                (filename (mail-content-type-get
 538                           (mm-handle-disposition handle) 'filename))
 539                (mime-info (mailcap-mime-info
 540                            (mm-handle-media-type handle) t))
 541                (needsterm (or (assoc "needsterm" mime-info)
 542                               (assoc "needsterminal" mime-info)))
 543                (copiousoutput (assoc "copiousoutput" mime-info))
 544                file buffer)
 545           ;; We create a private sub-directory where we store our files.
 546           (make-directory dir)
 547           (set-file-modes dir 448)
 548           (if filename
 549               (setq file (expand-file-name (file-name-nondirectory filename)
 550                                            dir))
 551             (setq file (make-temp-name (expand-file-name "mm." dir))))
 552           (let ((coding-system-for-write mm-binary-coding-system))
 553             (write-region (point-min) (point-max) file nil 'nomesg))
 554           (message "Viewing with %s" method)
 555           (cond (needsterm
 556                  (unwind-protect
 557                      (start-process "*display*" nil
 558                                     "xterm"
 559                                     "-e" shell-file-name
 560                                     shell-command-switch
 561                                     (mm-mailcap-command
 562                                      method file (mm-handle-type handle)))
 563                    (mm-handle-set-undisplayer handle (cons file buffer)))
 564                  (message "Displaying %s..." (format method file))
 565                  'external)
 566                 (copiousoutput
 567                  (with-current-buffer outbuf
 568                    (forward-line 1)
 569                    (mm-insert-inline
 570                     handle
 571                     (unwind-protect
 572                         (progn
 573                           (call-process shell-file-name nil
 574                                         (setq buffer
 575                                               (generate-new-buffer " *mm*"))
 576                                         nil
 577                                         shell-command-switch
 578                                         (mm-mailcap-command
 579                                          method file (mm-handle-type handle)))
 580                           (if (buffer-live-p buffer)
 581                               (save-excursion
 582                                 (set-buffer buffer)
 583                                 (buffer-string))))
 584                       (progn
 585                         (ignore-errors (delete-file file))
 586                         (ignore-errors (delete-directory
 587                                         (file-name-directory file)))
 588                         (ignore-errors (kill-buffer buffer))))))
 589                  'inline)
 590                 (t
 591                  (unwind-protect
 592                      (start-process "*display*"
 593                                     (setq buffer
 594                                           (generate-new-buffer " *mm*"))
 595                                     shell-file-name
 596                                     shell-command-switch
 597                                     (mm-mailcap-command
 598                                      method file (mm-handle-type handle)))
 599                    (mm-handle-set-undisplayer handle (cons file buffer)))
 600                  (message "Displaying %s..." (format method file))
 601                  'external)))))))
 602
 603 (defun mm-mailcap-command (method file type-list)
 604   (let ((ctl (cdr type-list))
 605         (beg 0)
 606         (uses-stdin t)
 607         out sub total)
 608     (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg)
 609       (push (substring method beg (match-beginning 0)) out)
 610       (setq beg (match-end 0)
 611             total (match-string 0 method)
 612             sub (match-string 1 method))
 613       (cond
 614        ((string= total "%%")
 615         (push "%" out))
 616        ((string= total "%s")
 617         (setq uses-stdin nil)
 618         (push (mm-quote-arg file) out))
 619        ((string= total "%t")
 620         (push (mm-quote-arg (car type-list)) out))
 621        (t
 622         (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
 623     (push (substring method beg (length method)) out)
 624     (if uses-stdin
 625         (progn
 626           (push "<" out)
 627           (push (mm-quote-arg file) out)))
 628     (mapconcat 'identity (nreverse out) "")))
 629
 630 (defun mm-remove-parts (handles)
 631   "Remove the displayed MIME parts represented by HANDLES."
 632   (if (and (listp handles)
 633            (bufferp (car handles)))
 634       (mm-remove-part handles)
 635     (let (handle)
 636       (while (setq handle (pop handles))
 637         (cond
 638          ((stringp handle)
 639           (when (buffer-live-p (get-text-property 0 'buffer handle))
 640             (kill-buffer (get-text-property 0 'buffer handle))))
 641          ((and (listp handle)
 642                (stringp (car handle)))
 643           (mm-remove-parts (cdr handle)))
 644          (t
 645           (mm-remove-part handle)))))))
 646
 647 (defun mm-destroy-parts (handles)
 648   "Remove the displayed MIME parts represented by HANDLES."
 649   (if (and (listp handles)
 650            (bufferp (car handles)))
 651       (mm-destroy-part handles)
 652     (let (handle)
 653       (while (setq handle (pop handles))
 654         (cond
 655          ((stringp handle)
 656           (when (buffer-live-p (get-text-property 0 'buffer handle))
 657             (kill-buffer (get-text-property 0 'buffer handle))))
 658          ((and (listp handle)
 659                (stringp (car handle)))
 660           (mm-destroy-parts handle))
 661          (t
 662           (mm-destroy-part handle)))))))
 663
 664 (defun mm-remove-part (handle)
 665   "Remove the displayed MIME part represented by HANDLE."
 666   (when (listp handle)
 667     (let ((object (mm-handle-undisplayer handle)))
 668       (ignore-errors
 669         (cond
 670          ;; Internally displayed part.
 671          ((mm-annotationp object)
 672           (delete-annotation object))
 673          ((or (functionp object)
 674               (and (listp object)
 675                    (eq (car object) 'lambda)))
 676           (funcall object))
 677          ;; Externally displayed part.
 678          ((consp object)
 679           (ignore-errors (delete-file (car object)))
 680           (ignore-errors (delete-directory (file-name-directory (car object))))
 681           (ignore-errors (kill-buffer (cdr object))))
 682          ((bufferp object)
 683           (when (buffer-live-p object)
 684             (kill-buffer object)))))
 685       (mm-handle-set-undisplayer handle nil))))
 686
 687 (defun mm-display-inline (handle)
 688   (let* ((type (mm-handle-media-type handle))
 689          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 690     (funcall function handle)
 691     (goto-char (point-min))))
 692
 693 (defun mm-assoc-string-match (alist type)
 694   (dolist (elem alist)
 695     (when (string-match (car elem) type)
 696       (return elem))))
 697
 698 (defun mm-inlinable-p (handle)
 699   "Say whether HANDLE can be displayed inline."
 700   (let ((alist mm-inline-media-tests)
 701         (type (mm-handle-media-type handle))
 702         test)
 703     (while alist
 704       (when (string-match (caar alist) type)
 705         (setq test (caddar alist)
 706               alist nil)
 707         (setq test (funcall test handle)))
 708       (pop alist))
 709     test))
 710
 711 (defun mm-automatic-display-p (handle)
 712   "Say whether the user wants HANDLE to be displayed automatically."
 713   (let ((methods mm-automatic-display)
 714         (type (mm-handle-media-type handle))
 715         method result)
 716     (while (setq method (pop methods))
 717       (when (and (not (mm-inline-override-p handle))
 718                  (string-match method type)
 719                  (mm-inlinable-p handle))
 720         (setq result t
 721               methods nil)))
 722     result))
 723
 724 (defun mm-inlined-p (handle)
 725   "Say whether the user wants HANDLE to be displayed automatically."
 726   (let ((methods mm-inlined-types)
 727         (type (mm-handle-media-type handle))
 728         method result)
 729     (while (setq method (pop methods))
 730       (when (and (not (mm-inline-override-p handle))
 731                  (string-match method type)
 732                  (mm-inlinable-p handle))
 733         (setq result t
 734               methods nil)))
 735     result))
 736
 737 (defun mm-attachment-override-p (handle)
 738   "Say whether HANDLE should have attachment behavior overridden."
 739   (let ((types mm-attachment-override-types)
 740         (type (mm-handle-media-type handle))
 741         ty)
 742     (catch 'found
 743       (while (setq ty (pop types))
 744         (when (and (string-match ty type)
 745                    (mm-inlinable-p handle))
 746           (throw 'found t))))))
 747
 748 (defun mm-inline-override-p (handle)
 749   "Say whether HANDLE should have inline behavior overridden."
 750   (let ((types mm-inline-override-types)
 751         (type (mm-handle-media-type handle))
 752         ty)
 753     (catch 'found
 754       (while (setq ty (pop types))
 755         (when (string-match ty type)
 756           (throw 'found t))))))
 757
 758 (defun mm-automatic-external-display-p (type)
 759   "Return the user-defined method for TYPE."
 760   (let ((methods mm-automatic-external-display)
 761         method result)
 762     (while (setq method (pop methods))
 763       (when (string-match method type)
 764         (setq result t
 765               methods nil)))
 766     result))
 767
 768 (defun mm-destroy-part (handle)
 769   "Destroy the data structures connected to HANDLE."
 770   (when (listp handle)
 771     (mm-remove-part handle)
 772     (when (buffer-live-p (mm-handle-buffer handle))
 773       (kill-buffer (mm-handle-buffer handle)))))
 774
 775 (defun mm-handle-displayed-p (handle)
 776   "Say whether HANDLE is displayed or not."
 777   (mm-handle-undisplayer handle))
 778
 779 ;;;
 780 ;;; Functions for outputting parts
 781 ;;;
 782
 783 (defun mm-get-part (handle)
 784   "Return the contents of HANDLE as a string."
 785   (mm-with-unibyte-buffer
 786     (insert (with-current-buffer (mm-handle-buffer handle)
 787               (mm-with-unibyte-current-buffer-mule4
 788                 (buffer-string))))
 789     (mm-decode-content-transfer-encoding
 790      (mm-handle-encoding handle)
 791      (mm-handle-media-type handle))
 792     (buffer-string)))
 793
 794 (defun mm-insert-part (handle)
 795   "Insert the contents of HANDLE in the current buffer."
 796   (let ((cur (current-buffer)))
 797     (save-excursion
 798       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 799           (with-temp-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         (mm-with-unibyte-buffer
 808           (insert-buffer-substring (mm-handle-buffer handle))
 809           (mm-decode-content-transfer-encoding
 810            (mm-handle-encoding handle)
 811            (mm-handle-media-type handle))
 812           (let ((temp (current-buffer)))
 813             (set-buffer cur)
 814             (insert-buffer-substring temp)))))))
 815
 816 (defun mm-save-part (handle)
 817   "Write HANDLE to a file."
 818   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 819          (filename (mail-content-type-get
 820                     (mm-handle-disposition handle) 'filename))
 821          file)
 822     (when filename
 823       (setq filename (file-name-nondirectory filename)))
 824     (setq file
 825           (read-file-name "Save MIME part to: "
 826                           (expand-file-name
 827                            (or filename name "")
 828                            (or mm-default-directory default-directory))))
 829     (setq mm-default-directory (file-name-directory file))
 830     (and (or (not (file-exists-p file))
 831              (yes-or-no-p (format "File %s already exists; overwrite? "
 832                                   file)))
 833          (progn
 834            (mm-save-part-to-file handle file)
 835            file))))
 836
 837 (defun mm-save-part-to-file (handle file)
 838   (mm-with-unibyte-buffer
 839     (mm-insert-part handle)
 840     (let ((coding-system-for-write 'binary)
 841           ;; Don't re-compress .gz & al.  Arguably we should make
 842           ;; `file-name-handler-alist' nil, but that would chop
 843           ;; ange-ftp, which is reasonable to use here.
 844           (inhibit-file-name-operation 'write-region)
 845           (inhibit-file-name-handlers
 846            (cons 'jka-compr-handler inhibit-file-name-handlers)))
 847       (write-region (point-min) (point-max) file))))
 848
 849 (defun mm-pipe-part (handle)
 850   "Pipe HANDLE to a process."
 851   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 852          (command
 853           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 854     (mm-with-unibyte-buffer
 855       (mm-insert-part handle)
 856       (shell-command-on-region (point-min) (point-max) command nil))))
 857
 858 (defun mm-interactively-view-part (handle)
 859   "Display HANDLE using METHOD."
 860   (let* ((type (mm-handle-media-type handle))
 861          (methods
 862           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 863                   (mailcap-mime-info type 'all)))
 864          (method (let ((minibuffer-local-completion-map
 865                         mm-viewer-completion-map))
 866                    (completing-read "Viewer: " methods))))
 867     (when (string= method "")
 868       (error "No method given"))
 869     (if (string-match "^[^% \t]+$" method)
 870         (setq method (concat method " %s")))
 871     (mm-display-external handle method)))
 872
 873 (defun mm-preferred-alternative (handles &optional preferred)
 874   "Say which of HANDLES are preferred."
 875   (let ((prec (if preferred (list preferred)
 876                 (mm-preferred-alternative-precedence handles)))
 877         p h result type handle)
 878     (while (setq p (pop prec))
 879       (setq h handles)
 880       (while h
 881         (setq handle (car h))
 882         (setq type (mm-handle-media-type handle))
 883         (when (and (equal p type)
 884                    (mm-automatic-display-p handle)
 885                    (or (stringp (car handle))
 886                        (not (mm-handle-disposition handle))
 887                        (equal (car (mm-handle-disposition handle))
 888                               "inline")))
 889           (setq result handle
 890                 h nil
 891                 prec nil))
 892         (pop h)))
 893     result))
 894
 895 (defun mm-preferred-alternative-precedence (handles)
 896   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
 897   (let ((seq (nreverse (mapcar #'mm-handle-media-type
 898                                handles))))
 899     (dolist (disc (reverse mm-discouraged-alternatives))
 900       (dolist (elem (copy-sequence seq))
 901         (when (string-match disc elem)
 902           (setq seq (nconc (delete elem seq) (list elem))))))
 903     seq))
 904
 905 (defun mm-get-content-id (id)
 906   "Return the handle(s) referred to by ID."
 907   (cdr (assoc id mm-content-id-alist)))
 908
 909 (defun mm-get-image (handle)
 910   "Return an image instance based on HANDLE."
 911   (let ((type (mm-handle-media-subtype handle))
 912         spec)
 913     ;; Allow some common translations.
 914     (setq type
 915           (cond
 916            ((equal type "x-pixmap")
 917             "xpm")
 918            ((equal type "x-xbitmap")
 919             "xbm")
 920            ((equal type "x-portable-bitmap")
 921             "pbm")
 922            (t type)))
 923     (or (mm-handle-cache handle)
 924         (mm-with-unibyte-buffer
 925           (mm-insert-part handle)
 926           (prog1
 927               (setq spec
 928                     (ignore-errors
 929                      ;; Avoid testing `make-glyph' since W3 may define
 930                      ;; a bogus version of it.
 931                       (if (fboundp 'create-image)
 932                           (create-image (buffer-string) (intern type) 'data-p)
 933                         (cond
 934                          ((equal type "xbm")
 935                           ;; xbm images require special handling, since
 936                           ;; the only way to create glyphs from these
 937                           ;; (without a ton of work) is to write them
 938                           ;; out to a file, and then create a file
 939                           ;; specifier.
 940                           (let ((file (make-temp-name
 941                                        (expand-file-name "emm.xbm"
 942                                                          mm-tmp-directory))))
 943                             (unwind-protect
 944                                 (progn
 945                                   (write-region (point-min) (point-max) file)
 946                                   (make-glyph (list (cons 'x file))))
 947                               (ignore-errors
 948                                (delete-file file)))))
 949                          (t
 950                           (make-glyph
 951                            (vector (intern type) :data (buffer-string))))))))
 952             (mm-handle-set-cache handle spec))))))
 953
 954 (defun mm-image-fit-p (handle)
 955   "Say whether the image in HANDLE will fit the current window."
 956   (let ((image (mm-get-image handle)))
 957     (if (fboundp 'glyph-width)
 958         ;; XEmacs' glyphs can actually tell us about their width, so
 959         ;; lets be nice and smart about them.
 960         (or mm-inline-large-images
 961             (and (< (glyph-width image) (window-pixel-width))
 962                  (< (glyph-height image) (window-pixel-height))))
 963       (let* ((size (image-size image))
 964              (w (car size))
 965              (h (cdr size)))
 966         (or mm-inline-large-images
 967             (and (< h (1- (window-height))) ; Don't include mode line.
 968                  (< w (window-width))))))))
 969
 970 (defun mm-valid-image-format-p (format)
 971   "Say whether FORMAT can be displayed natively by Emacs."
 972   (cond
 973    ;; Handle XEmacs
 974    ((fboundp 'valid-image-instantiator-format-p)
 975     (valid-image-instantiator-format-p format))
 976    ;; Handle Emacs 21
 977    ((fboundp 'image-type-available-p)
 978     (and (display-graphic-p)
 979          (image-type-available-p format)))
 980    ;; Nobody else can do images yet.
 981    (t
 982     nil)))
 983
 984 (defun mm-valid-and-fit-image-p (format handle)
 985   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
 986   (and (mm-valid-image-format-p format)
 987        (mm-image-fit-p handle)))
 988
 989 (defun mm-find-part-by-type (handles type &optional notp recursive)
 990   "Search in HANDLES for part with TYPE.
 991 If NOTP, returns first non-matching part.
 992 If RECURSIVE, search recursively."
 993   (let (handle)
 994     (while handles
 995       (if (and recursive (stringp (caar handles)))
 996           (if (setq handle (mm-find-part-by-type (cdar handles) type
 997                                                  notp recursive))
 998               (setq handles nil))
 999         (if (if notp
1000                 (not (equal (mm-handle-media-type (car handles)) type))
1001               (equal (mm-handle-media-type (car handles)) type))
1002             (setq handle (car handles)
1003                   handles nil)))
1004       (setq handles (cdr handles)))
1005     handle))
1006
1007 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1008   (goto-char (point-min))
1009   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1010                                                                    'boundary)))
1011          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1012          start
1013          (end (save-excursion
1014                 (goto-char (point-max))
1015                 (if (re-search-backward close-delimiter nil t)
1016                     (match-beginning 0)
1017                   (point-max))))
1018          result)
1019     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1020     (while (and (not result)
1021                 (re-search-forward boundary end t))
1022       (goto-char (match-beginning 0))
1023       (when start
1024         (save-excursion
1025           (save-restriction
1026             (narrow-to-region start (1- (point)))
1027             (when (let ((ctl (ignore-errors
1028                                (mail-header-parse-content-type
1029                                 (mail-fetch-field "content-type")))))
1030                     (if notp
1031                         (not (equal (car ctl) type))
1032                       (equal (car ctl) type)))
1033               (setq result (buffer-substring (point-min) (point-max)))))))
1034       (forward-line 1)
1035       (setq start (point)))
1036     (when (and (not result) start)
1037       (save-excursion
1038         (save-restriction
1039           (narrow-to-region start end)
1040           (when (let ((ctl (ignore-errors
1041                              (mail-header-parse-content-type
1042                               (mail-fetch-field "content-type")))))
1043                   (if notp
1044                       (not (equal (car ctl) type))
1045                     (equal (car ctl) type)))
1046             (setq result (buffer-substring (point-min) (point-max)))))))
1047     result))
1048
1049 (defvar mm-security-handle nil)
1050
1051 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1052   ;; HANDLE could be a CTL.
1053   (if handle
1054       (put-text-property 0 (length (car handle)) parameter value
1055                          (car handle))))
1056
1057 (defun mm-possibly-verify-or-decrypt (parts ctl)
1058   (let ((subtype (cadr (split-string (car ctl) "/")))
1059         (mm-security-handle ctl) ;; (car CTL) is the type.
1060         protocol func functest)
1061     (cond
1062      ((equal subtype "signed")
1063       (unless (and (setq protocol
1064                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1065                    (not (equal protocol "multipart/mixed")))
1066         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1067         (let ((protocols mm-verify-function-alist))
1068           (while protocols
1069             (if (and (or (not (setq functest (nth 3 (car protocols))))
1070                          (funcall functest parts ctl))
1071                      (mm-find-part-by-type parts (caar protocols) nil t))
1072                 (setq protocol (caar protocols)
1073                       protocols nil)
1074               (setq protocols (cdr protocols))))))
1075       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1076       (if (cond
1077            ((eq mm-verify-option 'never) nil)
1078            ((eq mm-verify-option 'always) t)
1079            ((eq mm-verify-option 'known)
1080             (and func
1081                  (or (not (setq functest
1082                                 (nth 3 (assoc protocol
1083                                               mm-verify-function-alist))))
1084                      (funcall functest parts ctl))))
1085            (t (y-or-n-p
1086                (format "Verify signed (%s) part? "
1087                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1088                            (format "protocol=%s" protocol))))))
1089           (save-excursion
1090             (if func
1091                 (funcall func parts ctl)
1092               (mm-set-handle-multipart-parameter
1093                mm-security-handle 'gnus-details
1094                (format "Unknown sign protocol (%s)" protocol))))))
1095      ((equal subtype "encrypted")
1096       (unless (setq protocol
1097                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1098         ;; The message is broken.
1099         (let ((parts parts))
1100           (while parts
1101             (if (assoc (mm-handle-media-type (car parts))
1102                        mm-decrypt-function-alist)
1103                 (setq protocol (mm-handle-media-type (car parts))
1104                       parts nil)
1105               (setq parts (cdr parts))))))
1106       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1107       (if (cond
1108            ((eq mm-decrypt-option 'never) nil)
1109            ((eq mm-decrypt-option 'always) t)
1110            ((eq mm-decrypt-option 'known)
1111             (and func
1112                  (or (not (setq functest
1113                                 (nth 3 (assoc protocol
1114                                               mm-decrypt-function-alist))))
1115                      (funcall functest parts ctl))))
1116            (t (y-or-n-p
1117                (format "Decrypt (%s) part? "
1118                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1119                            (format "protocol=%s" protocol))))))
1120           (save-excursion
1121             (if func
1122                 (setq parts (funcall func parts ctl))
1123               (mm-set-handle-multipart-parameter
1124                mm-security-handle 'gnus-details
1125                (format "Unknown encrypt protocol (%s)" protocol))))))
1126      (t nil))
1127     parts))
1128
1129 (defun mm-multiple-handles (handles)
1130    (and (listp (car handles))
1131         (> (length handles) 1)))
1132
1133 (defun mm-merge-handles (handles1 handles2)
1134   (append
1135    (if (listp (car handles1))
1136        handles1
1137      (list handles1))
1138    (if (listp (car handles2))
1139        handles2
1140      (list handles2))))
1141
1142 (provide 'mm-decode)
1143
1144 ;;; mm-decode.el ends here