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