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