cgit.sxemacs.org Git - gnus/blob - lisp/mm-decode.el

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