lisp/gnus/mm-decode.el

   1 ;;; mm-decode.el --- Functions for decoding MIME things
   2
   3 ;; Copyright (C) 1998-2011  Free Software Foundation, Inc.
   4
   5 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   6 ;;      MORIOKA Tomohiko <morioka@jaist.ac.jp>
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software: you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation, either version 3 of the License, or
  12 ;; (at your option) any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 ;;; Commentary:
  23
  24 ;;; Code:
  25
  26 ;; For Emacs <22.2 and XEmacs.
  27 (eval-and-compile
  28   (unless (fboundp 'declare-function) (defmacro declare-function (&rest r))))
  29
  30 (require 'mail-parse)
  31 (require 'mm-bodies)
  32 (eval-when-compile (require 'cl)
  33                    (require 'term))
  34
  35 (autoload 'gnus-map-function "gnus-util")
  36 (autoload 'gnus-replace-in-string "gnus-util")
  37 (autoload 'gnus-read-shell-command "gnus-util")
  38
  39 (autoload 'mm-inline-partial "mm-partial")
  40 (autoload 'mm-inline-external-body "mm-extern")
  41 (autoload 'mm-extern-cache-contents "mm-extern")
  42 (autoload 'mm-insert-inline "mm-view")
  43
  44 (defvar gnus-current-window-configuration)
  45
  46 (add-hook 'gnus-exit-gnus-hook 'mm-destroy-postponed-undisplay-list)
  47
  48 (defgroup mime-display ()
  49   "Display of MIME in mail and news articles."
  50   :link '(custom-manual "(emacs-mime)Display Customization")
  51   :version "21.1"
  52   :group 'mail
  53   :group 'news
  54   :group 'multimedia)
  55
  56 (defgroup mime-security ()
  57   "MIME security in mail and news articles."
  58   :link '(custom-manual "(emacs-mime)Display Customization")
  59   :group 'mail
  60   :group 'news
  61   :group 'multimedia)
  62
  63 ;;; Convenience macros.
  64
  65 (defmacro mm-handle-buffer (handle)
  66   `(nth 0 ,handle))
  67 (defmacro mm-handle-type (handle)
  68   `(nth 1 ,handle))
  69 (defsubst mm-handle-media-type (handle)
  70   (if (stringp (car handle))
  71       (car handle)
  72     (car (mm-handle-type handle))))
  73 (defsubst mm-handle-media-supertype (handle)
  74   (car (split-string (mm-handle-media-type handle) "/")))
  75 (defsubst mm-handle-media-subtype (handle)
  76   (cadr (split-string (mm-handle-media-type handle) "/")))
  77 (defmacro mm-handle-encoding (handle)
  78   `(nth 2 ,handle))
  79 (defmacro mm-handle-undisplayer (handle)
  80   `(nth 3 ,handle))
  81 (defmacro mm-handle-set-undisplayer (handle function)
  82   `(setcar (nthcdr 3 ,handle) ,function))
  83 (defmacro mm-handle-disposition (handle)
  84   `(nth 4 ,handle))
  85 (defmacro mm-handle-description (handle)
  86   `(nth 5 ,handle))
  87 (defmacro mm-handle-cache (handle)
  88   `(nth 6 ,handle))
  89 (defmacro mm-handle-set-cache (handle contents)
  90   `(setcar (nthcdr 6 ,handle) ,contents))
  91 (defmacro mm-handle-id (handle)
  92   `(nth 7 ,handle))
  93 (defmacro mm-handle-multipart-original-buffer (handle)
  94   `(get-text-property 0 'buffer (car ,handle)))
  95 (defmacro mm-handle-multipart-from (handle)
  96   `(get-text-property 0 'from (car ,handle)))
  97 (defmacro mm-handle-multipart-ctl-parameter (handle parameter)
  98   `(get-text-property 0 ,parameter (car ,handle)))
  99
 100 (defmacro mm-make-handle (&optional buffer type encoding undisplayer
 101                                     disposition description cache
 102                                     id)
 103   `(list ,buffer ,type ,encoding ,undisplayer
 104          ,disposition ,description ,cache ,id))
 105
 106 (defcustom mm-text-html-renderer
 107   (cond ((fboundp 'libxml-parse-html-region) 'shr)
 108         ((executable-find "w3m") 'gnus-w3m)
 109         ((executable-find "links") 'links)
 110         ((executable-find "lynx") 'lynx)
 111         ((locate-library "w3") 'w3)
 112         ((locate-library "html2text") 'html2text)
 113         (t nil))
 114   "Render of HTML contents.
 115 It is one of defined renderer types, or a rendering function.
 116 The defined renderer types are:
 117 `shr': use Gnus simple HTML renderer;
 118 `gnus-w3m' : use Gnus renderer based on w3m;
 119 `w3m'  : use emacs-w3m;
 120 `w3m-standalone': use w3m;
 121 `links': use links;
 122 `lynx' : use lynx;
 123 `w3'   : use Emacs/W3;
 124 `html2text' : use html2text;
 125 nil    : use external viewer (default web browser)."
 126   :version "24.1"
 127   :type '(choice (const shr)
 128                  (const gnus-w3m)
 129                  (const w3)
 130                  (const w3m :tag "emacs-w3m")
 131                  (const w3m-standalone :tag "standalone w3m" )
 132                  (const links)
 133                  (const lynx)
 134                  (const html2text)
 135                  (const nil :tag "External viewer")
 136                  (function))
 137   :group 'mime-display)
 138
 139 (defcustom mm-inline-text-html-with-images nil
 140   "If non-nil, Gnus will allow retrieving images in HTML contents with
 141 the <img> tags.  It has no effect on Emacs/w3.  See also the
 142 documentation for the `mm-w3m-safe-url-regexp' variable."
 143   :version "22.1"
 144   :type 'boolean
 145   :group 'mime-display)
 146
 147 (defcustom mm-w3m-safe-url-regexp "\\`cid:"
 148   "Regexp matching URLs which are considered to be safe.
 149 Some HTML mails might contain a nasty trick used by spammers, using
 150 the <img> tag which is far more evil than the [Click Here!] button.
 151 It is most likely intended to check whether the ominous spam mail has
 152 reached your eyes or not, in which case the spammer knows for sure
 153 that your email address is valid.  It is done by embedding an
 154 identifier string into a URL that you might automatically retrieve
 155 when displaying the image.  The default value is \"\\\\`cid:\" which only
 156 matches parts embedded to the Multipart/Related type MIME contents and
 157 Gnus will never connect to the spammer's site arbitrarily.  You may
 158 set this variable to nil if you consider all urls to be safe."
 159   :version "22.1"
 160   :type '(choice (regexp :tag "Regexp")
 161                  (const :tag "All URLs are safe" nil))
 162   :group 'mime-display)
 163
 164 (defcustom mm-inline-text-html-with-w3m-keymap t
 165   "If non-nil, use emacs-w3m command keys in the article buffer."
 166   :version "22.1"
 167   :type 'boolean
 168   :group 'mime-display)
 169
 170 (defcustom mm-enable-external t
 171   "Indicate whether external MIME handlers should be used.
 172
 173 If t, all defined external MIME handlers are used.  If nil, files are saved by
 174 `mailcap-save-binary-file'.  If it is the symbol `ask', you are prompted
 175 before the external MIME handler is invoked."
 176   :version "22.1"
 177   :type '(choice (const :tag "Always" t)
 178                  (const :tag "Never" nil)
 179                  (const :tag "Ask" ask))
 180   :group 'mime-display)
 181
 182 (defcustom mm-inline-media-tests
 183   '(("image/p?jpeg"
 184      mm-inline-image
 185      (lambda (handle)
 186        (mm-valid-and-fit-image-p 'jpeg handle)))
 187     ("image/png"
 188      mm-inline-image
 189      (lambda (handle)
 190        (mm-valid-and-fit-image-p 'png handle)))
 191     ("image/gif"
 192      mm-inline-image
 193      (lambda (handle)
 194        (mm-valid-and-fit-image-p 'gif handle)))
 195     ("image/tiff"
 196      mm-inline-image
 197      (lambda (handle)
 198        (mm-valid-and-fit-image-p 'tiff handle)) )
 199     ("image/xbm"
 200      mm-inline-image
 201      (lambda (handle)
 202        (mm-valid-and-fit-image-p 'xbm handle)))
 203     ("image/x-xbitmap"
 204      mm-inline-image
 205      (lambda (handle)
 206        (mm-valid-and-fit-image-p 'xbm handle)))
 207     ("image/xpm"
 208      mm-inline-image
 209      (lambda (handle)
 210        (mm-valid-and-fit-image-p 'xpm handle)))
 211     ("image/x-xpixmap"
 212      mm-inline-image
 213      (lambda (handle)
 214        (mm-valid-and-fit-image-p 'xpm handle)))
 215     ("image/bmp"
 216      mm-inline-image
 217      (lambda (handle)
 218        (mm-valid-and-fit-image-p 'bmp handle)))
 219     ("image/x-portable-bitmap"
 220      mm-inline-image
 221      (lambda (handle)
 222        (mm-valid-and-fit-image-p 'pbm handle)))
 223     ("text/plain" mm-inline-text identity)
 224     ("text/enriched" mm-inline-text identity)
 225     ("text/richtext" mm-inline-text identity)
 226     ("text/x-patch" mm-display-patch-inline identity)
 227     ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40).
 228     ("text/x-diff" mm-display-patch-inline identity)
 229     ("application/emacs-lisp" mm-display-elisp-inline identity)
 230     ("application/x-emacs-lisp" mm-display-elisp-inline identity)
 231     ("application/x-shellscript" mm-display-shell-script-inline identity)
 232     ("application/x-sh" mm-display-shell-script-inline identity)
 233     ("text/x-sh" mm-display-shell-script-inline identity)
 234     ("application/javascript" mm-display-javascript-inline identity)
 235     ("text/dns" mm-display-dns-inline identity)
 236     ("text/x-org" mm-display-org-inline identity)
 237     ("text/html"
 238      mm-inline-text-html
 239      (lambda (handle)
 240        mm-text-html-renderer))
 241     ("text/x-vcard"
 242      mm-inline-text-vcard
 243      (lambda (handle)
 244        (or (featurep 'vcard)
 245            (locate-library "vcard"))))
 246     ("message/delivery-status" mm-inline-text identity)
 247     ("message/rfc822" mm-inline-message identity)
 248     ("message/partial" mm-inline-partial identity)
 249     ("message/external-body" mm-inline-external-body identity)
 250     ("text/.*" mm-inline-text identity)
 251     ("audio/wav" mm-inline-audio
 252      (lambda (handle)
 253        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 254             (device-sound-enabled-p))))
 255     ("audio/au"
 256      mm-inline-audio
 257      (lambda (handle)
 258        (and (or (featurep 'nas-sound) (featurep 'native-sound))
 259             (device-sound-enabled-p))))
 260     ("application/pgp-signature" ignore identity)
 261     ("application/x-pkcs7-signature" ignore identity)
 262     ("application/pkcs7-signature" ignore identity)
 263     ("application/x-pkcs7-mime" ignore identity)
 264     ("application/pkcs7-mime" ignore identity)
 265     ("multipart/alternative" ignore identity)
 266     ("multipart/mixed" ignore identity)
 267     ("multipart/related" ignore identity)
 268     ;; Disable audio and image
 269     ("audio/.*" ignore ignore)
 270     ("image/.*" ignore ignore)
 271     ;; Default to displaying as text
 272     (".*" mm-inline-text mm-readable-p))
 273   "Alist of media types/tests saying whether types can be displayed inline."
 274   :type '(repeat (list (regexp :tag "MIME type")
 275                        (function :tag "Display function")
 276                        (function :tag "Display test")))
 277   :group 'mime-display)
 278
 279 (defcustom mm-inlined-types
 280   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
 281     "message/partial" "message/external-body" "application/emacs-lisp"
 282     "application/x-emacs-lisp"
 283     "application/pgp-signature" "application/x-pkcs7-signature"
 284     "application/pkcs7-signature" "application/x-pkcs7-mime"
 285     "application/pkcs7-mime"
 286     ;; Mutt still uses this even though it has already been withdrawn.
 287     "application/pgp")
 288   "List of media types that are to be displayed inline.
 289 See also `mm-inline-media-tests', which says how to display a media
 290 type inline."
 291   :type '(repeat regexp)
 292   :group 'mime-display)
 293
 294 (defcustom mm-keep-viewer-alive-types
 295   '("application/postscript" "application/msword" "application/vnd.ms-excel"
 296     "application/pdf" "application/x-dvi")
 297   "List of media types for which the external viewer will not be killed
 298 when selecting a different article."
 299   :version "22.1"
 300   :type '(repeat regexp)
 301   :group 'mime-display)
 302
 303 (defcustom mm-automatic-display
 304   '("text/plain" "text/enriched" "text/richtext" "text/html" "text/x-verbatim"
 305     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
 306     "message/rfc822" "text/x-patch" "text/dns" "application/pgp-signature"
 307     "application/emacs-lisp" "application/x-emacs-lisp"
 308     "application/x-pkcs7-signature"
 309     "application/pkcs7-signature" "application/x-pkcs7-mime"
 310     "application/pkcs7-mime"
 311     ;; Mutt still uses this even though it has already been withdrawn.
 312     "application/pgp\\'"
 313      "text/x-org")
 314   "A list of MIME types to be displayed automatically."
 315   :type '(repeat regexp)
 316   :group 'mime-display)
 317
 318 (defcustom mm-attachment-override-types '("text/x-vcard"
 319                                           "application/pkcs7-mime"
 320                                           "application/x-pkcs7-mime"
 321                                           "application/pkcs7-signature"
 322                                           "application/x-pkcs7-signature")
 323   "Types to have \"attachment\" ignored if they can be displayed inline."
 324   :type '(repeat regexp)
 325   :group 'mime-display)
 326
 327 (defcustom mm-inline-override-types nil
 328   "Types to be treated as attachments even if they can be displayed inline."
 329   :type '(repeat regexp)
 330   :group 'mime-display)
 331
 332 (defcustom mm-automatic-external-display nil
 333   "List of MIME type regexps that will be displayed externally automatically."
 334   :type '(repeat regexp)
 335   :group 'mime-display)
 336
 337 (defcustom mm-discouraged-alternatives nil
 338   "List of MIME types that are discouraged when viewing multipart/alternative.
 339 Viewing agents are supposed to view the last possible part of a message,
 340 as that is supposed to be the richest.  However, users may prefer other
 341 types instead, and this list says what types are most unwanted.  If,
 342 for instance, text/html parts are very unwanted, and text/richtext are
 343 somewhat unwanted, then the value of this variable should be set
 344 to:
 345
 346  (\"text/html\" \"text/richtext\")
 347
 348 Adding \"image/.*\" might also be useful.  Spammers use it as the
 349 prefered part of multipart/alternative messages.  See also
 350 `gnus-buttonized-mime-types', to which adding \"multipart/alternative\"
 351 enables you to choose manually one of two types those mails include."
 352   :type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'.
 353   :group 'mime-display)
 354
 355 (defcustom mm-tmp-directory
 356   (if (fboundp 'temp-directory)
 357       (temp-directory)
 358     (if (boundp 'temporary-file-directory)
 359         temporary-file-directory
 360       "/tmp/"))
 361   "Where mm will store its temporary files."
 362   :type 'directory
 363   :group 'mime-display)
 364
 365 (defcustom mm-inline-large-images nil
 366   "If t, then all images fit in the buffer.
 367 If 'resize, try to resize the images so they fit."
 368   :type '(radio
 369           (const :tag "Inline large images as they are." t)
 370           (const :tag "Resize large images." resize)
 371           (const :tag "Do not inline large images." nil))
 372   :group 'mime-display)
 373
 374 (defcustom mm-file-name-rewrite-functions
 375   '(mm-file-name-delete-control mm-file-name-delete-gotchas)
 376   "List of functions used for rewriting file names of MIME parts.
 377 Each function takes a file name as input and returns a file name.
 378
 379 Ready-made functions include `mm-file-name-delete-control',
 380 `mm-file-name-delete-gotchas' (you should not remove these two
 381 functions), `mm-file-name-delete-whitespace',
 382 `mm-file-name-trim-whitespace', `mm-file-name-collapse-whitespace',
 383 `mm-file-name-replace-whitespace', `capitalize', `downcase',
 384 `upcase', and `upcase-initials'."
 385   :type '(list (set :inline t
 386                     (const mm-file-name-delete-control)
 387                     (const mm-file-name-delete-gotchas)
 388                     (const mm-file-name-delete-whitespace)
 389                     (const mm-file-name-trim-whitespace)
 390                     (const mm-file-name-collapse-whitespace)
 391                     (const mm-file-name-replace-whitespace)
 392                     (const capitalize)
 393                     (const downcase)
 394                     (const upcase)
 395                     (const upcase-initials)
 396                (repeat :inline t
 397                        :tag "Function"
 398                        function)))
 399   :version "23.1" ;; No Gnus
 400   :group 'mime-display)
 401
 402
 403 (defvar mm-path-name-rewrite-functions nil
 404   "*List of functions for rewriting the full file names of MIME parts.
 405 This is used when viewing parts externally, and is meant for
 406 transforming the absolute name so that non-compliant programs can find
 407 the file where it's saved.
 408
 409 Each function takes a file name as input and returns a file name.")
 410
 411 (defvar mm-file-name-replace-whitespace nil
 412   "String used for replacing whitespace characters; default is `\"_\"'.")
 413
 414 (defcustom mm-default-directory nil
 415   "The default directory where mm will save files.
 416 If not set, `default-directory' will be used."
 417   :type '(choice directory (const :tag "Default" nil))
 418   :group 'mime-display)
 419
 420 (defcustom mm-attachment-file-modes 384
 421   "Set the mode bits of saved attachments to this integer."
 422   :version "22.1"
 423   :type 'integer
 424   :group 'mime-display)
 425
 426 (defcustom mm-external-terminal-program "xterm"
 427   "The program to start an external terminal."
 428   :version "22.1"
 429   :type 'string
 430   :group 'mime-display)
 431
 432 ;;; Internal variables.
 433
 434 (defvar mm-last-shell-command "")
 435 (defvar mm-content-id-alist nil)
 436 (defvar mm-postponed-undisplay-list nil)
 437
 438 ;; According to RFC2046, in particular, in a digest, the default
 439 ;; Content-Type value for a body part is changed from "text/plain" to
 440 ;; "message/rfc822".
 441 (defvar mm-dissect-default-type "text/plain")
 442
 443 (autoload 'mml2015-verify "mml2015")
 444 (autoload 'mml2015-verify-test "mml2015")
 445 (autoload 'mml-smime-verify "mml-smime")
 446 (autoload 'mml-smime-verify-test "mml-smime")
 447
 448 (defvar mm-verify-function-alist
 449   '(("application/pgp-signature" mml2015-verify "PGP" mml2015-verify-test)
 450     ("application/x-gnus-pgp-signature" mm-uu-pgp-signed-extract-1 "PGP"
 451      mm-uu-pgp-signed-test)
 452     ("application/pkcs7-signature" mml-smime-verify "S/MIME"
 453      mml-smime-verify-test)
 454     ("application/x-pkcs7-signature" mml-smime-verify "S/MIME"
 455      mml-smime-verify-test)))
 456
 457 (defcustom mm-verify-option 'never
 458   "Option of verifying signed parts.
 459 `never', not verify; `always', always verify;
 460 `known', only verify known protocols.  Otherwise, ask user.
 461
 462 When set to `always' or `known', you should add
 463 \"multipart/signed\" to `gnus-buttonized-mime-types' to see
 464 result of the verification."
 465   :version "22.1"
 466   :type '(choice (item always)
 467                  (item never)
 468                  (item :tag "only known protocols" known)
 469                  (item :tag "ask" nil))
 470   :group 'mime-security)
 471
 472 (autoload 'mml2015-decrypt "mml2015")
 473 (autoload 'mml2015-decrypt-test "mml2015")
 474
 475 (defvar mm-decrypt-function-alist
 476   '(("application/pgp-encrypted" mml2015-decrypt "PGP" mml2015-decrypt-test)
 477     ("application/x-gnus-pgp-encrypted" mm-uu-pgp-encrypted-extract-1 "PGP"
 478      mm-uu-pgp-encrypted-test)))
 479
 480 (defcustom mm-decrypt-option nil
 481   "Option of decrypting encrypted parts.
 482 `never', not decrypt; `always', always decrypt;
 483 `known', only decrypt known protocols.  Otherwise, ask user."
 484   :version "22.1"
 485   :type '(choice (item always)
 486                  (item never)
 487                  (item :tag "only known protocols" known)
 488                  (item :tag "ask" nil))
 489   :group 'mime-security)
 490
 491 (defvar mm-viewer-completion-map
 492   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 493     (set-keymap-parent map minibuffer-local-completion-map)
 494     ;; Should we bind other key to minibuffer-complete-word?
 495     (define-key map " " 'self-insert-command)
 496     map)
 497   "Keymap for input viewer with completion.")
 498
 499 (defvar mm-viewer-completion-map
 500   (let ((map (make-sparse-keymap 'mm-viewer-completion-map)))
 501     (set-keymap-parent map minibuffer-local-completion-map)
 502     ;; Should we bind other key to minibuffer-complete-word?
 503     (define-key map " " 'self-insert-command)
 504     map)
 505   "Keymap for input viewer with completion.")
 506
 507 ;;; The functions.
 508
 509 (defun mm-alist-to-plist (alist)
 510   "Convert association list ALIST into the equivalent property-list form.
 511 The plist is returned.  This converts from
 512
 513 \((a . 1) (b . 2) (c . 3))
 514
 515 into
 516
 517 \(a 1 b 2 c 3)
 518
 519 The original alist is not modified.  See also `destructive-alist-to-plist'."
 520   (let (plist)
 521     (while alist
 522       (let ((el (car alist)))
 523         (setq plist (cons (cdr el) (cons (car el) plist))))
 524       (setq alist (cdr alist)))
 525     (nreverse plist)))
 526
 527 (defun mm-keep-viewer-alive-p (handle)
 528   "Say whether external viewer for HANDLE should stay alive."
 529   (let ((types mm-keep-viewer-alive-types)
 530         (type (mm-handle-media-type handle))
 531         ty)
 532     (catch 'found
 533       (while (setq ty (pop types))
 534         (when (string-match ty type)
 535           (throw 'found t))))))
 536
 537 (defun mm-handle-set-external-undisplayer (handle function)
 538   "Set the undisplayer for HANDLE to FUNCTION.
 539 Postpone undisplaying of viewers for types in
 540 `mm-keep-viewer-alive-types'."
 541   (if (mm-keep-viewer-alive-p handle)
 542       (let ((new-handle (copy-sequence handle)))
 543         (mm-handle-set-undisplayer new-handle function)
 544         (mm-handle-set-undisplayer handle nil)
 545         (push new-handle mm-postponed-undisplay-list))
 546     (mm-handle-set-undisplayer handle function)))
 547
 548 (defun mm-destroy-postponed-undisplay-list ()
 549   (when mm-postponed-undisplay-list
 550     (message "Destroying external MIME viewers")
 551     (mm-destroy-parts mm-postponed-undisplay-list)))
 552
 553 (autoload 'message-fetch-field "message")
 554
 555 (defun mm-dissect-buffer (&optional no-strict-mime loose-mime from)
 556   "Dissect the current buffer and return a list of MIME handles."
 557   (save-excursion
 558     (let (ct ctl type subtype cte cd description id result)
 559       (save-restriction
 560         (mail-narrow-to-head)
 561         (when (or no-strict-mime
 562                   loose-mime
 563                   (mail-fetch-field "mime-version"))
 564           (setq ct (mail-fetch-field "content-type")
 565                 ctl (and ct (mail-header-parse-content-type ct))
 566                 cte (mail-fetch-field "content-transfer-encoding")
 567                 cd (mail-fetch-field "content-disposition")
 568                 ;; Newlines in description should be stripped so as
 569                 ;; not to break the MIME tag into two or more lines.
 570                 description (message-fetch-field "content-description")
 571                 id (mail-fetch-field "content-id"))
 572           (unless from
 573             (setq from (mail-fetch-field "from")))
 574           ;; FIXME: In some circumstances, this code is running within
 575           ;; an unibyte macro.  mail-extract-address-components
 576           ;; creates unibyte buffers. This `if', though not a perfect
 577           ;; solution, avoids most of them.
 578           (if from
 579               (setq from (cadr (mail-extract-address-components from))))
 580           (if description
 581               (setq description (mail-decode-encoded-word-string
 582                                  description)))))
 583       (if (or (not ctl)
 584               (not (string-match "/" (car ctl))))
 585           (mm-dissect-singlepart
 586            (list mm-dissect-default-type)
 587            (and cte (intern (downcase (mail-header-strip cte))))
 588            no-strict-mime
 589            (and cd (mail-header-parse-content-disposition cd))
 590            description)
 591         (setq type (split-string (car ctl) "/"))
 592         (setq subtype (cadr type)
 593               type (car type))
 594         (setq
 595          result
 596          (cond
 597           ((equal type "multipart")
 598            (let ((mm-dissect-default-type (if (equal subtype "digest")
 599                                               "message/rfc822"
 600                                             "text/plain"))
 601                  (start (cdr (assq 'start (cdr ctl)))))
 602              (add-text-properties 0 (length (car ctl))
 603                                   (mm-alist-to-plist (cdr ctl)) (car ctl))
 604
 605              ;; what really needs to be done here is a way to link a
 606              ;; MIME handle back to it's parent MIME handle (in a multilevel
 607              ;; MIME article).  That would probably require changing
 608              ;; the mm-handle API so we simply store the multipart buffer
 609              ;; name as a text property of the "multipart/whatever" string.
 610              (add-text-properties 0 (length (car ctl))
 611                                   (list 'buffer (mm-copy-to-buffer)
 612                                         'from from
 613                                         'start start)
 614                                   (car ctl))
 615              (cons (car ctl) (mm-dissect-multipart ctl from))))
 616           (t
 617            (mm-possibly-verify-or-decrypt
 618             (mm-dissect-singlepart
 619              ctl
 620              (and cte (intern (downcase (mail-header-strip cte))))
 621              no-strict-mime
 622              (and cd (mail-header-parse-content-disposition cd))
 623              description id)
 624             ctl from))))
 625         (when id
 626           (when (string-match " *<\\(.*\\)> *" id)
 627             (setq id (match-string 1 id)))
 628           (push (cons id result) mm-content-id-alist))
 629         result))))
 630
 631 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
 632   (when (or force
 633             (if (equal "text/plain" (car ctl))
 634                 (assoc 'format ctl)
 635               t))
 636     (mm-make-handle
 637      (mm-copy-to-buffer) ctl cte nil cdl description nil id)))
 638
 639 (defun mm-dissect-multipart (ctl from)
 640   (goto-char (point-min))
 641   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
 642          (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
 643          start parts
 644          (end (save-excursion
 645                 (goto-char (point-max))
 646                 (if (re-search-backward close-delimiter nil t)
 647                     (match-beginning 0)
 648                   (point-max)))))
 649     (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
 650     (while (and (< (point) end) (re-search-forward boundary end t))
 651       (goto-char (match-beginning 0))
 652       (when start
 653         (save-excursion
 654           (save-restriction
 655             (narrow-to-region start (point))
 656             (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 657       (end-of-line 2)
 658       (or (looking-at boundary)
 659           (forward-line 1))
 660       (setq start (point)))
 661     (when (and start (< start end))
 662       (save-excursion
 663         (save-restriction
 664           (narrow-to-region start end)
 665           (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts)))))
 666     (mm-possibly-verify-or-decrypt (nreverse parts) ctl from)))
 667
 668 (defun mm-copy-to-buffer ()
 669   "Copy the contents of the current buffer to a fresh buffer."
 670   (let ((obuf (current-buffer))
 671         (mb (mm-multibyte-p))
 672         beg)
 673     (goto-char (point-min))
 674     (search-forward-regexp "^\n" nil t)
 675     (setq beg (point))
 676     (with-current-buffer
 677           (generate-new-buffer " *mm*")
 678       ;; Preserve the data's unibyteness (for url-insert-file-contents).
 679       (mm-set-buffer-multibyte mb)
 680       (insert-buffer-substring obuf beg)
 681       (current-buffer))))
 682
 683 (defun mm-display-parts (handle &optional no-default)
 684   (if (stringp (car handle))
 685       (mapcar 'mm-display-parts (cdr handle))
 686     (if (bufferp (car handle))
 687         (save-restriction
 688           (narrow-to-region (point) (point))
 689           (mm-display-part handle)
 690           (goto-char (point-max)))
 691       (mapcar 'mm-display-parts handle))))
 692
 693 (autoload 'mailcap-parse-mailcaps "mailcap")
 694 (autoload 'mailcap-mime-info "mailcap")
 695
 696 (defun mm-display-part (handle &optional no-default force)
 697   "Display the MIME part represented by HANDLE.
 698 Returns nil if the part is removed; inline if displayed inline;
 699 external if displayed external."
 700   (save-excursion
 701     (mailcap-parse-mailcaps)
 702     (if (and (not force)
 703              (mm-handle-displayed-p handle))
 704         (mm-remove-part handle)
 705       (let* ((ehandle (if (equal (mm-handle-media-type handle)
 706                                  "message/external-body")
 707                           (progn
 708                             (unless (mm-handle-cache handle)
 709                               (mm-extern-cache-contents handle))
 710                             (mm-handle-cache handle))
 711                         handle))
 712              (type (mm-handle-media-type ehandle))
 713              (method (mailcap-mime-info type))
 714              (filename (or (mail-content-type-get
 715                             (mm-handle-disposition handle) 'filename)
 716                            (mail-content-type-get
 717                             (mm-handle-type handle) 'name)
 718                            "<file>"))
 719              (external mm-enable-external))
 720         (if (and (mm-inlinable-p ehandle)
 721                  (mm-inlined-p ehandle))
 722             (progn
 723               (forward-line 1)
 724               (mm-display-inline handle)
 725               'inline)
 726           (when (or method
 727                     (not no-default))
 728             (if (and (not method)
 729                      (equal "text" (car (split-string type "/"))))
 730                 (progn
 731                   (forward-line 1)
 732                   (mm-insert-inline handle (mm-get-part handle))
 733                   'inline)
 734               (setq external
 735                     (and method ;; If nil, we always use "save".
 736                        (stringp method) ;; 'mailcap-save-binary-file
 737                        (or (eq mm-enable-external t)
 738                            (and (eq mm-enable-external 'ask)
 739                                 (y-or-n-p
 740                                  (concat
 741                                   "Display part (" type
 742                                   ") using external program"
 743                                   ;; Can non-string method ever happen?
 744                                   (if (stringp method)
 745                                       (concat
 746                                        " \"" (format method filename) "\"")
 747                                     "")
 748                                     "? "))))))
 749               (if external
 750                   (mm-display-external
 751                    handle (or method 'mailcap-save-binary-file))
 752                 (mm-display-external
 753                  handle 'mailcap-save-binary-file)))))))))
 754
 755 (declare-function gnus-configure-windows "gnus-win" (setting &optional force))
 756 (defvar mailcap-mime-extensions)        ; mailcap-mime-info autoloads
 757
 758 (defun mm-display-external (handle method)
 759   "Display HANDLE using METHOD."
 760   (let ((outbuf (current-buffer)))
 761     (mm-with-unibyte-buffer
 762       (if (functionp method)
 763           (let ((cur (current-buffer)))
 764             (if (eq method 'mailcap-save-binary-file)
 765                 (progn
 766                   (set-buffer (generate-new-buffer " *mm*"))
 767                   (setq method nil))
 768               (mm-insert-part handle)
 769               (mm-add-meta-html-tag handle)
 770               (let ((win (get-buffer-window cur t)))
 771                 (when win
 772                   (select-window win)))
 773               (switch-to-buffer (generate-new-buffer " *mm*")))
 774             (buffer-disable-undo)
 775             (mm-set-buffer-file-coding-system mm-binary-coding-system)
 776             (insert-buffer-substring cur)
 777             (goto-char (point-min))
 778             (when method
 779               (message "Viewing with %s" method))
 780             (let ((mm (current-buffer))
 781                   (non-viewer (assq 'non-viewer
 782                                     (mailcap-mime-info
 783                                      (mm-handle-media-type handle) t))))
 784               (unwind-protect
 785                   (if method
 786                       (funcall method)
 787                     (mm-save-part handle))
 788                 (when (and (not non-viewer)
 789                            method)
 790                   (mm-handle-set-undisplayer handle mm)))))
 791         ;; The function is a string to be executed.
 792         (mm-insert-part handle)
 793         (mm-add-meta-html-tag handle)
 794         (let* ((dir (mm-make-temp-file
 795                      (expand-file-name "emm." mm-tmp-directory) 'dir))
 796                (filename (or
 797                           (mail-content-type-get
 798                            (mm-handle-disposition handle) 'filename)
 799                           (mail-content-type-get
 800                            (mm-handle-type handle) 'name)))
 801                (mime-info (mailcap-mime-info
 802                            (mm-handle-media-type handle) t))
 803                (needsterm (or (assoc "needsterm" mime-info)
 804                               (assoc "needsterminal" mime-info)))
 805                (copiousoutput (assoc "copiousoutput" mime-info))
 806                file buffer)
 807           ;; We create a private sub-directory where we store our files.
 808           (set-file-modes dir #o700)
 809           (if filename
 810               (setq file (expand-file-name
 811                           (gnus-map-function mm-file-name-rewrite-functions
 812                                              (file-name-nondirectory filename))
 813                           dir))
 814             ;; Use nametemplate (defined in RFC1524) if it is specified
 815             ;; in mailcap.
 816             (let ((suffix (cdr (assoc "nametemplate" mime-info))))
 817               (if (and suffix
 818                        (string-match "\\`%s\\(\\..+\\)\\'" suffix))
 819                   (setq suffix (match-string 1 suffix))
 820                 ;; Otherwise, use a suffix according to
 821                 ;; `mailcap-mime-extensions'.
 822                 (setq suffix (car (rassoc (mm-handle-media-type handle)
 823                                           mailcap-mime-extensions))))
 824               (setq file (mm-make-temp-file (expand-file-name "mm." dir)
 825                                             nil suffix))))
 826           (let ((coding-system-for-write mm-binary-coding-system))
 827             (write-region (point-min) (point-max) file nil 'nomesg))
 828           ;; The file is deleted after the viewer exists.  If the users edits
 829           ;; the file, changes will be lost.  Set file to read-only to make it
 830           ;; clear.
 831           (set-file-modes file #o400)
 832           (message "Viewing with %s" method)
 833           (cond
 834            (needsterm
 835             (let ((command (mm-mailcap-command
 836                             method file (mm-handle-type handle))))
 837               (unwind-protect
 838                   (if window-system
 839                       (start-process "*display*" nil
 840                                      mm-external-terminal-program
 841                                      "-e" shell-file-name
 842                                      shell-command-switch command)
 843                     (require 'term)
 844                     (require 'gnus-win)
 845                     (set-buffer
 846                      (setq buffer
 847                            (make-term "display"
 848                                       shell-file-name
 849                                       nil
 850                                       shell-command-switch command)))
 851                     (term-mode)
 852                     (term-char-mode)
 853                     (set-process-sentinel
 854                      (get-buffer-process buffer)
 855                      `(lambda (process state)
 856                         (if (eq 'exit (process-status process))
 857                             (gnus-configure-windows
 858                              ',gnus-current-window-configuration))))
 859                     (gnus-configure-windows 'display-term))
 860                 (mm-handle-set-external-undisplayer handle (cons file buffer)))
 861               (message "Displaying %s..." command))
 862             'external)
 863            (copiousoutput
 864             (with-current-buffer outbuf
 865               (forward-line 1)
 866               (mm-insert-inline
 867                handle
 868                (unwind-protect
 869                    (progn
 870                      (call-process shell-file-name nil
 871                                    (setq buffer
 872                                          (generate-new-buffer " *mm*"))
 873                                    nil
 874                                    shell-command-switch
 875                                    (mm-mailcap-command
 876                                     method file (mm-handle-type handle)))
 877                      (if (buffer-live-p buffer)
 878                          (with-current-buffer buffer
 879                            (buffer-string))))
 880                  (progn
 881                    (ignore-errors (delete-file file))
 882                    (ignore-errors (delete-directory
 883                                    (file-name-directory file)))
 884                    (ignore-errors (kill-buffer buffer))))))
 885             'inline)
 886            (t
 887             ;; Deleting the temp file should be postponed for some wrappers,
 888             ;; shell scripts, and so on, which might exit right after having
 889             ;; started a viewer command as a background job.
 890             (let ((command (mm-mailcap-command
 891                             method file (mm-handle-type handle))))
 892               (unwind-protect
 893                   (progn
 894                     (start-process "*display*"
 895                                    (setq buffer
 896                                          (generate-new-buffer " *mm*"))
 897                                    shell-file-name
 898                                    shell-command-switch command)
 899                     (set-process-sentinel
 900                      (get-buffer-process buffer)
 901                      (lexical-let ;; Don't use `let'.
 902                          ;; Function used to remove temp file and directory.
 903                          ((fn `(lambda nil
 904                                  ;; Don't use `ignore-errors'.
 905                                  (condition-case nil
 906                                      (delete-file ,file)
 907                                    (error))
 908                                  (condition-case nil
 909                                      (delete-directory
 910                                       ,(file-name-directory file))
 911                                    (error))))
 912                           ;; Form uses to kill the process buffer and
 913                           ;; remove the undisplayer.
 914                           (fm `(progn
 915                                  (kill-buffer ,buffer)
 916                                  ,(macroexpand
 917                                    (list 'mm-handle-set-undisplayer
 918                                          (list 'quote handle)
 919                                          nil))))
 920                           ;; Message to be issued when the process exits.
 921                           (done (format "Displaying %s...done" command))
 922                           ;; In particular, the timer object (which is
 923                           ;; a vector in Emacs but is a list in XEmacs)
 924                           ;; requires that it is lexically scoped.
 925                           (timer (run-at-time 2.0 nil 'ignore)))
 926                        (if (featurep 'xemacs)
 927                            (lambda (process state)
 928                              (when (eq 'exit (process-status process))
 929                                (if (memq timer itimer-list)
 930                                    (set-itimer-function timer fn)
 931                                  (funcall fn))
 932                                (ignore-errors (eval fm))
 933                                (message "%s" done)))
 934                          (lambda (process state)
 935                            (when (eq 'exit (process-status process))
 936                              (if (memq timer timer-list)
 937                                  (timer-set-function timer fn)
 938                                (funcall fn))
 939                              (ignore-errors (eval fm))
 940                              (message "%s" done)))))))
 941                 (mm-handle-set-external-undisplayer
 942                  handle (cons file buffer)))
 943               (message "Displaying %s..." command))
 944             'external)))))))
 945
 946 (defun mm-mailcap-command (method file type-list)
 947   (let ((ctl (cdr type-list))
 948         (beg 0)
 949         (uses-stdin t)
 950         out sub total)
 951     (while (string-match "%{\\([^}]+\\)}\\|'%s'\\|\"%s\"\\|%s\\|%t\\|%%"
 952                          method beg)
 953       (push (substring method beg (match-beginning 0)) out)
 954       (setq beg (match-end 0)
 955             total (match-string 0 method)
 956             sub (match-string 1 method))
 957       (cond
 958        ((string= total "%%")
 959         (push "%" out))
 960        ((or (string= total "%s")
 961             ;; We do our own quoting.
 962             (string= total "'%s'")
 963             (string= total "\"%s\""))
 964         (setq uses-stdin nil)
 965         (push (shell-quote-argument
 966                (gnus-map-function mm-path-name-rewrite-functions file)) out))
 967        ((string= total "%t")
 968         (push (shell-quote-argument (car type-list)) out))
 969        (t
 970         (push (shell-quote-argument (or (cdr (assq (intern sub) ctl)) "")) out))))
 971     (push (substring method beg (length method)) out)
 972     (when uses-stdin
 973       (push "<" out)
 974       (push (shell-quote-argument
 975              (gnus-map-function mm-path-name-rewrite-functions file))
 976             out))
 977     (mapconcat 'identity (nreverse out) "")))
 978
 979 (defun mm-remove-parts (handles)
 980   "Remove the displayed MIME parts represented by HANDLES."
 981   (if (and (listp handles)
 982            (bufferp (car handles)))
 983       (mm-remove-part handles)
 984     (let (handle)
 985       (while (setq handle (pop handles))
 986         (cond
 987          ((stringp handle)
 988           (when (buffer-live-p (get-text-property 0 'buffer handle))
 989             (kill-buffer (get-text-property 0 'buffer handle))))
 990          ((and (listp handle)
 991                (stringp (car handle)))
 992           (mm-remove-parts (cdr handle)))
 993          (t
 994           (mm-remove-part handle)))))))
 995
 996 (defun mm-destroy-parts (handles)
 997   "Remove the displayed MIME parts represented by HANDLES."
 998   (if (and (listp handles)
 999            (bufferp (car handles)))
1000       (mm-destroy-part handles)
1001     (let (handle)
1002       (while (setq handle (pop handles))
1003         (cond
1004          ((stringp handle)
1005           (when (buffer-live-p (get-text-property 0 'buffer handle))
1006             (kill-buffer (get-text-property 0 'buffer handle))))
1007          ((and (listp handle)
1008                (stringp (car handle)))
1009           (mm-destroy-parts handle))
1010          (t
1011           (mm-destroy-part handle)))))))
1012
1013 (defun mm-remove-part (handle)
1014   "Remove the displayed MIME part represented by HANDLE."
1015   (when (listp handle)
1016     (let ((object (mm-handle-undisplayer handle)))
1017       (ignore-errors
1018         (cond
1019          ;; Internally displayed part.
1020          ((mm-annotationp object)
1021           (if (featurep 'xemacs)
1022               (delete-annotation object)))
1023          ((or (functionp object)
1024               (and (listp object)
1025                    (eq (car object) 'lambda)))
1026           (funcall object))
1027          ;; Externally displayed part.
1028          ((consp object)
1029           (condition-case ()
1030               (while (get-buffer-process (cdr object))
1031                 (interrupt-process (get-buffer-process (cdr object)))
1032                 (message "Waiting for external displayer to die...")
1033                 (sit-for 1))
1034             (quit)
1035             (error))
1036           (ignore-errors (and (cdr object) (kill-buffer (cdr object))))
1037           (message "Waiting for external displayer to die...done")
1038           (ignore-errors (delete-file (car object)))
1039           (ignore-errors (delete-directory (file-name-directory
1040                                             (car object)))))
1041          ((bufferp object)
1042           (when (buffer-live-p object)
1043             (kill-buffer object)))))
1044       (mm-handle-set-undisplayer handle nil))))
1045
1046 (defun mm-display-inline (handle)
1047   (let* ((type (mm-handle-media-type handle))
1048          (function (cadr (mm-assoc-string-match mm-inline-media-tests type))))
1049     (funcall function handle)
1050     (goto-char (point-min))))
1051
1052 (defun mm-assoc-string-match (alist type)
1053   (dolist (elem alist)
1054     (when (string-match (car elem) type)
1055       (return elem))))
1056
1057 (defun mm-automatic-display-p (handle)
1058   "Say whether the user wants HANDLE to be displayed automatically."
1059   (let ((methods mm-automatic-display)
1060         (type (mm-handle-media-type handle))
1061         method result)
1062     (while (setq method (pop methods))
1063       (when (and (not (mm-inline-override-p handle))
1064                  (string-match method type))
1065         (setq result t
1066               methods nil)))
1067     result))
1068
1069 (defun mm-inlinable-p (handle &optional type)
1070   "Say whether HANDLE can be displayed inline.
1071 TYPE is the mime-type of the object; it defaults to the one given
1072 in HANDLE."
1073   (unless type (setq type (mm-handle-media-type handle)))
1074   (let ((alist mm-inline-media-tests)
1075         test)
1076     (while alist
1077       (when (string-match (caar alist) type)
1078         (setq test (caddar alist)
1079               alist nil)
1080         (setq test (funcall test handle)))
1081       (pop alist))
1082     test))
1083
1084 (defun mm-inlined-p (handle)
1085   "Say whether the user wants HANDLE to be displayed inline."
1086   (let ((methods mm-inlined-types)
1087         (type (mm-handle-media-type handle))
1088         method result)
1089     (while (setq method (pop methods))
1090       (when (and (not (mm-inline-override-p handle))
1091                  (string-match method type))
1092         (setq result t
1093               methods nil)))
1094     result))
1095
1096 (defun mm-attachment-override-p (handle)
1097   "Say whether HANDLE should have attachment behavior overridden."
1098   (let ((types mm-attachment-override-types)
1099         (type (mm-handle-media-type handle))
1100         ty)
1101     (catch 'found
1102       (while (setq ty (pop types))
1103         (when (and (string-match ty type)
1104                    (mm-inlinable-p handle))
1105           (throw 'found t))))))
1106
1107 (defun mm-inline-override-p (handle)
1108   "Say whether HANDLE should have inline behavior overridden."
1109   (let ((types mm-inline-override-types)
1110         (type (mm-handle-media-type handle))
1111         ty)
1112     (catch 'found
1113       (while (setq ty (pop types))
1114         (when (string-match ty type)
1115           (throw 'found t))))))
1116
1117 (defun mm-automatic-external-display-p (type)
1118   "Return the user-defined method for TYPE."
1119   (let ((methods mm-automatic-external-display)
1120         method result)
1121     (while (setq method (pop methods))
1122       (when (string-match method type)
1123         (setq result t
1124               methods nil)))
1125     result))
1126
1127 (defun mm-destroy-part (handle)
1128   "Destroy the data structures connected to HANDLE."
1129   (when (listp handle)
1130     (mm-remove-part handle)
1131     (when (buffer-live-p (mm-handle-buffer handle))
1132       (kill-buffer (mm-handle-buffer handle)))))
1133
1134 (defun mm-handle-displayed-p (handle)
1135   "Say whether HANDLE is displayed or not."
1136   (mm-handle-undisplayer handle))
1137
1138 ;;;
1139 ;;; Functions for outputting parts
1140 ;;;
1141
1142 (defmacro mm-with-part (handle &rest forms)
1143   "Run FORMS in the temp buffer containing the contents of HANDLE."
1144   ;; The handle-buffer's content is a sequence of bytes, not a sequence of
1145   ;; chars, so the buffer should be unibyte.  It may happen that the
1146   ;; handle-buffer is multibyte for some reason, in which case now is a good
1147   ;; time to adjust it, since we know at this point that it should
1148   ;; be unibyte.
1149   `(let* ((handle ,handle))
1150      (when (and (mm-handle-buffer handle)
1151                 (buffer-name (mm-handle-buffer handle)))
1152        (with-temp-buffer
1153          (mm-disable-multibyte)
1154          (insert-buffer-substring (mm-handle-buffer handle))
1155          (mm-decode-content-transfer-encoding
1156           (mm-handle-encoding handle)
1157           (mm-handle-media-type handle))
1158          ,@forms))))
1159 (put 'mm-with-part 'lisp-indent-function 1)
1160 (put 'mm-with-part 'edebug-form-spec '(body))
1161
1162 (defun mm-get-part (handle &optional no-cache)
1163   "Return the contents of HANDLE as a string.
1164 If NO-CACHE is non-nil, cached contents of a message/external-body part
1165 are ignored."
1166   (if (and (not no-cache)
1167            (equal (mm-handle-media-type handle) "message/external-body"))
1168       (progn
1169         (unless (mm-handle-cache handle)
1170           (mm-extern-cache-contents handle))
1171         (with-current-buffer (mm-handle-buffer (mm-handle-cache handle))
1172           (buffer-string)))
1173     (mm-with-part handle
1174       (buffer-string))))
1175
1176 (defun mm-insert-part (handle &optional no-cache)
1177   "Insert the contents of HANDLE in the current buffer.
1178 If NO-CACHE is non-nil, cached contents of a message/external-body part
1179 are ignored."
1180   (let ((text (cond ((eq (mail-content-type-get (mm-handle-type handle)
1181                                                 'charset)
1182                          'gnus-decoded)
1183                      (with-current-buffer (mm-handle-buffer handle)
1184                        (buffer-string)))
1185                     ((mm-multibyte-p)
1186                      (mm-string-to-multibyte (mm-get-part handle no-cache)))
1187                     (t
1188                      (mm-get-part handle no-cache)))))
1189     (save-restriction
1190       (widen)
1191       (goto-char
1192        (prog1
1193            (point)
1194          (if (and (eq (get-char-property (max (point-min) (1- (point))) 'face)
1195                       'mm-uu-extract)
1196                   (eq (get-char-property 0 'face text) 'mm-uu-extract))
1197              ;; Separate the extracted parts that have the same faces.
1198              (insert "\n" text)
1199            (insert text)))))))
1200
1201 (defun mm-file-name-delete-whitespace (file-name)
1202   "Remove all whitespace characters from FILE-NAME."
1203   (while (string-match "\\s-+" file-name)
1204     (setq file-name (replace-match "" t t file-name)))
1205   file-name)
1206
1207 (defun mm-file-name-trim-whitespace (file-name)
1208   "Remove leading and trailing whitespace characters from FILE-NAME."
1209   (when (string-match "\\`\\s-+" file-name)
1210     (setq file-name (substring file-name (match-end 0))))
1211   (when (string-match "\\s-+\\'" file-name)
1212     (setq file-name (substring file-name 0 (match-beginning 0))))
1213   file-name)
1214
1215 (defun mm-file-name-collapse-whitespace (file-name)
1216   "Collapse multiple whitespace characters in FILE-NAME."
1217   (while (string-match "\\s-\\s-+" file-name)
1218     (setq file-name (replace-match " " t t file-name)))
1219   file-name)
1220
1221 (defun mm-file-name-replace-whitespace (file-name)
1222   "Replace whitespace characters in FILE-NAME with underscores.
1223 Set the option `mm-file-name-replace-whitespace' to any other
1224 string if you do not like underscores."
1225   (let ((s (or mm-file-name-replace-whitespace "_")))
1226     (while (string-match "\\s-" file-name)
1227       (setq file-name (replace-match s t t file-name))))
1228   file-name)
1229
1230 (defun mm-file-name-delete-control (filename)
1231   "Delete control characters from FILENAME."
1232   (gnus-replace-in-string filename "[\x00-\x1f\x7f]" ""))
1233
1234 (defun mm-file-name-delete-gotchas (filename)
1235   "Delete shell gotchas from FILENAME."
1236   (setq filename (gnus-replace-in-string filename "[<>|]" ""))
1237   (gnus-replace-in-string filename "^[.-]+" ""))
1238
1239 (defun mm-save-part (handle &optional prompt)
1240   "Write HANDLE to a file.
1241 PROMPT overrides the default one used to ask user for a file name."
1242   (let ((filename (or (mail-content-type-get
1243                        (mm-handle-disposition handle) 'filename)
1244                       (mail-content-type-get
1245                        (mm-handle-type handle) 'name)))
1246         file)
1247     (when filename
1248       (setq filename (gnus-map-function mm-file-name-rewrite-functions
1249                                         (file-name-nondirectory filename))))
1250     (setq file
1251           (read-file-name
1252            (or prompt
1253                (format "Save MIME part to (default %s): "
1254                        (or filename "")))
1255            (or mm-default-directory default-directory)
1256            (expand-file-name (or filename "")
1257                              (or mm-default-directory default-directory))))
1258     (if (file-directory-p file)
1259         (setq file (expand-file-name filename file))
1260       (setq file (expand-file-name
1261                   file (or mm-default-directory default-directory))))
1262     (setq mm-default-directory (file-name-directory file))
1263     (and (or (not (file-exists-p file))
1264              (yes-or-no-p (format "File %s already exists; overwrite? "
1265                                   file)))
1266          (progn
1267            (mm-save-part-to-file handle file)
1268            file))))
1269
1270 (defun mm-add-meta-html-tag (handle &optional charset force-charset)
1271   "Add meta html tag to specify CHARSET of HANDLE in the current buffer.
1272 CHARSET defaults to the one HANDLE specifies.  Existing meta tag that
1273 specifies charset will not be modified unless FORCE-CHARSET is non-nil.
1274 Return t if meta tag is added or replaced."
1275   (when (equal (mm-handle-media-type handle) "text/html")
1276     (when (or charset
1277               (setq charset (mail-content-type-get (mm-handle-type handle)
1278                                                    'charset)))
1279       (setq charset (format "\
1280 <meta http-equiv=\"Content-Type\" content=\"text/html; charset=%s\">" charset))
1281       (let ((case-fold-search t))
1282         (goto-char (point-min))
1283         (if (re-search-forward "\
1284 <meta\\s-+http-equiv=[\"']?content-type[\"']?\\s-+content=[\"']\
1285 text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t)
1286             (if (and (not force-charset)
1287                      (match-beginning 2)
1288                      (string-match "\\`html\\'" (match-string 1)))
1289                 ;; Don't modify existing meta tag.
1290                 nil
1291               ;; Replace it with the one specifying charset.
1292               (replace-match charset)
1293               t)
1294           (if (re-search-forward "<head>\\s-*" nil t)
1295               (insert charset "\n")
1296             (re-search-forward "<html\\(?:\\s-+[^>]+\\|\\s-*\\)>\\s-*" nil t)
1297             (insert "<head>\n" charset "\n</head>\n"))
1298           t)))))
1299
1300 (defun mm-save-part-to-file (handle file)
1301   (mm-with-unibyte-buffer
1302     (mm-insert-part handle)
1303     (mm-add-meta-html-tag handle)
1304     (let ((current-file-modes (default-file-modes)))
1305       (set-default-file-modes mm-attachment-file-modes)
1306       (unwind-protect
1307           ;; Don't re-compress .gz & al.  Arguably we should make
1308           ;; `file-name-handler-alist' nil, but that would chop
1309           ;; ange-ftp, which is reasonable to use here.
1310           (mm-write-region (point-min) (point-max) file nil nil nil 'binary t)
1311         (set-default-file-modes current-file-modes)))))
1312
1313 (defun mm-pipe-part (handle &optional cmd)
1314   "Pipe HANDLE to a process.
1315 Use CMD as the process."
1316   (let ((name (mail-content-type-get (mm-handle-type handle) 'name))
1317         (command (or cmd
1318                      (gnus-read-shell-command
1319                       "Shell command on MIME part: " mm-last-shell-command))))
1320     (mm-with-unibyte-buffer
1321       (mm-insert-part handle)
1322       (mm-add-meta-html-tag handle)
1323       (let ((coding-system-for-write 'binary))
1324         (shell-command-on-region (point-min) (point-max) command nil)))))
1325
1326 (autoload 'gnus-completing-read "gnus-util")
1327
1328 (defun mm-interactively-view-part (handle)
1329   "Display HANDLE using METHOD."
1330   (let* ((type (mm-handle-media-type handle))
1331          (methods
1332           (mapcar (lambda (i) (cdr (assoc 'viewer i)))
1333                   (mailcap-mime-info type 'all)))
1334          (method (let ((minibuffer-local-completion-map
1335                         mm-viewer-completion-map))
1336                    (gnus-completing-read "Viewer" methods))))
1337     (when (string= method "")
1338       (error "No method given"))
1339     (if (string-match "^[^% \t]+$" method)
1340         (setq method (concat method " %s")))
1341     (mm-display-external handle method)))
1342
1343 (defun mm-preferred-alternative (handles &optional preferred)
1344   "Say which of HANDLES are preferred."
1345   (let ((prec (if preferred (list preferred)
1346                 (mm-preferred-alternative-precedence handles)))
1347         p h result type handle)
1348     (while (setq p (pop prec))
1349       (setq h handles)
1350       (while h
1351         (setq handle (car h))
1352         (setq type (mm-handle-media-type handle))
1353         (when (and (equal p type)
1354                    (mm-automatic-display-p handle)
1355                    (or (stringp (car handle))
1356                        (not (mm-handle-disposition handle))
1357                        (equal (car (mm-handle-disposition handle))
1358                               "inline")))
1359           (setq result handle
1360                 h nil
1361                 prec nil))
1362         (pop h)))
1363     result))
1364
1365 (defun mm-preferred-alternative-precedence (handles)
1366   "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
1367   (setq handles (reverse handles))
1368   (dolist (disc (reverse mm-discouraged-alternatives))
1369     (dolist (handle (copy-sequence handles))
1370       (when (string-match disc (mm-handle-media-type handle))
1371         (setq handles (nconc (delete handle handles) (list handle))))))
1372   ;; Remove empty parts.
1373   (dolist (handle (copy-sequence handles))
1374     (when (and (bufferp (mm-handle-buffer handle))
1375                (not (with-current-buffer (mm-handle-buffer handle)
1376                       (goto-char (point-min))
1377                       (re-search-forward "[^ \t\n]" nil t))))
1378       (setq handles (nconc (delete handle handles) (list handle)))))
1379   (mapcar #'mm-handle-media-type handles))
1380
1381 (defun mm-get-content-id (id)
1382   "Return the handle(s) referred to by ID."
1383   (cdr (assoc id mm-content-id-alist)))
1384
1385 (defconst mm-image-type-regexps
1386   '(("/\\*.*XPM.\\*/" . xpm)
1387     ("P[1-6]" . pbm)
1388     ("GIF8" . gif)
1389     ("\377\330" . jpeg)
1390     ("\211PNG\r\n" . png)
1391     ("#define" . xbm)
1392     ("\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
1393     ("%!PS" . postscript))
1394   "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
1395 When the first bytes of an image file match REGEXP, it is assumed to
1396 be of image type IMAGE-TYPE.")
1397
1398 ;; Steal from image.el. image-type-from-data suffers multi-line matching bug.
1399 (defun mm-image-type-from-buffer ()
1400   "Determine the image type from data in the current buffer.
1401 Value is a symbol specifying the image type or nil if type cannot
1402 be determined."
1403   (let ((types mm-image-type-regexps)
1404         type)
1405     (goto-char (point-min))
1406     (while (and types (null type))
1407       (let ((regexp (car (car types)))
1408             (image-type (cdr (car types))))
1409         (when (looking-at regexp)
1410           (setq type image-type))
1411         (setq types (cdr types))))
1412     type))
1413
1414 (defun mm-get-image (handle)
1415   "Return an image instance based on HANDLE."
1416   (let ((type (mm-handle-media-subtype handle))
1417         spec)
1418     ;; Allow some common translations.
1419     (setq type
1420           (cond
1421            ((equal type "x-pixmap")
1422             "xpm")
1423            ((equal type "x-xbitmap")
1424             "xbm")
1425            ((equal type "x-portable-bitmap")
1426             "pbm")
1427            (t type)))
1428     (or (mm-handle-cache handle)
1429         (mm-with-unibyte-buffer
1430           (mm-insert-part handle)
1431           (prog1
1432               (setq spec
1433                     (ignore-errors
1434                       ;; Avoid testing `make-glyph' since W3 may define
1435                       ;; a bogus version of it.
1436                       (if (fboundp 'create-image)
1437                           (create-image (buffer-string)
1438                                         (or (mm-image-type-from-buffer)
1439                                             (intern type))
1440                                         'data-p)
1441                         (mm-create-image-xemacs type))))
1442             (mm-handle-set-cache handle spec))))))
1443
1444 (defun mm-create-image-xemacs (type)
1445   (when (featurep 'xemacs)
1446     (cond
1447      ((equal type "xbm")
1448       ;; xbm images require special handling, since
1449       ;; the only way to create glyphs from these
1450       ;; (without a ton of work) is to write them
1451       ;; out to a file, and then create a file
1452       ;; specifier.
1453       (let ((file (mm-make-temp-file
1454                    (expand-file-name "emm" mm-tmp-directory)
1455                    nil ".xbm")))
1456         (unwind-protect
1457             (progn
1458               (write-region (point-min) (point-max) file)
1459               (make-glyph (list (cons 'x file))))
1460           (ignore-errors
1461             (delete-file file)))))
1462      (t
1463       (make-glyph
1464        (vector
1465         (or (mm-image-type-from-buffer)
1466             (intern type))
1467         :data (buffer-string)))))))
1468
1469 (declare-function image-size "image.c" (spec &optional pixels frame))
1470
1471 (defun mm-image-fit-p (handle)
1472   "Say whether the image in HANDLE will fit the current window."
1473   (let ((image (mm-get-image handle)))
1474     (or (not image)
1475         (if (featurep 'xemacs)
1476             ;; XEmacs' glyphs can actually tell us about their width, so
1477             ;; lets be nice and smart about them.
1478             (or mm-inline-large-images
1479                 (and (<= (glyph-width image) (window-pixel-width))
1480                      (<= (glyph-height image) (window-pixel-height))))
1481           (let* ((size (image-size image))
1482                  (w (car size))
1483                  (h (cdr size)))
1484             (or mm-inline-large-images
1485                 (and (<= h (1- (window-height))) ; Don't include mode line.
1486                      (<= w (window-width)))))))))
1487
1488 (defun mm-valid-image-format-p (format)
1489   "Say whether FORMAT can be displayed natively by Emacs."
1490   (cond
1491    ;; Handle XEmacs
1492    ((fboundp 'valid-image-instantiator-format-p)
1493     (valid-image-instantiator-format-p format))
1494    ;; Handle Emacs
1495    ((fboundp 'image-type-available-p)
1496     (and (display-graphic-p)
1497          (image-type-available-p format)))
1498    ;; Nobody else can do images yet.
1499    (t
1500     nil)))
1501
1502 (defun mm-valid-and-fit-image-p (format handle)
1503   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
1504   (and (mm-valid-image-format-p format)
1505        (mm-image-fit-p handle)))
1506
1507 (defun mm-find-part-by-type (handles type &optional notp recursive)
1508   "Search in HANDLES for part with TYPE.
1509 If NOTP, returns first non-matching part.
1510 If RECURSIVE, search recursively."
1511   (let (handle)
1512     (while handles
1513       (if (and recursive (stringp (caar handles)))
1514           (if (setq handle (mm-find-part-by-type (cdar handles) type
1515                                                  notp recursive))
1516               (setq handles nil))
1517         (if (if notp
1518                 (not (equal (mm-handle-media-type (car handles)) type))
1519               (equal (mm-handle-media-type (car handles)) type))
1520             (setq handle (car handles)
1521                   handles nil)))
1522       (setq handles (cdr handles)))
1523     handle))
1524
1525 (defun mm-find-raw-part-by-type (ctl type &optional notp)
1526   (goto-char (point-min))
1527   (let* ((boundary (concat "--" (mm-handle-multipart-ctl-parameter ctl
1528                                                                    'boundary)))
1529          (close-delimiter (concat "^" (regexp-quote boundary) "--[ \t]*$"))
1530          start
1531          (end (save-excursion
1532                 (goto-char (point-max))
1533                 (if (re-search-backward close-delimiter nil t)
1534                     (match-beginning 0)
1535                   (point-max))))
1536          result)
1537     (setq boundary (concat "^" (regexp-quote boundary) "[ \t]*$"))
1538     (while (and (not result)
1539                 (re-search-forward boundary end t))
1540       (goto-char (match-beginning 0))
1541       (when start
1542         (save-excursion
1543           (save-restriction
1544             (narrow-to-region start (1- (point)))
1545             (when (let* ((ct (mail-fetch-field "content-type"))
1546                          (ctl (and ct (mail-header-parse-content-type ct))))
1547                     (if notp
1548                         (not (equal (car ctl) type))
1549                       (equal (car ctl) type)))
1550               (setq result (buffer-string))))))
1551       (forward-line 1)
1552       (setq start (point)))
1553     (when (and (not result) start)
1554       (save-excursion
1555         (save-restriction
1556           (narrow-to-region start end)
1557           (when (let* ((ct (mail-fetch-field "content-type"))
1558                        (ctl (and ct (mail-header-parse-content-type ct))))
1559                   (if notp
1560                       (not (equal (car ctl) type))
1561                     (equal (car ctl) type)))
1562             (setq result (buffer-string))))))
1563     result))
1564
1565 (defvar mm-security-handle nil)
1566
1567 (defsubst mm-set-handle-multipart-parameter (handle parameter value)
1568   ;; HANDLE could be a CTL.
1569   (when handle
1570     (put-text-property 0 (length (car handle)) parameter value
1571                        (car handle))))
1572
1573 (autoload 'mm-view-pkcs7 "mm-view")
1574
1575 (defun mm-possibly-verify-or-decrypt (parts ctl &optional from)
1576   (let ((type (car ctl))
1577         (subtype (cadr (split-string (car ctl) "/")))
1578         (mm-security-handle ctl) ;; (car CTL) is the type.
1579         protocol func functest)
1580     (cond
1581      ((or (equal type "application/x-pkcs7-mime")
1582           (equal type "application/pkcs7-mime"))
1583       (with-temp-buffer
1584         (when (and (cond
1585                     ((eq mm-decrypt-option 'never) nil)
1586                     ((eq mm-decrypt-option 'always) t)
1587                     ((eq mm-decrypt-option 'known) t)
1588                     (t (y-or-n-p
1589                         (format "Decrypt (S/MIME) part? "))))
1590                    (mm-view-pkcs7 parts from))
1591           (setq parts (mm-dissect-buffer t)))))
1592      ((equal subtype "signed")
1593       (unless (and (setq protocol
1594                          (mm-handle-multipart-ctl-parameter ctl 'protocol))
1595                    (not (equal protocol "multipart/mixed")))
1596         ;; The message is broken or draft-ietf-openpgp-multsig-01.
1597         (let ((protocols mm-verify-function-alist))
1598           (while protocols
1599             (if (and (or (not (setq functest (nth 3 (car protocols))))
1600                          (funcall functest parts ctl))
1601                      (mm-find-part-by-type parts (caar protocols) nil t))
1602                 (setq protocol (caar protocols)
1603                       protocols nil)
1604               (setq protocols (cdr protocols))))))
1605       (setq func (nth 1 (assoc protocol mm-verify-function-alist)))
1606       (when (cond
1607              ((eq mm-verify-option 'never) nil)
1608              ((eq mm-verify-option 'always) t)
1609              ((eq mm-verify-option 'known)
1610               (and func
1611                    (or (not (setq functest
1612                                   (nth 3 (assoc protocol
1613                                                 mm-verify-function-alist))))
1614                        (funcall functest parts ctl))))
1615              (t
1616               (y-or-n-p
1617                (format "Verify signed (%s) part? "
1618                        (or (nth 2 (assoc protocol mm-verify-function-alist))
1619                            (format "protocol=%s" protocol))))))
1620         (save-excursion
1621           (if func
1622               (setq parts (funcall func parts ctl))
1623             (mm-set-handle-multipart-parameter
1624              mm-security-handle 'gnus-details
1625              (format "Unknown sign protocol (%s)" protocol))))))
1626      ((equal subtype "encrypted")
1627       (unless (setq protocol
1628                     (mm-handle-multipart-ctl-parameter ctl 'protocol))
1629         ;; The message is broken.
1630         (let ((parts parts))
1631           (while parts
1632             (if (assoc (mm-handle-media-type (car parts))
1633                        mm-decrypt-function-alist)
1634                 (setq protocol (mm-handle-media-type (car parts))
1635                       parts nil)
1636               (setq parts (cdr parts))))))
1637       (setq func (nth 1 (assoc protocol mm-decrypt-function-alist)))
1638       (when (cond
1639              ((eq mm-decrypt-option 'never) nil)
1640              ((eq mm-decrypt-option 'always) t)
1641              ((eq mm-decrypt-option 'known)
1642               (and func
1643                    (or (not (setq functest
1644                                   (nth 3 (assoc protocol
1645                                                 mm-decrypt-function-alist))))
1646                        (funcall functest parts ctl))))
1647              (t
1648               (y-or-n-p
1649                (format "Decrypt (%s) part? "
1650                        (or (nth 2 (assoc protocol mm-decrypt-function-alist))
1651                            (format "protocol=%s" protocol))))))
1652         (save-excursion
1653           (if func
1654               (setq parts (funcall func parts ctl))
1655             (mm-set-handle-multipart-parameter
1656              mm-security-handle 'gnus-details
1657              (format "Unknown encrypt protocol (%s)" protocol))))))
1658      (t nil))
1659     parts))
1660
1661 (defun mm-multiple-handles (handles)
1662   (and (listp handles)
1663        (> (length handles) 1)
1664        (or (listp (car handles))
1665            (stringp (car handles)))))
1666
1667 (defun mm-complicated-handles (handles)
1668   (and (listp (car handles))
1669        (> (length handles) 1)))
1670
1671 (defun mm-merge-handles (handles1 handles2)
1672   (append
1673    (if (listp (car handles1))
1674        handles1
1675      (list handles1))
1676    (if (listp (car handles2))
1677        handles2
1678      (list handles2))))
1679
1680 (defun mm-readable-p (handle)
1681   "Say whether the content of HANDLE is readable."
1682   (and (< (with-current-buffer (mm-handle-buffer handle)
1683             (buffer-size)) 10000)
1684        (mm-with-unibyte-buffer
1685          (mm-insert-part handle)
1686          (and (eq (mm-body-7-or-8) '7bit)
1687               (not (mm-long-lines-p 76))))))
1688
1689 (declare-function libxml-parse-html-region "xml.c"
1690                   (start end &optional base-url))
1691 (declare-function shr-insert-document "shr" (dom))
1692 (defvar shr-blocked-images)
1693 (defvar gnus-inhibit-images)
1694 (autoload 'gnus-blocked-images "gnus-art")
1695
1696 (defun mm-shr (handle)
1697   ;; Require since we bind its variables.
1698   (require 'shr)
1699   (let ((article-buffer (current-buffer))
1700         (shr-content-function (lambda (id)
1701                                 (let ((handle (mm-get-content-id id)))
1702                                   (when handle
1703                                     (mm-with-part handle
1704                                       (buffer-string))))))
1705         shr-inhibit-images shr-blocked-images charset char)
1706     (if (and (boundp 'gnus-summary-buffer)
1707              (buffer-name gnus-summary-buffer))
1708         (with-current-buffer gnus-summary-buffer
1709           (setq shr-inhibit-images gnus-inhibit-images
1710                 shr-blocked-images (gnus-blocked-images)))
1711       (setq shr-inhibit-images gnus-inhibit-images
1712             shr-blocked-images (gnus-blocked-images)))
1713     (unless handle
1714       (setq handle (mm-dissect-buffer t)))
1715     (setq charset (mail-content-type-get (mm-handle-type handle) 'charset))
1716     (save-restriction
1717       (narrow-to-region (point) (point))
1718       (shr-insert-document
1719        (mm-with-part handle
1720          (insert (prog1
1721                      (if (and charset
1722                               (setq charset
1723                                     (mm-charset-to-coding-system charset))
1724                               (not (eq charset 'ascii)))
1725                          (mm-decode-coding-string (buffer-string) charset)
1726                        (mm-string-as-multibyte (buffer-string)))
1727                    (erase-buffer)
1728                    (mm-enable-multibyte)))
1729          (goto-char (point-min))
1730          (setq case-fold-search t)
1731          (while (re-search-forward
1732                  "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t)
1733            (when (setq char
1734                        (cdr (assq (if (match-beginning 1)
1735                                       (string-to-number (match-string 1) 16)
1736                                     (string-to-number (match-string 2)))
1737                                   mm-extra-numeric-entities)))
1738              (replace-match (char-to-string char))))
1739          (libxml-parse-html-region (point-min) (point-max))))
1740       (mm-handle-set-undisplayer
1741        handle
1742        `(lambda ()
1743           (let ((inhibit-read-only t))
1744             (delete-region ,(point-min-marker)
1745                            ,(point-max-marker))))))))
1746
1747 (defun mm-handle-filename (handle)
1748   "Return filename of HANDLE if any."
1749   (or (mail-content-type-get (mm-handle-type handle)
1750                              'name)
1751       (mail-content-type-get (mm-handle-disposition handle)
1752                              'filename)))
1753
1754 (provide 'mm-decode)
1755
1756 ;;; mm-decode.el ends here