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