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