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