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     (let (ctl type cte cd description id result header-string header-end)
 240       (save-restriction
 241         (mail-narrow-to-head)
 242         (when (or no-strict-mime
 243                   (mail-fetch-field "mime-version"))
 244           (setq ctl (mail-fetch-field "content-type")
 245                 ctl (ignore-errors (mail-header-parse-content-type ctl))
 246                 cte (mail-fetch-field "content-transfer-encoding")
 247                 cd (mail-fetch-field "content-disposition")
 248                 description (mail-fetch-field "content-description")
 249                 id (mail-fetch-field "content-id")))
 250         (setq header-end (point-max)
 251               header-string (buffer-substring (point-min) header-end)))
 252       (unless ctl
 253         (setq ctl (mail-header-parse-content-type "text/plain")))
 254       (setq cte (and cte (downcase (mail-header-remove-whitespace
 255                                     (mail-header-remove-comments
 256                                      cte))))
 257             cd (and cd (ignore-errors
 258                          (mail-header-parse-content-disposition cd))))
 259       (if handle
 260           (progn
 261             (mime-entity-set-content-type-internal handle ctl)
 262             (mime-entity-set-encoding-internal handle cte)
 263             (mime-entity-set-content-disposition-internal handle cd)
 264             (mmgnus-entity-set-content-description-internal handle description)
 265             (mmgnus-entity-set-header-internal handle header-string)
 266             (setq result handle))
 267         (setq result (mm-make-handle nil nil ctl cte nil cd
 268                                      description nil id nil header-string)))
 269       (when id
 270         (when (string-match " *<\\(.*\\)> *" id)
 271           (setq id (match-string 1 id)))
 272         (mmgnus-entity-set-content-id-internal result id))
 273       result)))
 274
 275 (defun mm-dissect-buffer (handle &optional no-strict-mime)
 276   "Dissect the current buffer and return a list of MIME handles."
 277   (save-excursion
 278     (let* ((result (mm-dissect-buffer-header handle no-strict-mime))
 279            (ctl (mime-entity-content-type-internal result))
 280            (type (mime-content-type-primary-type ctl)))
 281       (cond
 282        ((and (eq gnus-mime-display-part-function
 283                  'gnus-mime-display-part-with-mime-view)
 284              (eq type 'message))
 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       (insert-buffer-substring obuf beg)
 364       (current-buffer))))
 365
 366 (defun mm-display-part (handle &optional no-default)
 367   "Display the MIME part represented by HANDLE.
 368 Returns nil if the part is removed; inline if displayed inline;
 369 external if displayed external."
 370   (save-excursion
 371     (mm-mailcap-parse-mailcaps)
 372     (if (mm-handle-displayed-p handle)
 373         (mm-remove-part handle)
 374       (let* ((type (mm-handle-media-type handle))
 375              (method (mm-mailcap-mime-info type)))
 376         (if (mm-inlined-p handle)
 377             (progn
 378               (forward-line 1)
 379               (mm-display-inline handle)
 380               'inline)
 381           (when (or method
 382                     (not no-default))
 383             (if (and (not method)
 384                      (equal "text" (mm-handle-media-subtype handle)))
 385                 (progn
 386                   (forward-line 1)
 387                   (mm-insert-inline handle (mm-get-part handle))
 388                   'inline)
 389               (mm-display-external
 390                handle (or method 'mm-mailcap-save-binary-file)))))))))
 391
 392 (defun mm-display-external (handle method)
 393   "Display HANDLE using METHOD."
 394   (let ((outbuf (current-buffer)))
 395     (mm-with-unibyte-buffer
 396       (if (functionp method)
 397           (let ((cur (current-buffer)))
 398             (if (eq method 'mm-mailcap-save-binary-file)
 399                 (progn
 400                   (set-buffer (generate-new-buffer "*mm*"))
 401                   (setq method nil))
 402               (mm-insert-part handle)
 403               (let ((win (get-buffer-window cur t)))
 404                 (when win
 405                   (select-window win)))
 406               (switch-to-buffer (generate-new-buffer "*mm*")))
 407             (buffer-disable-undo)
 408             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 409             (insert-buffer-substring cur)
 410             (message "Viewing with %s" method)
 411             (let ((mm (current-buffer))
 412                   (non-viewer (assq 'non-viewer
 413                                     (mm-mailcap-mime-info
 414                                      (mm-handle-media-type handle) t))))
 415               (unwind-protect
 416                   (if method
 417                       (funcall method)
 418                     (mm-save-part handle))
 419                 (when (and (not non-viewer)
 420                            method)
 421                   (mm-handle-set-undisplayer handle mm)))))
 422         ;; The function is a string to be executed.
 423         (mm-insert-part handle)
 424         (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
 425                (filename (mail-content-type-get
 426                           (mm-handle-disposition handle) 'filename))
 427                (mime-info (mm-mailcap-mime-info
 428                            (mm-handle-media-type handle) t))
 429                (needsterm (or (assoc "needsterm" mime-info)
 430                               (assoc "needsterminal" mime-info)))
 431                (copiousoutput (assoc "copiousoutput" mime-info))
 432                file buffer)
 433           ;; We create a private sub-directory where we store our files.
 434           (make-directory dir)
 435           (set-file-modes dir 448)
 436           (if filename
 437               (setq file (expand-file-name (file-name-nondirectory filename)
 438                                            dir))
 439             (setq file (make-temp-name (expand-file-name "mm." dir))))
 440           (let ((coding-system-for-write mm-binary-coding-system))
 441             (write-region (point-min) (point-max) file nil 'nomesg))
 442           (message "Viewing with %s" method)
 443           (cond (needsterm
 444                  (unwind-protect
 445                      (start-process "*display*" nil
 446                                     "xterm"
 447                                     "-e" shell-file-name
 448                                     shell-command-switch
 449                                     (mm-mailcap-command
 450                                      method file (mm-handle-type handle)))
 451                    (mm-handle-set-undisplayer handle (cons file buffer)))
 452                  (message "Displaying %s..." (format method file))
 453                  'external)
 454                 (copiousoutput
 455                  (with-current-buffer outbuf
 456                    (forward-line 1)
 457                    (mm-insert-inline
 458                     handle
 459                     (unwind-protect
 460                         (progn
 461                           (call-process shell-file-name nil
 462                                         (setq buffer
 463                                               (generate-new-buffer "*mm*"))
 464                                         shell-file-name
 465                                         nil
 466                                         shell-command-switch
 467                                         (mm-mailcap-command
 468                                          method file (mm-handle-type handle)))
 469                           (if (buffer-live-p buffer)
 470                               (save-excursion
 471                                 (set-buffer buffer)
 472                                 (buffer-string))))
 473                       (progn
 474                         (ignore-errors (delete-file file))
 475                         (ignore-errors (delete-directory
 476                                         (file-name-directory file)))
 477                         (ignore-errors (kill-buffer buffer))))))
 478                  'inline)
 479                 (t
 480                  (unwind-protect
 481                      (start-process "*display*"
 482                                     (setq buffer
 483                                           (generate-new-buffer "*mm*"))
 484                                     shell-file-name
 485                                     shell-command-switch
 486                                     (mm-mailcap-command
 487                                      method file (mm-handle-type handle)))
 488                    (mm-handle-set-undisplayer handle (cons file buffer)))
 489                  (message "Displaying %s..." (format method file))
 490                  'external)))))))
 491
 492 (defun mm-mailcap-command (method file type-list)
 493   (let ((ctl (cdr type-list))
 494         (beg 0)
 495         (uses-stdin t)
 496         out sub total)
 497     (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg)
 498       (push (substring method beg (match-beginning 0)) out)
 499       (setq beg (match-end 0)
 500             total (match-string 0 method)
 501             sub (match-string 1 method))
 502       (cond
 503        ((string= total "%%")
 504         (push "%" out))
 505        ((string= total "%s")
 506         (setq uses-stdin nil)
 507         (push (mm-quote-arg file) out))
 508        ((string= total "%t")
 509         (push (mm-quote-arg (car type-list)) out))
 510        (t
 511         (push (mm-quote-arg (or (mime-content-type-parameter sub ctl) ""))
 512               out))))
 513     (push (substring method beg (length method)) out)
 514     (if uses-stdin
 515         (progn
 516           (push "<" out)
 517           (push (mm-quote-arg file) out)))
 518     (mapconcat 'identity (nreverse out) "")))
 519
 520 (defun mm-remove-parts (handles)
 521   "Remove the displayed MIME parts represented by HANDLE."
 522   (cond
 523    ((listp handles)
 524     (let (handle)
 525       (while (setq handle (pop handles))
 526         (mm-remove-parts handle))))
 527    ((mm-handle-child handles)
 528     (mm-remove-parts (mm-handle-child handles))
 529     (mm-remove-part handles))
 530    (t
 531     (mm-remove-part handles))))
 532
 533 (defun mm-destroy-parts (handles)
 534   "Remove the displayed MIME parts represented by HANDLE."
 535   (cond
 536    ((listp handles)
 537     (let (handle)
 538       (while (setq handle (pop handles))
 539         (mm-destroy-parts handle))))
 540    ((mm-handle-child handles)
 541     (mm-destroy-parts (mm-handle-child handles))
 542     (mm-destroy-part handles)
 543     (mm-handle-set-child handles nil))
 544    (t
 545     (mm-destroy-part handles))))
 546
 547 (defun mm-remove-part (handle)
 548   "Remove the displayed MIME part represented by HANDLE."
 549   (when (mm-handle-p handle)
 550     (let ((object (mm-handle-undisplayer handle)))
 551       (ignore-errors
 552         (cond
 553          ;; Internally displayed part.
 554          ((mm-annotationp object)
 555           (delete-annotation object))
 556          ((or (functionp object)
 557               (and (listp object)
 558                    (eq (car object) 'lambda)))
 559           (funcall object))
 560          ;; Externally displayed part.
 561          ((consp object)
 562           (ignore-errors (delete-file (car object)))
 563           (ignore-errors (delete-directory (file-name-directory (car object))))
 564           (ignore-errors (kill-buffer (cdr object))))
 565          ((bufferp object)
 566           (when (buffer-live-p object)
 567             (kill-buffer object)))))
 568       (mm-handle-set-undisplayer handle nil))))
 569
 570 (defun mm-display-inline (handle)
 571   (let* ((type (mm-handle-media-type handle))
 572          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
 573     (funcall function handle)
 574     (goto-char (point-min))))
 575
 576 (defun mm-assoc-string-match (alist type)
 577   (dolist (elem alist)
 578     (when (string-match (car elem) type)
 579       (return elem))))
 580
 581 (defun mm-inlinable-p (handle)
 582   "Say whether HANDLE can be displayed inline."
 583   (let ((alist mm-inline-media-tests)
 584         (type (mm-handle-media-type handle))
 585         test)
 586     (while alist
 587       (when (string-match (caar alist) type)
 588         (setq test (caddar alist)
 589               alist nil)
 590         (setq test (funcall test handle)))
 591       (pop alist))
 592     test))
 593
 594 (defun mm-automatic-display-p (handle)
 595   "Say whether the user wants HANDLE to be displayed automatically."
 596   (let ((methods mm-automatic-display)
 597         (type (mm-handle-media-type handle))
 598         method result)
 599     (while (setq method (pop methods))
 600       (when (and (not (mm-inline-override-p handle))
 601                  (string-match method type)
 602                  (mm-inlinable-p handle))
 603         (setq result t
 604               methods nil)))
 605     result))
 606
 607 (defun mm-inlined-p (handle)
 608   "Say whether the user wants HANDLE to be displayed automatically."
 609   (let ((methods mm-inlined-types)
 610         (type (mm-handle-media-type handle))
 611         method result)
 612     (while (setq method (pop methods))
 613       (when (and (not (mm-inline-override-p handle))
 614                  (string-match method type)
 615                  (mm-inlinable-p handle))
 616         (setq result t
 617               methods nil)))
 618     result))
 619
 620 (defun mm-attachment-override-p (handle)
 621   "Say whether HANDLE should have attachment behavior overridden."
 622   (let ((types mm-attachment-override-types)
 623         (type (mm-handle-media-type handle))
 624         ty)
 625     (catch 'found
 626       (while (setq ty (pop types))
 627         (when (and (string-match ty type)
 628                    (mm-inlinable-p handle))
 629           (throw 'found t))))))
 630
 631 (defun mm-inline-override-p (handle)
 632   "Say whether HANDLE should have inline behavior overridden."
 633   (let ((types mm-inline-override-types)
 634         (type (mm-handle-media-type handle))
 635         ty)
 636     (catch 'found
 637       (while (setq ty (pop types))
 638         (when (string-match ty type)
 639           (throw 'found t))))))
 640
 641 (defun mm-automatic-external-display-p (type)
 642   "Return the user-defined method for TYPE."
 643   (let ((methods mm-automatic-external-display)
 644         method result)
 645     (while (setq method (pop methods))
 646       (when (string-match method type)
 647         (setq result t
 648               methods nil)))
 649     result))
 650
 651 (defun mm-destroy-part (handle)
 652   "Destroy the data structures connected to HANDLE."
 653   (when (mm-handle-p handle)
 654     (mm-remove-part handle)
 655     (when (buffer-live-p (mm-handle-body handle))
 656       (kill-buffer (mm-handle-body handle))
 657       (mm-handle-set-body handle nil))))
 658
 659 (defun mm-handle-displayed-p (handle)
 660   "Say whether HANDLE is displayed or not."
 661   (mm-handle-undisplayer handle))
 662
 663 ;;;
 664 ;;; Functions for outputting parts
 665 ;;;
 666
 667 (defun mm-get-part (handle)
 668   "Return the contents of HANDLE as a string."
 669   (mm-with-unibyte-buffer
 670     (mm-insert-part handle)
 671     (buffer-string)))
 672
 673 (defun mm-insert-part (handle)
 674   "Insert the contents of HANDLE in the current buffer."
 675   (let ((cur (current-buffer)))
 676     (save-excursion
 677       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 678           (with-temp-buffer
 679             (insert-buffer-substring (mm-handle-body handle))
 680             (mm-decode-content-transfer-encoding
 681              (mm-handle-encoding handle)
 682              (mm-handle-media-type handle))
 683             (let ((temp (current-buffer)))
 684               (set-buffer cur)
 685               (insert-buffer-substring temp)))
 686         (mm-with-unibyte-buffer
 687           (insert-buffer-substring (mm-handle-body handle))
 688           (mm-decode-content-transfer-encoding
 689            (mm-handle-encoding handle)
 690            (mm-handle-media-type handle))
 691           (let ((temp (current-buffer)))
 692             (set-buffer cur)
 693             (insert-buffer-substring temp)))))))
 694
 695 (defvar mm-default-directory nil)
 696
 697 (defun mm-save-part (handle)
 698   "Write HANDLE to a file."
 699   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 700          (filename (mail-content-type-get
 701                     (mm-handle-disposition handle) 'filename))
 702          file)
 703     (when filename
 704       (setq filename (file-name-nondirectory filename)))
 705     (setq file
 706           (read-file-name "Save MIME part to: "
 707                           (expand-file-name
 708                            (or filename name "")
 709                            (or mm-default-directory default-directory))))
 710     (setq mm-default-directory (file-name-directory file))
 711     (when (or (not (file-exists-p file))
 712               (yes-or-no-p (format "File %s already exists; overwrite? "
 713                                    file)))
 714       (mm-save-part-to-file handle file))))
 715
 716 (defun mm-save-part-to-file (handle file)
 717   (mm-with-unibyte-buffer
 718     (mm-insert-part handle)
 719     (let ((coding-system-for-write 'binary)
 720           ;; Don't re-compress .gz & al.  Arguably we should make
 721           ;; `file-name-handler-alist' nil, but that would chop
 722           ;; ange-ftp, which is reasonable to use here.
 723           (inhibit-file-name-operation 'write-region)
 724           (inhibit-file-name-handlers
 725            (cons 'jka-compr-handler inhibit-file-name-handlers)))
 726       (write-region (point-min) (point-max) file))))
 727
 728 (defun mm-pipe-part (handle)
 729   "Pipe HANDLE to a process."
 730   (let* ((name (mail-content-type-get (mm-handle-type handle) 'name))
 731          (command
 732           (read-string "Shell command on MIME part: " mm-last-shell-command)))
 733     (mm-with-unibyte-buffer
 734       (mm-insert-part handle)
 735       (shell-command-on-region (point-min) (point-max) command nil))))
 736
 737 (defun mm-interactively-view-part (handle)
 738   "Display HANDLE using METHOD."
 739   (let* ((type (mm-handle-media-type handle))
 740          (methods
 741           (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 742                   (mm-mailcap-mime-info type 'all)))
 743          (method (completing-read "Viewer: " methods)))
 744     (mm-display-external (copy-sequence handle) method)))
 745
 746 (defun mm-preferred-alternative (handles &optional preferred)
 747   "Say which of HANDLES are preferred."
 748   (let ((prec (if preferred (list preferred)
 749                 (mm-preferred-alternative-precedence handles)))
 750         p h result type handle)
 751     (while (setq p (pop prec))
 752       (setq h handles)
 753       (while h
 754         (setq handle (car h))
 755         (setq type (mm-handle-media-type handle))
 756         (when (and (equal p type)
 757                    (mm-automatic-display-p handle)
 758                    (or (mm-handle-child handle)
 759                        (not (mm-handle-disposition handle))
 760                        (eq (mm-handle-disposition-type handle) 'inline)))
 761           (setq result handle
 762                 h nil
 763                 prec nil))
 764         (pop h)))
 765     result))
 766
 767 (defun mm-preferred-alternative-precedence (handles)
 768   "Return the precedence based on HANDLES and mm-discouraged-alternatives."
 769   (let ((seq (nreverse (mapcar (lambda (h)
 770                                  (mm-handle-media-type h))
 771                                handles))))
 772     (dolist (disc (reverse mm-discouraged-alternatives))
 773       (dolist (elem (copy-sequence seq))
 774         (when (string-match disc elem)
 775           (setq seq (nconc (delete elem seq) (list elem))))))
 776     seq))
 777
 778 (defun mm-get-content-id (id)
 779   "Return the handle(s) referred to by ID."
 780   (cdr (assoc id mm-content-id-alist)))
 781
 782 (defun mm-get-image-emacs (handle)
 783   "Return an image instance based on HANDLE."
 784   (let ((type (mm-handle-media-subtype handle))
 785         spec)
 786     ;; Allow some common translations.
 787     (setq type
 788           (cond
 789            ((equal type "x-pixmap")
 790             "xpm")
 791            ((equal type "x-xbitmap")
 792             "xbm")
 793            (t type)))
 794     (or (mm-handle-cache handle)
 795         (mm-with-unibyte-buffer
 796           (mm-insert-part handle)
 797           (prog1
 798               (setq spec
 799                     (ignore-errors
 800                       (cond
 801                        ((equal type "xbm")
 802                         ;; xbm images require special handling, since
 803                         ;; the only way to create glyphs from these
 804                         ;; (without a ton of work) is to write them
 805                         ;; out to a file, and then create a file
 806                         ;; specifier.
 807                         (error "Don't know what to do for XBMs right now."))
 808                        (t
 809                         (list 'image :type (intern type) :data (buffer-string))))))
 810             (mm-handle-set-cache handle spec))))))
 811
 812 (defun mm-get-image-xemacs (handle)
 813   "Return an image instance based on HANDLE."
 814   (let ((type (mm-handle-media-subtype handle))
 815         spec)
 816     ;; Allow some common translations.
 817     (setq type
 818           (cond
 819            ((equal type "x-pixmap")
 820             "xpm")
 821            ((equal type "x-xbitmap")
 822             "xbm")
 823            (t type)))
 824     (or (mm-handle-cache handle)
 825         (mm-with-unibyte-buffer
 826           (mm-insert-part handle)
 827           (prog1
 828               (setq spec
 829                     (ignore-errors
 830                       (cond
 831                        ((equal type "xbm")
 832                         ;; xbm images require special handling, since
 833                         ;; the only way to create glyphs from these
 834                         ;; (without a ton of work) is to write them
 835                         ;; out to a file, and then create a file
 836                         ;; specifier.
 837                         (let ((file (make-temp-name
 838                                      (expand-file-name "emm.xbm"
 839                                                        mm-tmp-directory))))
 840                           (unwind-protect
 841                               (progn
 842                                 (write-region (point-min) (point-max) file)
 843                                 (make-glyph (list (cons 'x file))))
 844                             (ignore-errors
 845                               (delete-file file)))))
 846                        (t
 847                         (make-glyph
 848                          (vector (intern type) :data (buffer-string)))))))
 849             (mm-handle-set-cache handle spec))))))
 850
 851 (defun mm-get-image (handle)
 852   (if mm-xemacs-p
 853       (mm-get-image-xemacs handle)
 854     (mm-get-image-emacs handle)))
 855
 856 (defun mm-image-fit-p (handle)
 857   "Say whether the image in HANDLE will fit the current window."
 858   (let ((image (mm-get-image handle)))
 859     (if (fboundp 'glyph-width)
 860         ;; XEmacs' glyphs can actually tell us about their width, so
 861         ;; lets be nice and smart about them.
 862         (or mm-inline-large-images
 863             (and (< (glyph-width image) (window-pixel-width))
 864                  (< (glyph-height image) (window-pixel-height))))
 865       ;; Let's just inline everything under Emacs 21, since the image
 866       ;; specification there doesn't actually get the width/height
 867       ;; until you render the image.
 868       t)))
 869
 870 (defun mm-valid-image-format-p (format)
 871   "Say whether FORMAT can be displayed natively by Emacs."
 872   (cond
 873    ;; Handle XEmacs
 874    ((fboundp 'valid-image-instantiator-format-p)
 875     (valid-image-instantiator-format-p format))
 876    ;; Handle Emacs 21
 877    ((fboundp 'image-type-available-p)
 878     (image-type-available-p format))
 879    ;; Nobody else can do images yet.
 880    (t
 881     nil)))
 882
 883 (defun mm-valid-and-fit-image-p (format handle)
 884   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
 885   (and window-system
 886        (mm-valid-image-format-p format)
 887        (mm-image-fit-p handle)))
 888
 889 (provide 'mm-decode)
 890
 891 ;; mm-decode.el ends here