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