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