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 '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 ((obuf (current-buffer))
 455           beg)
 456       (goto-char (point-min))
 457       (search-forward-regexp "^\n" nil t)
 458       (setq beg (point))
 459       (set-buffer (generate-new-buffer " *mm*"))
 460       (insert-buffer-substring obuf beg)
 461       (current-buffer))))
 462
 463 (defun mm-display-parts (handle &optional no-default)
 464   (if (stringp (car handle))
 465       (mapcar 'mm-display-parts (cdr handle))
 466     (if (bufferp (car handle))
 467         (save-restriction
 468           (narrow-to-region (point) (point))
 469           (mm-display-part handle)
 470           (goto-char (point-max)))
 471       (mapcar 'mm-display-parts handle))))
 472
 473 (defun mm-display-part (handle &optional no-default)
 474   "Display the MIME part represented by HANDLE.
 475 Returns nil if the part is removed; inline if displayed inline;
 476 external if displayed external."
 477   (save-excursion
 478     (mailcap-parse-mailcaps)
 479     (if (mm-handle-displayed-p handle)
 480         (mm-remove-part handle)
 481       (let* ((type (mm-handle-media-type handle))
 482              (method (mailcap-mime-info type)))
 483         (if (mm-inlined-p handle)
 484             (progn
 485               (forward-line 1)
 486               (mm-display-inline handle)
 487               'inline)
 488           (when (or method
 489                     (not no-default))
 490             (if (and (not method)
 491                      (equal "text" (car (split-string type))))
 492                 (progn
 493                   (forward-line 1)
 494                   (mm-insert-inline handle (mm-get-part handle))
 495                   'inline)
 496               (mm-display-external
 497                handle (or method 'mailcap-save-binary-file)))))))))
 498
 499 (defun mm-display-external (handle method)
 500   "Display HANDLE using METHOD."
 501   (let ((outbuf (current-buffer)))
 502     (mm-with-unibyte-buffer
 503       (if (functionp method)
 504           (let ((cur (current-buffer)))
 505             (if (eq method 'mailcap-save-binary-file)
 506                 (progn
 507                   (set-buffer (generate-new-buffer " *mm*"))
 508                   (setq method nil))
 509               (mm-insert-part handle)
 510               (let ((win (get-buffer-window cur t)))
 511                 (when win
 512                   (select-window win)))
 513               (switch-to-buffer (generate-new-buffer " *mm*")))
 514             (buffer-disable-undo)
 515             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 516             (insert-buffer-substring cur)
 517             (goto-char (point-min))
 518             (message "Viewing with %s" method)
 519             (let ((mm (current-buffer))
 520                   (non-viewer (assq 'non-viewer
 521                                     (mailcap-mime-info
 522                                      (mm-handle-media-type handle) t))))
 523               (unwind-protect
 524                   (if method
 525                       (funcall method)
 526                     (mm-save-part handle))
 527                 (when (and (not non-viewer)
 528                            method)
 529                   (mm-handle-set-undisplayer handle mm)))))
 530         ;; The function is a string to be executed.
 531         (mm-insert-part handle)
 532         (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 533                (filename (mail-content-type-get
 534                           (mm-handle-disposition handle) 'filename))
 535                (mime-info (mailcap-mime-info
 536                            (mm-handle-media-type handle) t))
 537                (needsterm (or (assoc "needsterm" mime-info)
 538                               (assoc "needsterminal" mime-info)))
 539                (copiousoutput (assoc "copiousoutput" mime-info))
 540                file buffer)
 541           ;; We create a private sub-directory where we store our files.
 542           (make-directory dir)
 543           (set-file-modes dir 448)
 544           (if filename
 545               (setq file (expand-file-name (file-name-nondirectory filename)
 546                                            dir))
 547             (setq file (make-temp-name (expand-file-name "mm." dir))))
 548           (let ((coding-system-for-write mm-binary-coding-system))
 549             (write-region (point-min) (point-max) file nil 'nomesg))
 550           (message "Viewing with %s" method)
 551           (cond (needsterm
 552                  (unwind-protect
 553                      (start-process "*display*" nil
 554                                     "xterm"
 555                                     "-e" shell-file-name
 556                                     shell-command-switch
 557                                     (mm-mailcap-command
 558                                      method file (mm-handle-type handle)))
 559                    (mm-handle-set-undisplayer handle (cons file buffer)))
 560                  (message "Displaying %s..." (format method file))
 561                  'external)
 562                 (copiousoutput
 563                  (with-current-buffer outbuf
 564                    (forward-line 1)
 565                    (mm-insert-inline
 566                     handle
 567                     (unwind-protect
 568                         (progn
 569                           (call-process shell-file-name nil
 570                                         (setq buffer
 571                                               (generate-new-buffer " *mm*"))
 572                                         nil
 573                                         shell-command-switch
 574                                         (mm-mailcap-command
 575                                          method file (mm-handle-type handle)))
 576                           (if (buffer-live-p buffer)
 577                               (save-excursion
 578                                 (set-buffer buffer)
 579                                 (buffer-string))))
 580                       (progn
 581                         (ignore-errors (delete-file file))
 582                         (ignore-errors (delete-directory
 583                                         (file-name-directory file)))
 584                         (ignore-errors (kill-buffer buffer))))))
 585                  'inline)
 586                 (t
 587                  (unwind-protect
 588                      (start-process "*display*"
 589                                     (setq buffer
 590                                           (generate-new-buffer " *mm*"))
 591                                     shell-file-name
 592                                     shell-command-switch
 593                                     (mm-mailcap-command
 594                                      method file (mm-handle-type handle)))
 595                    (mm-handle-set-undisplayer handle (cons file buffer)))
 596                  (message "Displaying %s..." (format method file))
 597                  'external)))))))
 598
 599 (defun mm-mailcap-command (method file type-list)
 600   (let ((ctl (cdr type-list))
 601         (beg 0)
 602         (uses-stdin t)
 603         out sub total)
 604     (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg)
 605       (push (substring method beg (match-beginning 0)) out)
 606       (setq beg (match-end 0)
 607             total (match-string 0 method)
 608             sub (match-string 1 method))
 609       (cond
 610        ((string= total "%%")
 611         (push "%" out))
 612        ((string= total "%s")
 613         (setq uses-stdin nil)
 614         (push (mm-quote-arg file) out))
 615        ((string= total "%t")
 616         (push (mm-quote-arg (car type-list)) out))
 617        (t
 618         (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
 619     (push (substring method beg (length method)) out)
 620     (if uses-stdin
 621         (progn
 622           (push "<" out)
 623           (push (mm-quote-arg file) out)))
 624     (mapconcat 'identity (nreverse out) "")))
 625
 626 (defun mm-remove-parts (handles)
 627   "Remove the displayed MIME parts represented by HANDLES."
 628   (if (and (listp handles)
 629            (bufferp (car handles)))
 630       (mm-remove-part handles)
 631     (let (handle)
 632       (while (setq handle (pop handles))
 633         (cond
 634          ((stringp handle)
 635           (when (buffer-live-p (get-text-property 0 'buffer handle))
 636             (kill-buffer (get-text-property 0 'buffer handle))))
 637          ((and (listp handle)
 638                (stringp (car handle)))
 639           (mm-remove-parts (cdr handle)))
 640          (t
 641           (mm-remove-part handle)))))))
 642
 643 (defun mm-destroy-parts (handles)
 644   "Remove the displayed MIME parts represented by HANDLES."
 645   (if (and (listp handles)
 646            (bufferp (car handles)))
 647       (mm-destroy-part handles)
 648     (let (handle)
 649       (while (setq handle (pop handles))
 650         (cond
 651          ((stringp handle)
 652           (when (buffer-live-p (get-text-property 0 'buffer handle))
 653             (kill-buffer (get-text-property 0 'buffer handle))))
 654          ((and (listp handle)
 655                (stringp (car handle)))
 656           (mm-destroy-parts handle))
 657          (t
 658           (mm-destroy-part handle)))))))
 659
 660 (defun mm-remove-part (handle)
 661   "Remove the displayed MIME part represented by HANDLE."
 662   (when (listp handle)
 663     (let ((object (mm-handle-undisplayer handle)))
 664       (ignore-errors
 665         (cond
 666          ;; Internally displayed part.
 667          ((mm-annotationp object)
 668           (delete-annotation object))
 669          ((or (functionp object)
 670               (and (listp object)
 671                    (eq (car object) 'lambda)))
 672           (funcall object))
 673          ;; Externally displayed part.
 674          ((consp object)
 675           (ignore-errors (delete-file (car object)))
 676           (ignore-errors (delete-directory (file-name-directory (car object))))
 677           (ignore-errors (kill-buffer (cdr object))))
 678          ((bufferp object)
 679           (when (buffer-live-p object)
 680             (kill-buffer object)))))
 681       (mm-handle-set-undisplayer handle nil))))
 682
 683 (defun mm-display-inline (handle)
 684   (let* ((type (mm-handle-media-type handle))
 685          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 686     (funcall function handle)
 687     (goto-char (point-min))))
 688
 689 (defun mm-assoc-string-match (alist type)
 690   (dolist (elem alist)
 691     (when (string-match (car elem) type)
 692       (return elem))))
 693
 694 (defun mm-inlinable-p (handle)
 695   "Say whether HANDLE can be displayed inline."
 696   (let ((alist mm-inline-media-tests)
 697         (type (mm-handle-media-type handle))
 698         test)
 699     (while alist
 700       (when (string-match (caar alist) type)
 701         (setq test (caddar alist)
 702               alist nil)
 703         (setq test (funcall test handle)))
 704       (pop alist))
 705     test))
 706
 707 (defun mm-automatic-display-p (handle)
 708   "Say whether the user wants HANDLE to be displayed automatically."
 709   (let ((methods mm-automatic-display)
 710         (type (mm-handle-media-type handle))
 711         method result)
 712     (while (setq method (pop methods))
 713       (when (and (not (mm-inline-override-p handle))
 714                  (string-match method type)
 715                  (mm-inlinable-p handle))
 716         (setq result t
 717               methods nil)))
 718     result))
 719
 720 (defun mm-inlined-p (handle)
 721   "Say whether the user wants HANDLE to be displayed automatically."
 722   (let ((methods mm-inlined-types)
 723         (type (mm-handle-media-type handle))
 724         method result)
 725     (while (setq method (pop methods))
 726       (when (and (not (mm-inline-override-p handle))
 727                  (string-match method type)
 728                  (mm-inlinable-p handle))
 729         (setq result t
 730               methods nil)))
 731     result))
 732
 733 (defun mm-attachment-override-p (handle)
 734   "Say whether HANDLE should have attachment behavior overridden."
 735   (let ((types mm-attachment-override-types)
 736         (type (mm-handle-media-type handle))
 737         ty)
 738     (catch 'found
 739       (while (setq ty (pop types))
 740         (when (and (string-match ty type)
 741                    (mm-inlinable-p handle))
 742           (throw 'found t))))))
 743
 744 (defun mm-inline-override-p (handle)
 745   "Say whether HANDLE should have inline behavior overridden."
 746   (let ((types mm-inline-override-types)
 747         (type (mm-handle-media-type handle))
 748         ty)
 749     (catch 'found
 750       (while (setq ty (pop types))
 751         (when (string-match ty type)
 752           (throw 'found t))))))
 753
 754 (defun mm-automatic-external-display-p (type)
 755   "Return the user-defined method for TYPE."
 756   (let ((methods mm-automatic-external-display)
 757         method result)
 758     (while (setq method (pop methods))
 759       (when (string-match method type)
 760         (setq result t
 761               methods nil)))
 762     result))
 763
 764 (defun mm-destroy-part (handle)
 765   "Destroy the data structures connected to HANDLE."
 766   (when (listp handle)
 767     (mm-remove-part handle)
 768     (when (buffer-live-p (mm-handle-buffer handle))
 769       (kill-buffer (mm-handle-buffer handle)))))
 770
 771 (defun mm-handle-displayed-p (handle)
 772   "Say whether HANDLE is displayed or not."
 773   (mm-handle-undisplayer handle))
 774
 775 ;;;
 776 ;;; Functions for outputting parts
 777 ;;;
 778
 779 (defun mm-get-part (handle)
 780   "Return the contents of HANDLE as a string."
 781   (mm-with-unibyte-buffer
 782     (insert (with-current-buffer (mm-handle-buffer handle)
 783               (mm-with-unibyte-current-buffer-mule4
 784                 (buffer-string))))
 785     (mm-decode-content-transfer-encoding
 786      (mm-handle-encoding handle)
 787      (mm-handle-media-type handle))
 788     (buffer-string)))
 789
 790 (defun mm-insert-part (handle)
 791   "Insert the contents of HANDLE in the current buffer."
 792   (let ((cur (current-buffer)))
 793     (save-excursion
 794       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 795           (with-temp-buffer
 796             (insert-buffer-substring (mm-handle-buffer handle))
 797             (mm-decode-content-transfer-encoding
 798              (mm-handle-encoding handle)
 799              (mm-handle-media-type handle))
 800             (let ((temp (current-buffer)))
 801               (set-buffer cur)
 802               (insert-buffer-substring temp)))
 803         (mm-with-unibyte-buffer
 804           (insert-buffer-substring (mm-handle-buffer handle))
 805           (mm-decode-content-transfer-encoding
 806            (mm-handle-encoding handle)
 807            (mm-handle-media-type handle))
 808           (let ((temp (current-buffer)))
 809             (set-buffer cur)
 810             (insert-buffer-substring temp)))))))
 811
 812 (defun mm-save-part (handle)
 813   "Write HANDLE to a file."
 814   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 815          (filename (mail-content-type-get
 816                     (mm-handle-disposition handle) 'filename))
 817          file)
 818     (when filename
 819       (setq filename (file-name-nondirectory filename)))
 820     (setq file
 821           (read-file-name "Save MIME part to: "
 822                           (expand-file-name
 823                            (or filename name "")
 824                            (or mm-default-directory default-directory))))
 825     (setq mm-default-directory (file-name-directory file))
 826     (and (or (not (file-exists-p file))
 827              (yes-or-no-p (format "File %s already exists; overwrite? "
 828                                   file)))
 829          (progn
 830            (mm-save-part-to-file handle file)
 831            file))))
 832
 833 (defun mm-save-part-to-file (handle file)
 834   (mm-with-unibyte-buffer
 835     (mm-insert-part handle)
 836     (let ((coding-system-for-write 'binary)
 837           ;; Don't re-compress .gz & al.  Arguably we should make
 838           ;; `file-name-handler-alist' nil, but that would chop
 839           ;; ange-ftp, which is reasonable to use here.
 840           (inhibit-file-name-operation 'write-region)
 841           (inhibit-file-name-handlers
 842            (cons 'jka-compr-handler inhibit-file-name-handlers)))
 843       (write-region (point-min) (point-max) file))))
 844
 845 (defun mm-pipe-part (handle)
 846   "Pipe HANDLE to a process."
 847   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 848          (command
 849           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 850     (mm-with-unibyte-buffer
 851       (mm-insert-part handle)
 852       (shell-command-on-region (point-min) (point-max) command nil))))
 853
 854 (defun mm-interactively-view-part (handle)
 855   "Display HANDLE using METHOD."
 856   (let* ((type (mm-handle-media-type handle))
 857          (methods
 858           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 859                   (mailcap-mime-info type 'all)))
 860          (method (let ((minibuffer-local-completion-map
 861                         mm-viewer-completion-map))
 862                    (completing-read "Viewer: " methods))))
 863     (when (string= method "")
 864       (error "No method given"))
 865     (if (string-match "^[^% \t]+$" method)
 866         (setq method (concat method " %s")))
 867     (mm-display-external handle method)))
 868
 869 (defun mm-preferred-alternative (handles &optional preferred)
 870   "Say which of HANDLES are preferred."
 871   (let ((prec (if preferred (list preferred)
 872                 (mm-preferred-alternative-precedence handles)))
 873         p h result type handle)
 874     (while (setq p (pop prec))
 875       (setq h handles)
 876       (while h
 877         (setq handle (car h))
 878         (setq type (mm-handle-media-type handle))
 879         (when (and (equal p type)
 880                    (mm-automatic-display-p handle)
 881                    (or (stringp (car handle))
 882                        (not (mm-handle-disposition handle))
 883                        (equal (car (mm-handle-disposition handle))
 884                               "inline")))
 885           (setq result handle
 886                 h nil
 887                 prec nil))
 888         (pop h)))
 889     result))
 890
 891 (defun mm-preferred-alternative-precedence (handles)
 892   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
 893   (let ((seq (nreverse (mapcar #'mm-handle-media-type
 894                                handles))))
 895     (dolist (disc (reverse mm-discouraged-alternatives))
 896       (dolist (elem (copy-sequence seq))
 897         (when (string-match disc elem)
 898           (setq seq (nconc (delete elem seq) (list elem))))))
 899     seq))
 900
 901 (defun mm-get-content-id (id)
 902   "Return the handle(s) referred to by ID."
 903   (cdr (assoc id mm-content-id-alist)))
 904
 905 (defun mm-get-image (handle)
 906   "Return an image instance based on HANDLE."
 907   (let ((type (mm-handle-media-subtype handle))
 908         spec)
 909     ;; Allow some common translations.
 910     (setq type
 911           (cond
 912            ((equal type "x-pixmap")
 913             "xpm")
 914            ((equal type "x-xbitmap")
 915             "xbm")
 916            ((equal type "x-portable-bitmap")
 917             "pbm")
 918            (t type)))
 919     (or (mm-handle-cache handle)
 920         (mm-with-unibyte-buffer
 921           (mm-insert-part handle)
 922           (prog1
 923               (setq spec
 924                     (ignore-errors
 925                      ;; Avoid testing `make-glyph' since W3 may define
 926                      ;; a bogus version of it.
 927                       (if (fboundp 'create-image)
 928                           (create-image (buffer-string) (intern type) 'data-p)
 929                         (cond
 930                          ((equal type "xbm")
 931                           ;; xbm images require special handling, since
 932                           ;; the only way to create glyphs from these
 933                           ;; (without a ton of work) is to write them
 934                           ;; out to a file, and then create a file
 935                           ;; specifier.
 936                           (let ((file (make-temp-name
 937                                        (expand-file-name "emm.xbm"
 938                                                          mm-tmp-directory))))
 939                             (unwind-protect
 940                                 (progn
 941                                   (write-region (point-min) (point-max) file)
 942                                   (make-glyph (list (cons 'x file))))
 943                               (ignore-errors
 944                                (delete-file file)))))
 945                          (t
 946                           (make-glyph
 947                            (vector (intern type) :data (buffer-string))))))))
 948             (mm-handle-set-cache handle spec))))))
 949
 950 (defun mm-image-fit-p (handle)
 951   "Say whether the image in HANDLE will fit the current window."
 952   (let ((image (mm-get-image handle)))
 953     (if (fboundp 'glyph-width)
 954         ;; XEmacs' glyphs can actually tell us about their width, so
 955         ;; lets be nice and smart about them.
 956         (or mm-inline-large-images
 957             (and (< (glyph-width image) (window-pixel-width))
 958                  (< (glyph-height image) (window-pixel-height))))
 959       (let* ((size (image-size image))
 960              (w (car size))
 961              (h (cdr size)))
 962         (or mm-inline-large-images
 963             (and (< h (1- (window-height))) ; Don't include mode line.
 964                  (< w (window-width))))))))
 965
 966 (defun mm-valid-image-format-p (format)
 967   "Say whether FORMAT can be displayed natively by Emacs."
 968   (cond
 969    ;; Handle XEmacs
 970    ((fboundp 'valid-image-instantiator-format-p)
 971     (valid-image-instantiator-format-p format))
 972    ;; Handle Emacs 21
 973    ((fboundp 'image-type-available-p)
 974     (and (display-graphic-p)
 975          (image-type-available-p format)))
 976    ;; Nobody else can do images yet.
 977    (t
 978     nil)))
 979
 980 (defun mm-valid-and-fit-image-p (format handle)
 981   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
 982   (and (mm-valid-image-format-p format)
 983        (mm-image-fit-p handle)))
 984
 985 (defun mm-find-part-by-type (handles type &optional notp recursive)
 986   "Search in HANDLES for part with TYPE.
 987 If NOTP, returns first non-matching part.
 988 If RECURSIVE, search recursively."
 989   (let (handle)
 990     (while handles
 991       (if (and recursive (stringp (caar handles)))
 992           (if (setq handle (mm-find-part-by-type (cdar handles) type
 993                                                  notp recursive))
 994               (setq handles nil))
 995         (if (if notp
 996                 (not (equal (mm-handle-media-type (car handles)) type))
 997               (equal (mm-handle-media-type (car handles)) type))
 998             (setq handle (car handles)
 999                   handles nil)))
1000       (setq handles (cdr handles)))
1001     handle))
1002
1003 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1004   (goto-char (point-min))
1005   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1006                                                                    'boundary)))
1007          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1008          start
1009          (end (save-excursion
1010                 (goto-char (point-max))
1011                 (if (re-search-backward close-delimiter nil t)
1012                     (match-beginning 0)
1013                   (point-max))))
1014          result)
1015     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1016     (while (and (not result)
1017                 (re-search-forward boundary end t))
1018       (goto-char (match-beginning 0))
1019       (when start
1020         (save-excursion
1021           (save-restriction
1022             (narrow-to-region start (1- (point)))
1023             (when (let ((ctl (ignore-errors
1024                                (mail-header-parse-content-type
1025                                 (mail-fetch-field "content-type")))))
1026                     (if notp
1027                         (not (equal (car ctl) type))
1028                       (equal (car ctl) type)))
1029               (setq result (buffer-substring (point-min) (point-max)))))))
1030       (forward-line 1)
1031       (setq start (point)))
1032     (when (and (not result) start)
1033       (save-excursion
1034         (save-restriction
1035           (narrow-to-region start end)
1036           (when (let ((ctl (ignore-errors
1037                              (mail-header-parse-content-type
1038                               (mail-fetch-field "content-type")))))
1039                   (if notp
1040                       (not (equal (car ctl) type))
1041                     (equal (car ctl) type)))
1042             (setq result (buffer-substring (point-min) (point-max)))))))
1043     result))
1044
1045 (defvar mm-security-handle nil)
1046
1047 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1048   ;; HANDLE could be a CTL.
1049   (if handle
1050       (put-text-property 0 (length (car handle)) parameter value
1051                          (car handle))))
1052
1053 (defun mm-possibly-verify-or-decrypt (parts ctl)
1054   (let ((subtype (cadr (split-string (car ctl) "/")))
1055         (mm-security-handle ctl) ;; (car CTL) is the type.
1056         protocol func functest)
1057     (cond
1058      ((equal subtype "signed")
1059       (unless (and (setq protocol
1060                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1061                    (not (equal protocol "multipart/mixed")))
1062         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1063         (let ((protocols mm-verify-function-alist))
1064           (while protocols
1065             (if (and (or (not (setq functest (nth 3 (car protocols))))
1066                          (funcall functest parts ctl))
1067                      (mm-find-part-by-type parts (caar protocols) nil t))
1068                 (setq protocol (caar protocols)
1069                       protocols nil)
1070               (setq protocols (cdr protocols))))))
1071       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1072       (if (cond
1073            ((eq mm-verify-option 'never) nil)
1074            ((eq mm-verify-option 'always) t)
1075            ((eq mm-verify-option 'known)
1076             (and func
1077                  (or (not (setq functest
1078                                 (nth 3 (assoc protocol
1079                                               mm-verify-function-alist))))
1080                      (funcall functest parts ctl))))
1081            (t (y-or-n-p
1082                (format "Verify signed (%s) part? "
1083                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1084                            (format "protocol=%s" protocol))))))
1085           (save-excursion
1086             (if func
1087                 (funcall func parts ctl)
1088               (mm-set-handle-multipart-parameter
1089                mm-security-handle 'gnus-details
1090                (format "Unknown sign protocol (%s)" protocol))))))
1091      ((equal subtype "encrypted")
1092       (unless (setq protocol
1093                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1094         ;; The message is broken.
1095         (let ((parts parts))
1096           (while parts
1097             (if (assoc (mm-handle-media-type (car parts))
1098                        mm-decrypt-function-alist)
1099                 (setq protocol (mm-handle-media-type (car parts))
1100                       parts nil)
1101               (setq parts (cdr parts))))))
1102       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1103       (if (cond
1104            ((eq mm-decrypt-option 'never) nil)
1105            ((eq mm-decrypt-option 'always) t)
1106            ((eq mm-decrypt-option 'known)
1107             (and func
1108                  (or (not (setq functest
1109                                 (nth 3 (assoc protocol
1110                                               mm-decrypt-function-alist))))
1111                      (funcall functest parts ctl))))
1112            (t (y-or-n-p
1113                (format "Decrypt (%s) part? "
1114                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1115                            (format "protocol=%s" protocol))))))
1116           (save-excursion
1117             (if func
1118                 (setq parts (funcall func parts ctl))
1119               (mm-set-handle-multipart-parameter
1120                mm-security-handle 'gnus-details
1121                (format "Unknown encrypt protocol (%s)" protocol))))))
1122      (t nil))
1123     parts))
1124
1125 (defun mm-multiple-handles (handles)
1126    (and (listp (car handles))
1127         (> (length handles) 1)))
1128
1129 (defun mm-merge-handles (handles1 handles2)
1130   (append
1131    (if (listp (car handles1))
1132        handles1
1133      (list handles1))
1134    (if (listp (car handles2))
1135        handles2
1136      (list handles2))))
1137
1138 (provide 'mm-decode)
1139
1140 ;;; mm-decode.el ends here