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