cgit.sxemacs.org Git - gnus/blob - lisp/mm-decode.el

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