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