git.chise.org Git - elisp/gnus.git-/blob - lisp/mm-decode.el

   1 ;;; mm-decode.el --- Functions for decoding MIME things
   2 ;; Copyright (C) 1998, 1999, 2000 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 'mm-mailcap)
  29 (require 'mm-bodies)
  30 (require 'mmgnus)
  31
  32 (defvar mm-xemacs-p (string-match "XEmacs" (emacs-version)))
  33
  34 (defgroup mime-display ()
  35   "Display of MIME in mail and news articles."
  36   :link '(custom-manual "(emacs-mime)Customization")
  37   :group 'mail
  38   :group 'news)
  39
  40 ;;; Convenience macros.
  41
  42 (defsubst mm-handle-p (handle)
  43   (memq (luna-class-name handle)
  44         '(mmgnus-entity mime-gnus-entity)))
  45 (defalias 'mm-handle-body 'mmgnus-entity-body-internal)
  46 (defalias 'mm-handle-set-body 'mmgnus-entity-set-body-internal)
  47 (defsubst mm-handle-multipart/mixed-p (handle)
  48   (string= (mime-entity-content-type-internal handle) "multipart/mixed"))
  49 (defalias 'mm-handle-type 'mime-entity-content-type-internal)
  50 (defsubst mm-handle-type-parameters (handle)
  51   (mime-content-type-parameters (mm-handle-type handle)))
  52 (defsubst mm-handle-media-type (handle)
  53   (mime-type/subtype-string
  54    (mime-content-type-primary-type (mm-handle-type handle))
  55    (mime-content-type-subtype (mm-handle-type handle))))
  56 (defsubst mm-handle-media-supertype (handle)
  57   (and (mime-content-type-primary-type (mm-handle-type handle))
  58        (symbol-name (mime-content-type-primary-type (mm-handle-type handle)))))
  59 (defsubst mm-handle-media-subtype (handle)
  60   (and (mime-content-type-subtype (mm-handle-type handle))
  61        (symbol-name (mime-content-type-subtype (mm-handle-type handle)))))
  62 (defsubst mm-handle-encoding (handle)
  63   (and (mime-entity-encoding-internal handle)
  64        (intern (mime-entity-encoding-internal handle))))
  65 (defalias 'mm-handle-child 'mime-entity-children-internal)
  66 (defalias 'mm-handle-set-child 'mime-entity-set-children-internal)
  67 (defalias 'mm-handle-parent 'mime-entity-parent-internal)
  68 (defalias 'mm-handle-set-parent 'mime-entity-set-parent-internal)
  69 (defalias 'mm-handle-undisplayer 'mmgnus-entity-undisplayer-internal)
  70 (defalias 'mm-handle-set-undisplayer 'mmgnus-entity-set-undisplayer-internal)
  71 (defalias 'mm-handle-disposition 'mime-entity-content-disposition-internal)
  72 (defsubst mm-handle-disposition-type (handle)
  73   (mime-content-disposition-type (mm-handle-disposition handle)))
  74 (defsubst mm-handle-disposition-parameters (handle)
  75   (mime-content-disposition-parameters (mm-handle-disposition handle)))
  76 (defalias 'mm-handle-description 'mmgnus-entity-content-description-internal)
  77 (defalias 'mm-handle-cache 'mmgnus-entity-cache-internal)
  78 (defalias 'mm-handle-set-cache 'mmgnus-entity-set-cache-internal)
  79 (defalias 'mm-handle-id 'mmgnus-entity-content-id-internal)
  80 (defalias 'mm-handle-header 'mmgnus-entity-header-internal)
  81 (defalias 'mm-handle-set-header 'mmgnus-entity-set-header-internal)
  82 (defsubst mm-make-handle (&optional parent body type encoding undisplayer
  83                                     disposition description cache
  84                                     id child header)
  85   (luna-make-entity 'mmgnus-entity
  86                     :parent parent
  87                     :body body
  88                     :content-type type
  89                     :encoding (if (and encoding
  90                                        (symbolp encoding))
  91                                   (symbol-name encoding)
  92                                 encoding)
  93                     :undisplayer undisplayer
  94                     :content-disposition disposition
  95                     :content-description description
  96                     :cache cache
  97                     :content-id id
  98                     :children child
  99                     :header header))
 100
 101 (defcustom mm-inline-media-tests
 102   '(("image/jpeg"
 103      mm-inline-image
 104      (lambda (handle)
 105        (mm-valid-and-fit-image-p 'jpeg handle)))
 106     ("image/png"
 107      mm-inline-image
 108      (lambda (handle)
 109        (mm-valid-and-fit-image-p 'png handle)))
 110     ("image/gif"
 111      mm-inline-image
 112      (lambda (handle)
 113        (mm-valid-and-fit-image-p 'gif handle)))
 114     ("image/tiff"
 115      mm-inline-image
 116      (lambda (handle)
 117        (mm-valid-and-fit-image-p 'tiff handle)) )
 118     ("image/xbm"
 119      mm-inline-image
 120      (lambda (handle)
 121        (mm-valid-and-fit-image-p 'xbm handle)))
 122     ("image/x-xbitmap"
 123      mm-inline-image
 124      (lambda (handle)
 125        (mm-valid-and-fit-image-p 'xbm handle)))
 126     ("image/xpm"
 127      mm-inline-image
 128      (lambda (handle)
 129        (mm-valid-and-fit-image-p 'xpm handle)))
 130     ("image/x-pixmap"
 131      mm-inline-image
 132      (lambda (handle)
 133        (mm-valid-and-fit-image-p 'xpm handle)))
 134     ("image/bmp"
 135      mm-inline-image
 136      (lambda (handle)
 137        (mm-valid-and-fit-image-p 'bmp handle)))
 138     ("text/plain" mm-inline-text identity)
 139     ("text/enriched" mm-inline-text identity)
 140     ("text/richtext" mm-inline-text identity)
 141     ("text/x-patch" mm-display-patch-inline
 142      (lambda (handle)
 143        (locate-library "diff-mode")))
 144     ("text/html"
 145      mm-inline-text
 146      (lambda (handle)
 147        (locate-library "w3")))
 148     ("text/x-vcard"
 149      mm-inline-text
 150      (lambda (handle)
 151        (or (featurep 'vcard)
 152            (locate-library "vcard"))))
 153     ("message/delivery-status" mm-inline-text identity)
 154     ("message/rfc822" mm-inline-message identity)
 155     ("text/.*" mm-inline-text identity)
 156     ("audio/wav" mm-inline-audio
 157      (lambda (handle)
 158        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 159             (device-sound-enabled-p))))
 160     ("audio/au"
 161      mm-inline-audio
 162      (lambda (handle)
 163        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 164             (device-sound-enabled-p))))
 165     ("application/pgp-signature" ignore identity)
 166     ("multipart/alternative" ignore identity)
 167     ("multipart/mixed" ignore identity)
 168     ("multipart/related" ignore identity))
 169   "Alist of media types/tests saying whether types can be displayed inline."
 170   :type '(repeat (list (string :tag "MIME type")
 171                        (function :tag "Display function")
 172                        (function :tag "Display test")))
 173   :group 'mime-display)
 174
 175 (defcustom mm-inlined-types
 176   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
 177     "application/pgp-signature")
 178   "List of media types that are to be displayed inline."
 179   :type '(repeat string)
 180   :group 'mime-display)
 181
 182 (defcustom mm-automatic-display
 183   '("text/plain" "text/enriched" "text/richtext" "text/html"
 184     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
 185     "message/rfc822" "text/x-patch" "application/pgp-signature")
 186   "A list of MIME types to be displayed automatically."
 187   :type '(repeat string)
 188   :group 'mime-display)
 189
 190 (defcustom mm-attachment-override-types '("text/x-vcard")
 191   "Types to have \"attachment\" ignored if they can be displayed inline."
 192   :type '(repeat string)
 193   :group 'mime-display)
 194
 195 (defcustom mm-inline-override-types nil
 196   "Types to be treated as attachments even if they can be displayed inline."
 197   :type '(repeat string)
 198   :group 'mime-display)
 199
 200 (defcustom mm-automatic-external-display nil
 201   "List of MIME type regexps that will be displayed externally automatically."
 202   :type '(repeat string)
 203   :group 'mime-display)
 204
 205 (defcustom mm-discouraged-alternatives nil
 206   "List of MIME types that are discouraged when viewing multipart/alternative.
 207 Viewing agents are supposed to view the last possible part of a message,
 208 as that is supposed to be the richest.  However, users may prefer other
 209 types instead, and this list says what types are most unwanted.  If,
 210 for instance, text/html parts are very unwanted, and text/richtech are
 211 somewhat unwanted, then the value of this variable should be set
 212 to:
 213
 214  (\"text/html\" \"text/richtext\")"
 215   :type '(repeat string)
 216   :group 'mime-display)
 217
 218 (defvar mm-tmp-directory
 219   (cond ((fboundp 'temp-directory) (temp-directory))
 220         ((boundp 'temporary-file-directory) temporary-file-directory)
 221         ("/tmp/"))
 222   "Where mm will store its temporary files.")
 223
 224 (defcustom mm-inline-large-images nil
 225   "If non-nil, then all images fit in the buffer."
 226   :type 'boolean
 227   :group 'mime-display)
 228
 229 ;;; Internal variables.
 230
 231 (defvar mm-dissection-list nil)
 232 (defvar mm-last-shell-command "")
 233 (defvar mm-content-id-alist nil)
 234
 235 ;;; The functions.
 236
 237 (defun mm-dissect-buffer-header (handle &optional no-strict-mime)
 238   (save-excursion
 239     (unless handle
 240       (setq handle (mm-make-handle)))
 241     (save-restriction
 242       (mail-narrow-to-head)
 243       (mmgnus-entity-set-header-internal handle (buffer-string)))
 244     (let (ctl type cte cd description id result header-string header-end)
 245       (when (or no-strict-mime
 246                 (mime-entity-fetch-field handle "mime-version"))
 247           (setq ctl (mime-entity-fetch-field handle "content-type")
 248                 ctl (ignore-errors (mail-header-parse-content-type ctl))
 249                 cte (mime-entity-fetch-field handle
 250                                              "content-transfer-encoding")
 251                 cd (mime-entity-fetch-field handle
 252                                             "content-disposition")
 253                 description (mime-entity-fetch-field handle
 254                                                      "content-description")
 255                 id (mime-entity-fetch-field handle "content-id")))
 256       (unless ctl
 257         (setq ctl (mail-header-parse-content-type "text/plain")))
 258       (setq cte (and cte (downcase (mail-header-remove-whitespace
 259                                     (mail-header-remove-comments
 260                                      cte))))
 261             cd (and cd (ignore-errors
 262                          (mail-header-parse-content-disposition cd))))
 263       (mime-entity-set-content-type handle ctl)
 264       (mime-entity-set-encoding handle cte)
 265       (mime-entity-set-content-disposition-internal handle cd)
 266       (mmgnus-entity-set-content-description-internal handle description)
 267       (when id
 268         (when (string-match " *<\\(.*\\)> *" id)
 269           (setq id (match-string 1 id)))
 270         (mmgnus-entity-set-content-id-internal handle id))
 271       handle)))
 272
 273 (defun mm-dissect-buffer (handle &optional no-strict-mime)
 274   "Dissect the current buffer and return a list of MIME handles."
 275   (save-excursion
 276     (let* ((result (mm-dissect-buffer-header handle no-strict-mime))
 277            (ctl (mime-entity-content-type-internal result))
 278            (type (mime-content-type-primary-type ctl)))
 279       (cond
 280        ((and (eq gnus-mime-display-part-function
 281                  'gnus-mime-display-part-with-mime-view)
 282              (eq type 'message))
 283         (if (eq (mime-content-type-subtype ctl) 'partial)
 284             (mm-dissect-singlepart result ctl no-strict-mime)
 285           (mm-dissect-message result ctl)))
 286        ((eq type 'multipart)
 287         (mm-dissect-multipart result ctl))
 288        (t
 289         (mm-dissect-singlepart result ctl no-strict-mime)))
 290       (when (mm-handle-id result)
 291         (push (cons (mm-handle-id result) result) mm-content-id-alist))
 292       result)))
 293
 294 (defun mm-dissect-singlepart (handle ctl &optional force)
 295   (mm-handle-set-body handle (mm-copy-to-buffer))
 296   (push (mm-handle-body handle) mm-dissection-list)
 297   handle)
 298
 299 (defun mm-remove-all-parts ()
 300   "Remove all MIME handles."
 301   (interactive)
 302   (mapcar 'mm-remove-part mm-dissection-list)
 303   (setq mm-dissection-list nil))
 304
 305 (defun mm-dissect-message (handle ctl)
 306   (goto-char (point-min))
 307   (save-excursion
 308     (save-restriction
 309       (when (re-search-forward "\n\n" nil t)
 310         (narrow-to-region (point) (point-max))
 311         (let ((part (mm-dissect-buffer nil t)))
 312           (mm-handle-set-parent part handle)
 313           (mm-handle-set-child handle
 314                                (cons part (mm-handle-child handle))))))))
 315
 316 (defun mm-dissect-multipart (handle ctl)
 317   (goto-char (point-min))
 318   (let* ((node-id (and handle (mime-entity-node-id-internal handle)))
 319          (this-node 0)
 320          (boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 321          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 322         start parts
 323         (end (save-excursion
 324                (goto-char (point-max))
 325                (if (re-search-backward close-delimiter nil t)
 326                    (match-beginning 0)
 327                  (point-max)))))
 328     (while (search-forward boundary end t)
 329       (goto-char (match-beginning 0))
 330       (when start
 331         (save-excursion
 332           (save-restriction
 333             (narrow-to-region start (point))
 334             (let ((part (mm-make-handle handle nil nil nil nil nil
 335                                         nil nil nil nil nil)))
 336               (mime-entity-set-node-id-internal part (cons this-node node-id))
 337               (setq this-node (1+ this-node))
 338               (mm-dissect-buffer part t)
 339               (setq parts (cons part parts))))))
 340       (forward-line 2)
 341       (setq start (point)))
 342     (when start
 343       (save-excursion
 344         (save-restriction
 345           (narrow-to-region start end)
 346           (let ((part (mm-make-handle handle nil nil nil nil nil
 347                                       nil nil nil nil nil)))
 348             (mime-entity-set-node-id-internal part (cons this-node node-id))
 349             (mm-dissect-buffer part t)
 350             (setq parts (cons part parts))))))
 351     (mm-handle-set-child handle (nreverse parts))
 352     handle))
 353
 354 (defun mm-copy-to-buffer ()
 355   "Copy the contents of the current buffer to a fresh buffer."
 356   (save-excursion
 357     (let ((obuf (current-buffer))
 358           beg)
 359       (goto-char (point-min))
 360       (search-forward-regexp "^\n" nil t)
 361       (setq beg (point))
 362       (set-buffer (generate-new-buffer " *mm*"))
 363       (mm-disable-multibyte)
 364       (insert-buffer-substring obuf beg)
 365       (current-buffer))))
 366
 367 (defun mm-display-part (handle &optional no-default)
 368   "Display the MIME part represented by HANDLE.
 369 Returns nil if the part is removed; inline if displayed inline;
 370 external if displayed external."
 371   (save-excursion
 372     (mm-mailcap-parse-mailcaps)
 373     (if (mm-handle-displayed-p handle)
 374         (mm-remove-part handle)
 375       (let* ((type (mm-handle-media-type handle))
 376              (method (mm-mailcap-mime-info type)))
 377         (if (mm-inlined-p handle)
 378             (progn
 379               (forward-line 1)
 380               (mm-display-inline handle)
 381               'inline)
 382           (when (or method
 383                     (not no-default))
 384             (if (and (not method)
 385                      (equal "text" (mm-handle-media-subtype handle)))
 386                 (progn
 387                   (forward-line 1)
 388                   (mm-insert-inline handle (mm-get-part handle))
 389                   'inline)
 390               (mm-display-external
 391                handle (or method 'mm-mailcap-save-binary-file)))))))))
 392
 393 (defun mm-display-external (handle method)
 394   "Display HANDLE using METHOD."
 395   (let ((outbuf (current-buffer)))
 396     (mm-with-unibyte-buffer
 397       (if (functionp method)
 398           (let ((cur (current-buffer)))
 399             (if (eq method 'mm-mailcap-save-binary-file)
 400                 (progn
 401                   (set-buffer (generate-new-buffer "*mm*"))
 402                   (setq method nil))
 403               (mm-insert-part handle)
 404               (let ((win (get-buffer-window cur t)))
 405                 (when win
 406                   (select-window win)))
 407               (switch-to-buffer (generate-new-buffer "*mm*")))
 408             (buffer-disable-undo)
 409             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 410             (insert-buffer-substring cur)
 411             (message "Viewing with %s" method)
 412             (let ((mm (current-buffer))
 413                   (non-viewer (assq 'non-viewer
 414                                     (mm-mailcap-mime-info
 415                                      (mm-handle-media-type handle) t))))
 416               (unwind-protect
 417                   (if method
 418                       (funcall method)
 419                     (mm-save-part handle))
 420                 (when (and (not non-viewer)
 421                            method)
 422                   (mm-handle-set-undisplayer handle mm)))))
 423         ;; The function is a string to be executed.
 424         (mm-insert-part handle)
 425         (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 426                (filename (mail-content-type-get
 427                           (mm-handle-disposition handle) 'filename))
 428                (mime-info (mm-mailcap-mime-info
 429                            (mm-handle-media-type handle) t))
 430                (needsterm (or (assoc "needsterm" mime-info)
 431                               (assoc "needsterminal" mime-info)))
 432                (copiousoutput (assoc "copiousoutput" mime-info))
 433                file buffer)
 434           ;; We create a private sub-directory where we store our files.
 435           (make-directory dir)
 436           (set-file-modes dir 448)
 437           (if filename
 438               (setq file (expand-file-name (file-name-nondirectory filename)
 439                                            dir))
 440             (setq file (make-temp-name (expand-file-name "mm." dir))))
 441           (let ((coding-system-for-write mm-binary-coding-system))
 442             (write-region (point-min) (point-max) file nil 'nomesg))
 443           (message "Viewing with %s" method)
 444           (cond (needsterm
 445                  (unwind-protect
 446                      (start-process "*display*" nil
 447                                     "xterm"
 448                                     "-e" shell-file-name
 449                                     shell-command-switch
 450                                     (mm-mailcap-command
 451                                      method file (mm-handle-type handle)))
 452                    (mm-handle-set-undisplayer handle (cons file buffer)))
 453                  (message "Displaying %s..." (format method file))
 454                  'external)
 455                 (copiousoutput
 456                  (with-current-buffer outbuf
 457                    (forward-line 1)
 458                    (mm-insert-inline
 459                     handle
 460                     (unwind-protect
 461                         (progn
 462                           (call-process shell-file-name nil
 463                                         (setq buffer
 464                                               (generate-new-buffer "*mm*"))
 465                                         shell-file-name
 466                                         nil
 467                                         shell-command-switch
 468                                         (mm-mailcap-command
 469                                          method file (mm-handle-type handle)))
 470                           (if (buffer-live-p buffer)
 471                               (save-excursion
 472                                 (set-buffer buffer)
 473                                 (buffer-string))))
 474                       (progn
 475                         (ignore-errors (delete-file file))
 476                         (ignore-errors (delete-directory
 477                                         (file-name-directory file)))
 478                         (ignore-errors (kill-buffer buffer))))))
 479                  'inline)
 480                 (t
 481                  (unwind-protect
 482                      (start-process "*display*"
 483                                     (setq buffer
 484                                           (generate-new-buffer "*mm*"))
 485                                     shell-file-name
 486                                     shell-command-switch
 487                                     (mm-mailcap-command
 488                                      method file (mm-handle-type handle)))
 489                    (mm-handle-set-undisplayer handle (cons file buffer)))
 490                  (message "Displaying %s..." (format method file))
 491                  'external)))))))
 492
 493 (defun mm-mailcap-command (method file type-list)
 494   (let ((ctl (cdr type-list))
 495         (beg 0)
 496         (uses-stdin t)
 497         out sub total)
 498     (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg)
 499       (push (substring method beg (match-beginning 0)) out)
 500       (setq beg (match-end 0)
 501             total (match-string 0 method)
 502             sub (match-string 1 method))
 503       (cond
 504        ((string= total "%%")
 505         (push "%" out))
 506        ((string= total "%s")
 507         (setq uses-stdin nil)
 508         (push (mm-quote-arg file) out))
 509        ((string= total "%t")
 510         (push (mm-quote-arg (car type-list)) out))
 511        (t
 512         (push (mm-quote-arg (or (mime-content-type-parameter sub ctl) ""))
 513               out))))
 514     (push (substring method beg (length method)) out)
 515     (if uses-stdin
 516         (progn
 517           (push "<" out)
 518           (push (mm-quote-arg file) out)))
 519     (mapconcat 'identity (nreverse out) "")))
 520
 521 (defun mm-remove-parts (handles)
 522   "Remove the displayed MIME parts represented by HANDLE."
 523   (cond
 524    ((listp handles)
 525     (let (handle)
 526       (while (setq handle (pop handles))
 527         (mm-remove-parts handle))))
 528    ((mm-handle-child handles)
 529     (mm-remove-parts (mm-handle-child handles))
 530     (mm-remove-part handles))
 531    (t
 532     (mm-remove-part handles))))
 533
 534 (defun mm-destroy-parts (handles)
 535   "Remove the displayed MIME parts represented by HANDLE."
 536   (cond
 537    ((listp handles)
 538     (let (handle)
 539       (while (setq handle (pop handles))
 540         (mm-destroy-parts handle))))
 541    ((mm-handle-child handles)
 542     (mm-destroy-parts (mm-handle-child handles))
 543     (mm-destroy-part handles)
 544     (mm-handle-set-child handles nil))
 545    (t
 546     (mm-destroy-part handles))))
 547
 548 (defun mm-remove-part (handle)
 549   "Remove the displayed MIME part represented by HANDLE."
 550   (when (mm-handle-p handle)
 551     (let ((object (mm-handle-undisplayer handle)))
 552       (ignore-errors
 553         (cond
 554          ;; Internally displayed part.
 555          ((mm-annotationp object)
 556           (delete-annotation object))
 557          ((or (functionp object)
 558               (and (listp object)
 559                    (eq (car object) 'lambda)))
 560           (funcall object))
 561          ;; Externally displayed part.
 562          ((consp object)
 563           (ignore-errors (delete-file (car object)))
 564           (ignore-errors (delete-directory (file-name-directory (car object))))
 565           (ignore-errors (kill-buffer (cdr object))))
 566          ((bufferp object)
 567           (when (buffer-live-p object)
 568             (kill-buffer object)))))
 569       (mm-handle-set-undisplayer handle nil))))
 570
 571 (defun mm-display-inline (handle)
 572   (let* ((type (mm-handle-media-type handle))
 573          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 574     (funcall function handle)
 575     (goto-char (point-min))))
 576
 577 (defun mm-assoc-string-match (alist type)
 578   (dolist (elem alist)
 579     (when (string-match (car elem) type)
 580       (return elem))))
 581
 582 (defun mm-inlinable-p (handle)
 583   "Say whether HANDLE can be displayed inline."
 584   (let ((alist mm-inline-media-tests)
 585         (type (mm-handle-media-type handle))
 586         test)
 587     (while alist
 588       (when (string-match (caar alist) type)
 589         (setq test (caddar alist)
 590               alist nil)
 591         (setq test (funcall test handle)))
 592       (pop alist))
 593     test))
 594
 595 (defun mm-automatic-display-p (handle)
 596   "Say whether the user wants HANDLE to be displayed automatically."
 597   (let ((methods mm-automatic-display)
 598         (type (mm-handle-media-type handle))
 599         method result)
 600     (while (setq method (pop methods))
 601       (when (and (not (mm-inline-override-p handle))
 602                  (string-match method type)
 603                  (mm-inlinable-p handle))
 604         (setq result t
 605               methods nil)))
 606     result))
 607
 608 (defun mm-inlined-p (handle)
 609   "Say whether the user wants HANDLE to be displayed automatically."
 610   (let ((methods mm-inlined-types)
 611         (type (mm-handle-media-type handle))
 612         method result)
 613     (while (setq method (pop methods))
 614       (when (and (not (mm-inline-override-p handle))
 615                  (string-match method type)
 616                  (mm-inlinable-p handle))
 617         (setq result t
 618               methods nil)))
 619     result))
 620
 621 (defun mm-attachment-override-p (handle)
 622   "Say whether HANDLE should have attachment behavior overridden."
 623   (let ((types mm-attachment-override-types)
 624         (type (mm-handle-media-type handle))
 625         ty)
 626     (catch 'found
 627       (while (setq ty (pop types))
 628         (when (and (string-match ty type)
 629                    (mm-inlinable-p handle))
 630           (throw 'found t))))))
 631
 632 (defun mm-inline-override-p (handle)
 633   "Say whether HANDLE should have inline behavior overridden."
 634   (let ((types mm-inline-override-types)
 635         (type (mm-handle-media-type handle))
 636         ty)
 637     (catch 'found
 638       (while (setq ty (pop types))
 639         (when (string-match ty type)
 640           (throw 'found t))))))
 641
 642 (defun mm-automatic-external-display-p (type)
 643   "Return the user-defined method for TYPE."
 644   (let ((methods mm-automatic-external-display)
 645         method result)
 646     (while (setq method (pop methods))
 647       (when (string-match method type)
 648         (setq result t
 649               methods nil)))
 650     result))
 651
 652 (defun mm-destroy-part (handle)
 653   "Destroy the data structures connected to HANDLE."
 654   (when (mm-handle-p handle)
 655     (mm-remove-part handle)
 656     (when (buffer-live-p (mm-handle-body handle))
 657       (kill-buffer (mm-handle-body handle))
 658       (mm-handle-set-body handle nil))))
 659
 660 (defun mm-handle-displayed-p (handle)
 661   "Say whether HANDLE is displayed or not."
 662   (mm-handle-undisplayer handle))
 663
 664 ;;;
 665 ;;; Functions for outputting parts
 666 ;;;
 667
 668 (defun mm-get-part (handle)
 669   "Return the contents of HANDLE as a string."
 670   (mm-with-unibyte-buffer
 671     (mm-insert-part handle)
 672     (buffer-string)))
 673
 674 (defun mm-insert-part (handle)
 675   "Insert the contents of HANDLE in the current buffer."
 676   (let ((cur (current-buffer)))
 677     (save-excursion
 678       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 679           (with-temp-buffer
 680             (insert-buffer-substring (mm-handle-body handle))
 681             (mm-decode-content-transfer-encoding
 682              (mm-handle-encoding handle)
 683              (mm-handle-media-type handle))
 684             (let ((temp (current-buffer)))
 685               (set-buffer cur)
 686               (insert-buffer-substring temp)))
 687         (mm-with-unibyte-buffer
 688           (insert-buffer-substring (mm-handle-body handle))
 689           (mm-decode-content-transfer-encoding
 690            (mm-handle-encoding handle)
 691            (mm-handle-media-type handle))
 692           (let ((temp (current-buffer)))
 693             (set-buffer cur)
 694             (insert-buffer-substring temp)))))))
 695
 696 (defvar mm-default-directory nil)
 697
 698 (defun mm-save-part (handle)
 699   "Write HANDLE to a file."
 700   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 701          (filename (mail-content-type-get
 702                     (mm-handle-disposition handle) 'filename))
 703          file)
 704     (when filename
 705       (setq filename (file-name-nondirectory filename)))
 706     (setq file
 707           (read-file-name "Save MIME part to: "
 708                           (expand-file-name
 709                            (or filename name "")
 710                            (or mm-default-directory default-directory))))
 711     (setq mm-default-directory (file-name-directory file))
 712     (when (or (not (file-exists-p file))
 713               (yes-or-no-p (format "File %s already exists; overwrite? "
 714                                    file)))
 715       (mm-save-part-to-file handle file))))
 716
 717 (defun mm-save-part-to-file (handle file)
 718   (mm-with-unibyte-buffer
 719     (mm-insert-part handle)
 720     (let ((coding-system-for-write 'binary)
 721           ;; Don't re-compress .gz & al.  Arguably we should make
 722           ;; `file-name-handler-alist' nil, but that would chop
 723           ;; ange-ftp, which is reasonable to use here.
 724           (inhibit-file-name-operation 'write-region)
 725           (inhibit-file-name-handlers
 726            (cons 'jka-compr-handler inhibit-file-name-handlers)))
 727       (write-region (point-min) (point-max) file))))
 728
 729 (defun mm-pipe-part (handle)
 730   "Pipe HANDLE to a process."
 731   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 732          (command
 733           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 734     (mm-with-unibyte-buffer
 735       (mm-insert-part handle)
 736       (shell-command-on-region (point-min) (point-max) command nil))))
 737
 738 (defun mm-interactively-view-part (handle)
 739   "Display HANDLE using METHOD."
 740   (let* ((type (mm-handle-media-type handle))
 741          (methods
 742           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 743                   (mm-mailcap-mime-info type 'all)))
 744          (method (completing-read "Viewer: " methods)))
 745     (mm-display-external (copy-sequence handle) method)))
 746
 747 (defun mm-preferred-alternative (handles &optional preferred)
 748   "Say which of HANDLES are preferred."
 749   (let ((prec (if preferred (list preferred)
 750                 (mm-preferred-alternative-precedence handles)))
 751         p h result type handle)
 752     (while (setq p (pop prec))
 753       (setq h handles)
 754       (while h
 755         (setq handle (car h))
 756         (setq type (mm-handle-media-type handle))
 757         (when (and (equal p type)
 758                    (mm-automatic-display-p handle)
 759                    (or (mm-handle-child handle)
 760                        (not (mm-handle-disposition handle))
 761                        (eq (mm-handle-disposition-type handle) 'inline)))
 762           (setq result handle
 763                 h nil
 764                 prec nil))
 765         (pop h)))
 766     result))
 767
 768 (defun mm-preferred-alternative-precedence (handles)
 769   "Return the precedence based on HANDLES and mm-discouraged-alternatives."
 770   (let ((seq (nreverse (mapcar (lambda (h)
 771                                  (mm-handle-media-type h))
 772                                handles))))
 773     (dolist (disc (reverse mm-discouraged-alternatives))
 774       (dolist (elem (copy-sequence seq))
 775         (when (string-match disc elem)
 776           (setq seq (nconc (delete elem seq) (list elem))))))
 777     seq))
 778
 779 (defun mm-get-content-id (id)
 780   "Return the handle(s) referred to by ID."
 781   (cdr (assoc id mm-content-id-alist)))
 782
 783 (defun mm-get-image-emacs (handle)
 784   "Return an image instance based on HANDLE."
 785   (let ((type (mm-handle-media-subtype handle))
 786         spec)
 787     ;; Allow some common translations.
 788     (setq type
 789           (cond
 790            ((equal type "x-pixmap")
 791             "xpm")
 792            ((equal type "x-xbitmap")
 793             "xbm")
 794            (t type)))
 795     (or (mm-handle-cache handle)
 796         (mm-with-unibyte-buffer
 797           (mm-insert-part handle)
 798           (prog1
 799               (setq spec
 800                     (ignore-errors
 801                       (cond
 802                        ((equal type "xbm")
 803                         ;; xbm images require special handling, since
 804                         ;; the only way to create glyphs from these
 805                         ;; (without a ton of work) is to write them
 806                         ;; out to a file, and then create a file
 807                         ;; specifier.
 808                         (error "Don't know what to do for XBMs right now."))
 809                        (t
 810                         (list 'image :type (intern type) :data (buffer-string))))))
 811             (mm-handle-set-cache handle spec))))))
 812
 813 (defun mm-get-image-xemacs (handle)
 814   "Return an image instance based on HANDLE."
 815   (let ((type (mm-handle-media-subtype handle))
 816         spec)
 817     ;; Allow some common translations.
 818     (setq type
 819           (cond
 820            ((equal type "x-pixmap")
 821             "xpm")
 822            ((equal type "x-xbitmap")
 823             "xbm")
 824            (t type)))
 825     (or (mm-handle-cache handle)
 826         (mm-with-unibyte-buffer
 827           (mm-insert-part handle)
 828           (prog1
 829               (setq spec
 830                     (ignore-errors
 831                       (cond
 832                        ((equal type "xbm")
 833                         ;; xbm images require special handling, since
 834                         ;; the only way to create glyphs from these
 835                         ;; (without a ton of work) is to write them
 836                         ;; out to a file, and then create a file
 837                         ;; specifier.
 838                         (let ((file (make-temp-name
 839                                      (expand-file-name "emm.xbm"
 840                                                        mm-tmp-directory))))
 841                           (unwind-protect
 842                               (progn
 843                                 (write-region (point-min) (point-max) file)
 844                                 (make-glyph (list (cons 'x file))))
 845                             (ignore-errors
 846                               (delete-file file)))))
 847                        (t
 848                         (make-glyph
 849                          (vector (intern type) :data (buffer-string)))))))
 850             (mm-handle-set-cache handle spec))))))
 851
 852 (defun mm-get-image (handle)
 853   (if mm-xemacs-p
 854       (mm-get-image-xemacs handle)
 855     (mm-get-image-emacs handle)))
 856
 857 (defun mm-image-fit-p (handle)
 858   "Say whether the image in HANDLE will fit the current window."
 859   (let ((image (mm-get-image handle)))
 860     (if (fboundp 'glyph-width)
 861         ;; XEmacs' glyphs can actually tell us about their width, so
 862         ;; lets be nice and smart about them.
 863         (or mm-inline-large-images
 864             (and (< (glyph-width image) (window-pixel-width))
 865                  (< (glyph-height image) (window-pixel-height))))
 866       ;; Let's just inline everything under Emacs 21, since the image
 867       ;; specification there doesn't actually get the width/height
 868       ;; until you render the image.
 869       t)))
 870
 871 (defun mm-valid-image-format-p (format)
 872   "Say whether FORMAT can be displayed natively by Emacs."
 873   (cond
 874    ;; Handle XEmacs
 875    ((fboundp 'valid-image-instantiator-format-p)
 876     (valid-image-instantiator-format-p format))
 877    ;; Handle Emacs 21
 878    ((fboundp 'image-type-available-p)
 879     (image-type-available-p format))
 880    ;; Nobody else can do images yet.
 881    (t
 882     nil)))
 883
 884 (defun mm-valid-and-fit-image-p (format handle)
 885   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
 886   (and window-system
 887        (mm-valid-image-format-p format)
 888        (mm-image-fit-p handle)))
 889
 890 (provide 'mm-decode)
 891
 892 ;; mm-decode.el ends here