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