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-automatic-external-display-p (type)
 524   "Return the user-defined method for TYPE."
 525   (let ((methods mm-automatic-external-display)
 526         method result)
 527     (while (setq method (pop methods))
 528       (when (string-match method type)
 529         (setq result t
 530               methods nil)))
 531     result))
 532
 533 (defun mm-destroy-part (handle)
 534   "Destroy the data structures connected to HANDLE."
 535   (when (listp handle)
 536     (mm-remove-part handle)
 537     (when (buffer-live-p (mm-handle-buffer handle))
 538       (kill-buffer (mm-handle-buffer handle)))))
 539
 540 (defun mm-handle-displayed-p (handle)
 541   "Say whether HANDLE is displayed or not."
 542   (mm-handle-undisplayer handle))
 543
 544 ;;;
 545 ;;; Functions for outputting parts
 546 ;;;
 547
 548 (defun mm-get-part (handle)
 549   "Return the contents of HANDLE as a string."
 550   (mm-with-unibyte-buffer
 551     (mm-insert-part handle)
 552     (buffer-string)))
 553
 554 (defun mm-insert-part (handle)
 555   "Insert the contents of HANDLE in the current buffer."
 556   (let ((cur (current-buffer)))
 557     (save-excursion
 558       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 559           (with-temp-buffer
 560             (insert-buffer-substring (mm-handle-buffer handle))
 561             (mm-decode-content-transfer-encoding
 562              (mm-handle-encoding handle)
 563              (mm-handle-media-type handle))
 564             (let ((temp (current-buffer)))
 565               (set-buffer cur)
 566               (insert-buffer-substring temp)))
 567         (mm-with-unibyte-buffer
 568           (insert-buffer-substring (mm-handle-buffer handle))
 569           (mm-decode-content-transfer-encoding
 570            (mm-handle-encoding handle)
 571            (mm-handle-media-type handle))
 572           (let ((temp (current-buffer)))
 573             (set-buffer cur)
 574             (insert-buffer-substring temp)))))))
 575
 576 (defvar mm-default-directory nil)
 577
 578 (defun mm-save-part (handle)
 579   "Write HANDLE to a file."
 580   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 581          (filename (mail-content-type-get
 582                     (mm-handle-disposition handle) 'filename))
 583          file)
 584     (when filename
 585       (setq filename (file-name-nondirectory filename)))
 586     (setq file
 587           (read-file-name "Save MIME part to: "
 588                           (expand-file-name
 589                            (or filename name "")
 590                            (or mm-default-directory default-directory))))
 591     (setq mm-default-directory (file-name-directory file))
 592     (when (or (not (file-exists-p file))
 593               (yes-or-no-p (format "File %s already exists; overwrite? "
 594                                    file)))
 595       (mm-save-part-to-file handle file))))
 596
 597 (defun mm-save-part-to-file (handle file)
 598   (mm-with-unibyte-buffer
 599     (mm-insert-part handle)
 600     (let ((coding-system-for-write 'binary)
 601           ;; Don't re-compress .gz & al.  Arguably we should make
 602           ;; `file-name-handler-alist' nil, but that would chop
 603           ;; ange-ftp, which is reasonable to use here.
 604           (inhibit-file-name-operation 'write-region)
 605           (inhibit-file-name-handlers
 606            (if (equal (mm-handle-media-type handle)
 607                       "application/octet-stream")
 608                (cons 'jka-compr-handler inhibit-file-name-handlers)
 609              inhibit-file-name-handlers)))
 610       (write-region (point-min) (point-max) file))))
 611
 612 (defun mm-pipe-part (handle)
 613   "Pipe HANDLE to a process."
 614   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 615          (command
 616           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 617     (mm-with-unibyte-buffer
 618       (mm-insert-part handle)
 619       (shell-command-on-region (point-min) (point-max) command nil))))
 620
 621 (defun mm-interactively-view-part (handle)
 622   "Display HANDLE using METHOD."
 623   (let* ((type (mm-handle-media-type handle))
 624          (methods
 625           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 626                   (mailcap-mime-info type 'all)))
 627          (method (completing-read "Viewer: " methods)))
 628     (mm-display-external (copy-sequence handle) method)))
 629
 630 (defun mm-preferred-alternative (handles &optional preferred)
 631   "Say which of HANDLES are preferred."
 632   (let ((prec (if preferred (list preferred)
 633                 (mm-preferred-alternative-precedence handles)))
 634         p h result type handle)
 635     (while (setq p (pop prec))
 636       (setq h handles)
 637       (while h
 638         (setq handle (car h))
 639         (setq type (mm-handle-media-type handle))
 640         (when (and (equal p type)
 641                    (mm-automatic-display-p handle)
 642                    (or (stringp (car handle))
 643                        (not (mm-handle-disposition handle))
 644                        (equal (car (mm-handle-disposition handle))
 645                               "inline")))
 646           (setq result handle
 647                 h nil
 648                 prec nil))
 649         (pop h)))
 650     result))
 651
 652 (defun mm-preferred-alternative-precedence (handles)
 653   "Return the precedence based on HANDLES and mm-discouraged-alternatives."
 654   (let ((seq (nreverse (mapcar (lambda (h)
 655                                  (mm-handle-media-type h))
 656                                handles))))
 657     (dolist (disc (reverse mm-discouraged-alternatives))
 658       (dolist (elem (copy-sequence seq))
 659         (when (string-match disc elem)
 660           (setq seq (nconc (delete elem seq) (list elem))))))
 661     seq))
 662
 663 (defun mm-get-content-id (id)
 664   "Return the handle(s) referred to by ID."
 665   (cdr (assoc id mm-content-id-alist)))
 666
 667 (defun mm-get-image (handle)
 668   "Return an image instance based on HANDLE."
 669   (let ((type (mm-handle-media-subtype handle))
 670         spec)
 671     ;; Allow some common translations.
 672     (setq type
 673           (cond
 674            ((equal type "x-pixmap")
 675             "xpm")
 676            ((equal type "x-xbitmap")
 677             "xbm")
 678            (t type)))
 679     (or (mm-handle-cache handle)
 680         (mm-with-unibyte-buffer
 681           (mm-insert-part handle)
 682           (prog1
 683               (setq spec
 684                     (ignore-errors
 685                       (cond
 686                        ((equal type "xbm")
 687                         ;; xbm images require special handling, since
 688                         ;; the only way to create glyphs from these
 689                         ;; (without a ton of work) is to write them
 690                         ;; out to a file, and then create a file
 691                         ;; specifier.
 692                         (let ((file (make-temp-name
 693                                      (expand-file-name "emm.xbm"
 694                                                        mm-tmp-directory))))
 695                           (unwind-protect
 696                               (progn
 697                                 (write-region (point-min) (point-max) file)
 698                                 (make-glyph (list (cons 'x file))))
 699                             (ignore-errors
 700                               (delete-file file)))))
 701                        (t
 702                         (make-glyph
 703                          (vector (intern type) :data (buffer-string)))))))
 704             (mm-handle-set-cache handle spec))))))
 705
 706 (defun mm-image-fit-p (handle)
 707   "Say whether the image in HANDLE will fit the current window."
 708   (let ((image (mm-get-image handle)))
 709     (or mm-inline-large-images
 710         (and (< (glyph-width image) (window-pixel-width))
 711              (< (glyph-height image) (window-pixel-height))))))
 712
 713 (defun mm-valid-image-format-p (format)
 714   "Say whether FORMAT can be displayed natively by Emacs."
 715   (and (fboundp 'valid-image-instantiator-format-p)
 716        (valid-image-instantiator-format-p format)))
 717
 718 (defun mm-valid-and-fit-image-p (format handle)
 719   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
 720   (and window-system
 721        (mm-valid-image-format-p format)
 722        (mm-image-fit-p handle)))
 723
 724 (provide 'mm-decode)
 725
 726 ;; mm-decode.el ends here