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 (assoc "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              process file buffer)
 352         ;; We create a private sub-directory where we store our files.
 353         (make-directory dir)
 354         (set-file-modes dir 448)
 355         (if filename
 356             (setq file (expand-file-name (file-name-nondirectory filename)
 357                                          dir))
 358           (setq file (make-temp-name (expand-file-name "mm." dir))))
 359         (write-region (point-min) (point-max) file nil 'nomesg)
 360         (message "Viewing with %s" method)
 361         (unwind-protect
 362             (setq process
 363                   (if needsterm
 364                       (start-process "*display*" nil
 365                                      "xterm"
 366                                      "-e" shell-file-name "-c"
 367                                      (mm-mailcap-command
 368                                       method file (mm-handle-type handle)))
 369                     (start-process "*display*"
 370                                    (setq buffer (generate-new-buffer "*mm*"))
 371                                    shell-file-name
 372                                    "-c"
 373                                    (mm-mailcap-command
 374                                     method file (mm-handle-type handle)))))
 375           (mm-handle-set-undisplayer handle (cons file buffer)))
 376         (message "Displaying %s..." (format method file))))))
 377
 378 (defun mm-mailcap-command (method file type-list)
 379   (let ((ctl (cdr type-list))
 380         (beg 0)
 381         out sub total)
 382     (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t" method beg)
 383       (push (substring method beg (match-beginning 0)) out)
 384       (setq beg (match-end 0)
 385             total (match-string 0 method)
 386             sub (match-string 1 method))
 387       (cond
 388        ((string= total "%s")
 389         (push (mm-quote-arg file) out))
 390        ((string= total "%t")
 391         (push (mm-quote-arg (car type-list)) out))
 392        (t
 393         (push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
 394     (push (substring method beg (length method)) out)
 395     (mapconcat 'identity (nreverse out) "")))
 396
 397 (defun mm-remove-parts (handles)
 398   "Remove the displayed MIME parts represented by HANDLE."
 399   (if (and (listp handles)
 400            (bufferp (car handles)))
 401       (mm-remove-part handles)
 402     (let (handle)
 403       (while (setq handle (pop handles))
 404         (cond
 405          ((stringp handle)
 406           )
 407          ((and (listp handle)
 408                (stringp (car handle)))
 409           (mm-remove-parts (cdr handle)))
 410          (t
 411           (mm-remove-part handle)))))))
 412
 413 (defun mm-destroy-parts (handles)
 414   "Remove the displayed MIME parts represented by HANDLE."
 415   (if (and (listp handles)
 416            (bufferp (car handles)))
 417       (mm-destroy-part handles)
 418     (let (handle)
 419       (while (setq handle (pop handles))
 420         (cond
 421          ((stringp handle)
 422           )
 423          ((and (listp handle)
 424                (stringp (car handle)))
 425           (mm-destroy-parts (cdr handle)))
 426          (t
 427           (mm-destroy-part handle)))))))
 428
 429 (defun mm-remove-part (handle)
 430   "Remove the displayed MIME part represented by HANDLE."
 431   (when (listp handle)
 432     (let ((object (mm-handle-undisplayer handle)))
 433       (ignore-errors
 434         (cond
 435          ;; Internally displayed part.
 436          ((mm-annotationp object)
 437           (delete-annotation object))
 438          ((or (functionp object)
 439               (and (listp object)
 440                    (eq (car object) 'lambda)))
 441           (funcall object))
 442          ;; Externally displayed part.
 443          ((consp object)
 444           (ignore-errors (delete-file (car object)))
 445           (ignore-errors (delete-directory (file-name-directory (car object))))
 446           (ignore-errors (kill-buffer (cdr object))))
 447          ((bufferp object)
 448           (when (buffer-live-p object)
 449             (kill-buffer object)))))
 450       (mm-handle-set-undisplayer handle nil))))
 451
 452 (defun mm-display-inline (handle)
 453   (let* ((type (mm-handle-media-type handle))
 454          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 455     (funcall function handle)
 456     (goto-char (point-min))))
 457
 458 (defun mm-assoc-string-match (alist type)
 459   (dolist (elem alist)
 460     (when (string-match (car elem) type)
 461       (return elem))))
 462
 463 (defun mm-inlinable-p (handle)
 464   "Say whether HANDLE can be displayed inline."
 465   (let ((alist mm-inline-media-tests)
 466         (type (mm-handle-media-type handle))
 467         test)
 468     (while alist
 469       (when (string-match (caar alist) type)
 470         (setq test (caddar alist)
 471               alist nil)
 472         (setq test (funcall test handle)))
 473       (pop alist))
 474     test))
 475
 476 (defun mm-automatic-display-p (handle)
 477   "Say whether the user wants HANDLE to be displayed automatically."
 478   (let ((methods mm-automatic-display)
 479         (type (mm-handle-media-type handle))
 480         method result)
 481     (while (setq method (pop methods))
 482       (when (and (not (mm-inline-override-p handle))
 483                  (string-match method type)
 484                  (mm-inlinable-p handle))
 485         (setq result t
 486               methods nil)))
 487     result))
 488
 489 (defun mm-inlined-p (handle)
 490   "Say whether the user wants HANDLE to be displayed automatically."
 491   (let ((methods mm-inlined-types)
 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-attachment-override-p (handle)
 503   "Say whether HANDLE should have attachment behavior overridden."
 504   (let ((types mm-attachment-override-types)
 505         (type (mm-handle-media-type handle))
 506         ty)
 507     (catch 'found
 508       (while (setq ty (pop types))
 509         (when (and (string-match ty type)
 510                    (mm-inlinable-p handle))
 511           (throw 'found t))))))
 512
 513 (defun mm-inline-override-p (handle)
 514   "Say whether HANDLE should have inline behavior overridden."
 515   (let ((types mm-inline-override-types)
 516         (type (mm-handle-media-type handle))
 517         ty)
 518     (catch 'found
 519       (while (setq ty (pop types))
 520         (when (string-match ty type)
 521           (throw 'found t))))))
 522
 523 (defun mm-inline-override-p (handle)
 524   "Say whether HANDLE should have inline behavior overridden."
 525   (let ((types mm-inline-override-types)
 526         (type (mm-handle-media-type handle))
 527         ty)
 528     (catch 'found
 529       (while (setq ty (pop types))
 530         (when (string-match ty type)
 531           (throw 'found t))))))
 532
 533 (defun mm-automatic-external-display-p (type)
 534   "Return the user-defined method for TYPE."
 535   (let ((methods mm-automatic-external-display)
 536         method result)
 537     (while (setq method (pop methods))
 538       (when (string-match method type)
 539         (setq result t
 540               methods nil)))
 541     result))
 542
 543 (defun mm-destroy-part (handle)
 544   "Destroy the data structures connected to HANDLE."
 545   (when (listp handle)
 546     (mm-remove-part handle)
 547     (when (buffer-live-p (mm-handle-buffer handle))
 548       (kill-buffer (mm-handle-buffer handle)))))
 549
 550 (defun mm-handle-displayed-p (handle)
 551   "Say whether HANDLE is displayed or not."
 552   (mm-handle-undisplayer handle))
 553
 554 ;;;
 555 ;;; Functions for outputting parts
 556 ;;;
 557
 558 (defun mm-get-part (handle)
 559   "Return the contents of HANDLE as a string."
 560   (mm-with-unibyte-buffer
 561     (mm-insert-part handle)
 562     (buffer-string)))
 563
 564 (defun mm-insert-part (handle)
 565   "Insert the contents of HANDLE in the current buffer."
 566   (let ((cur (current-buffer)))
 567     (save-excursion
 568       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 569           (with-temp-buffer
 570             (insert-buffer-substring (mm-handle-buffer handle))
 571             (mm-decode-content-transfer-encoding
 572              (mm-handle-encoding handle)
 573              (mm-handle-media-type handle))
 574             (let ((temp (current-buffer)))
 575               (set-buffer cur)
 576               (insert-buffer-substring temp)))
 577         (mm-with-unibyte-buffer
 578           (insert-buffer-substring (mm-handle-buffer handle))
 579           (mm-decode-content-transfer-encoding
 580            (mm-handle-encoding handle)
 581            (mm-handle-media-type handle))
 582           (let ((temp (current-buffer)))
 583             (set-buffer cur)
 584             (insert-buffer-substring temp)))))))
 585
 586 (defvar mm-default-directory nil)
 587
 588 (defun mm-save-part (handle)
 589   "Write HANDLE to a file."
 590   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 591          (filename (mail-content-type-get
 592                     (mm-handle-disposition handle) 'filename))
 593          file)
 594     (when filename
 595       (setq filename (file-name-nondirectory filename)))
 596     (setq file
 597           (read-file-name "Save MIME part to: "
 598                           (expand-file-name
 599                            (or filename name "")
 600                            (or mm-default-directory default-directory))))
 601     (setq mm-default-directory (file-name-directory file))
 602     (when (or (not (file-exists-p file))
 603               (yes-or-no-p (format "File %s already exists; overwrite? "
 604                                    file)))
 605       (mm-save-part-to-file handle file))))
 606
 607 (defun mm-save-part-to-file (handle file)
 608   (mm-with-unibyte-buffer
 609     (mm-insert-part handle)
 610     (let ((coding-system-for-write 'binary)
 611           ;; Don't re-compress .gz & al.  Arguably we should make
 612           ;; `file-name-handler-alist' nil, but that would chop
 613           ;; ange-ftp, which is reasonable to use here.
 614           (inhibit-file-name-operation 'write-region)
 615           (inhibit-file-name-handlers
 616            (if (equal (mm-handle-media-type handle)
 617                       "application/octet-stream")
 618                (cons 'jka-compr-handler inhibit-file-name-handlers)
 619              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