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