X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=e6407cf1a3fe3d8dccebb0431a0576ff47c6fa66;hp=72bf61bed24c6154330b70ed93ae3391ea3ec410;hb=d84b26f66f1975b52a15ca2caf5f10da5103e42e;hpb=e9c0c3e1a897728fef338d204074bdc6c46f5e5d diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 72bf61bed..e6407cf1a 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,7 +1,6 @@ ;;; mm-decode.el --- Functions for decoding MIME things -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1998-2012 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -24,12 +23,13 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) (require 'mail-parse) (require 'mm-bodies) +(require 'mm-archive) (eval-when-compile (require 'cl) (require 'term)) @@ -105,8 +105,8 @@ ,disposition ,description ,cache ,id)) (defcustom mm-text-html-renderer - (cond ((fboundp 'libxml-parse-html-region) 'mm-shr) - ((executable-find "w3m") 'gnus-article-html) + (cond ((fboundp 'libxml-parse-html-region) 'shr) + ((executable-find "w3m") 'gnus-w3m) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) ((locate-library "w3") 'w3) @@ -115,16 +115,18 @@ "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: -`gnus-article-html' : use Gnus renderer based on w3m; -`w3m' : use emacs-w3m; -`w3m-standalone': use w3m; +`shr': use the built-in Gnus HTML renderer; +`gnus-w3m': use Gnus renderer based on w3m; +`w3m': use emacs-w3m; +`w3m-standalone': use plain w3m; `links': use links; -`lynx' : use lynx; -`w3' : use Emacs/W3; -`html2text' : use html2text; +`lynx': use lynx; +`w3': use Emacs/W3; +`html2text': use html2text; nil : use external viewer (default web browser)." :version "24.1" - :type '(choice (const gnus-article-html) + :type '(choice (const shr) + (const gnus-w3m) (const w3) (const w3m :tag "emacs-w3m") (const w3m-standalone :tag "standalone w3m" ) @@ -135,10 +137,6 @@ nil : use external viewer (default web browser)." (function)) :group 'mime-display) -(defvar mm-inline-text-html-renderer nil - "Function used for rendering inline HTML contents. -It is suggested to customize `mm-text-html-renderer' instead.") - (defcustom mm-inline-text-html-with-images nil "If non-nil, Gnus will allow retrieving images in HTML contents with the tags. It has no effect on Emacs/w3. See also the @@ -198,7 +196,7 @@ before the external MIME handler is invoked." ("image/tiff" mm-inline-image (lambda (handle) - (mm-valid-and-fit-image-p 'tiff handle)) ) + (mm-valid-and-fit-image-p 'tiff handle))) ("image/xbm" mm-inline-image (lambda (handle) @@ -226,25 +224,21 @@ before the external MIME handler is invoked." ("text/plain" mm-inline-text identity) ("text/enriched" mm-inline-text identity) ("text/richtext" mm-inline-text identity) - ("text/x-patch" mm-display-patch-inline - (lambda (handle) - ;; If the diff-mode.el package is installed, the function is - ;; autoloaded. Checking (locate-library "diff-mode") would be trying - ;; to cater to broken installations. OTOH checking the function - ;; makes it possible to install another package which provides an - ;; alternative implementation of diff-mode. --Stef - (fboundp 'diff-mode))) + ("text/x-patch" mm-display-patch-inline identity) ;; In case mime.types uses x-diff (as does Debian's mime-support-3.40). - ("text/x-diff" mm-display-patch-inline - (lambda (handle) (fboundp 'diff-mode))) + ("text/x-diff" mm-display-patch-inline identity) ("application/emacs-lisp" mm-display-elisp-inline identity) ("application/x-emacs-lisp" mm-display-elisp-inline identity) + ("application/x-shellscript" mm-display-shell-script-inline identity) + ("application/x-sh" mm-display-shell-script-inline identity) + ("text/x-sh" mm-display-shell-script-inline identity) + ("application/javascript" mm-display-javascript-inline identity) ("text/dns" mm-display-dns-inline identity) + ("text/x-org" mm-display-org-inline identity) ("text/html" mm-inline-text-html (lambda (handle) - (or mm-inline-text-html-renderer - mm-text-html-renderer))) + mm-text-html-renderer)) ("text/x-vcard" mm-inline-text-vcard (lambda (handle) @@ -272,6 +266,20 @@ before the external MIME handler is invoked." ("multipart/alternative" ignore identity) ("multipart/mixed" ignore identity) ("multipart/related" ignore identity) + ("image/.*" + mm-inline-image + (lambda (handle) + (and (mm-valid-image-format-p 'imagemagick) + (mm-with-unibyte-buffer + (mm-insert-part handle) + (let ((image + (ignore-errors + (if (fboundp 'create-image) + (create-image (buffer-string) 'imagemagick 'data-p) + (mm-create-image-xemacs (mm-handle-media-subtype handle)))))) + (when image + (setcar (cdr handle) (list "image/imagemagick")) + (mm-image-fit-p handle))))))) ;; Disable audio and image ("audio/.*" ignore ignore) ("image/.*" ignore ignore) @@ -316,7 +324,8 @@ when selecting a different article." "application/pkcs7-signature" "application/x-pkcs7-mime" "application/pkcs7-mime" ;; Mutt still uses this even though it has already been withdrawn. - "application/pgp\\'") + "application/pgp\\'" + "text/x-org") "A list of MIME types to be displayed automatically." :type '(repeat regexp) :group 'mime-display) @@ -352,7 +361,7 @@ to: (\"text/html\" \"text/richtext\") Adding \"image/.*\" might also be useful. Spammers use it as the -prefered part of multipart/alternative messages. See also +preferred part of multipart/alternative messages. See also `gnus-buttonized-mime-types', to which adding \"multipart/alternative\" enables you to choose manually one of two types those mails include." :type '(repeat regexp) ;; See `mm-preferred-alternative-precedence'. @@ -369,8 +378,12 @@ enables you to choose manually one of two types those mails include." :group 'mime-display) (defcustom mm-inline-large-images nil - "If non-nil, then all images fit in the buffer." - :type 'boolean + "If t, then all images fit in the buffer. +If 'resize, try to resize the images so they fit." + :type '(radio + (const :tag "Inline large images as they are." t) + (const :tag "Resize large images." resize) + (const :tag "Do not inline large images." nil)) :group 'mime-display) (defcustom mm-file-name-rewrite-functions @@ -566,7 +579,13 @@ Postpone undisplaying of viewers for types in (setq ct (mail-fetch-field "content-type") ctl (and ct (mail-header-parse-content-type ct)) cte (mail-fetch-field "content-transfer-encoding") - cd (mail-fetch-field "content-disposition") + cd (or (mail-fetch-field "content-disposition") + (when (and ctl + (eq 'mm-inline-text + (cadr (mm-assoc-string-match + mm-inline-media-tests + (car ctl))))) + "inline")) ;; Newlines in description should be stripped so as ;; not to break the MIME tag into two or more lines. description (message-fetch-field "content-description") @@ -623,7 +642,7 @@ Postpone undisplaying of viewers for types in no-strict-mime (and cd (mail-header-parse-content-disposition cd)) description id) - ctl)))) + ctl from)))) (when id (when (string-match " *<\\(.*\\)> *" id) (setq id (match-string 1 id))) @@ -635,8 +654,14 @@ Postpone undisplaying of viewers for types in (if (equal "text/plain" (car ctl)) (assoc 'format ctl) t)) - (mm-make-handle - (mm-copy-to-buffer) ctl cte nil cdl description nil id))) + (let ((handle + (mm-make-handle + (mm-copy-to-buffer) ctl cte nil cdl description nil id)) + (decoder (assoc (car ctl) mm-archive-decoders))) + (if (and decoder + (executable-find (cadr decoder))) + (mm-dissect-archive handle) + handle)))) (defun mm-dissect-multipart (ctl from) (goto-char (point-min)) @@ -665,7 +690,7 @@ Postpone undisplaying of viewers for types in (save-restriction (narrow-to-region start end) (setq parts (nconc (list (mm-dissect-buffer t nil from)) parts))))) - (mm-possibly-verify-or-decrypt (nreverse parts) ctl))) + (mm-possibly-verify-or-decrypt (nreverse parts) ctl from))) (defun mm-copy-to-buffer () "Copy the contents of the current buffer to a fresh buffer." @@ -695,13 +720,14 @@ Postpone undisplaying of viewers for types in (autoload 'mailcap-parse-mailcaps "mailcap") (autoload 'mailcap-mime-info "mailcap") -(defun mm-display-part (handle &optional no-default) +(defun mm-display-part (handle &optional no-default force) "Display the MIME part represented by HANDLE. Returns nil if the part is removed; inline if displayed inline; external if displayed external." (save-excursion (mailcap-parse-mailcaps) - (if (mm-handle-displayed-p handle) + (if (and (not force) + (mm-handle-displayed-p handle)) (mm-remove-part handle) (let* ((ehandle (if (equal (mm-handle-media-type handle) "message/external-body") @@ -923,7 +949,7 @@ external if displayed external." ;; In particular, the timer object (which is ;; a vector in Emacs but is a list in XEmacs) ;; requires that it is lexically scoped. - (timer (run-at-time 2.0 nil 'ignore))) + (timer (run-at-time 30.0 nil 'ignore))) (if (featurep 'xemacs) (lambda (process state) (when (eq 'exit (process-status process)) @@ -1249,13 +1275,17 @@ PROMPT overrides the default one used to ask user for a file name." (setq filename (gnus-map-function mm-file-name-rewrite-functions (file-name-nondirectory filename)))) (setq file - (read-file-name (or prompt - (format "Save MIME part to (default %s): " - (or filename ""))) - (or mm-default-directory default-directory) - (or filename ""))) - (when (file-directory-p file) - (setq file (expand-file-name filename file))) + (read-file-name + (or prompt + (format "Save MIME part to (default %s): " + (or filename ""))) + (or mm-default-directory default-directory) + (expand-file-name (or filename "") + (or mm-default-directory default-directory)))) + (if (file-directory-p file) + (setq file (expand-file-name filename file)) + (setq file (expand-file-name + file (or mm-default-directory default-directory)))) (setq mm-default-directory (file-name-directory file)) (and (or (not (file-exists-p file)) (yes-or-no-p (format "File %s already exists; overwrite? " @@ -1320,6 +1350,8 @@ Use CMD as the process." (let ((coding-system-for-write 'binary)) (shell-command-on-region (point-min) (point-max) command nil))))) +(autoload 'gnus-completing-read "gnus-util") + (defun mm-interactively-view-part (handle) "Display HANDLE using METHOD." (let* ((type (mm-handle-media-type handle)) @@ -1328,7 +1360,7 @@ Use CMD as the process." (mailcap-mime-info type 'all))) (method (let ((minibuffer-local-completion-map mm-viewer-completion-map)) - (gnus-completing-read "Viewer" methods)))) + (completing-read "Viewer: " methods)))) (when (string= method "") (error "No method given")) (if (string-match "^[^% \t]+$" method) @@ -1359,13 +1391,19 @@ Use CMD as the process." (defun mm-preferred-alternative-precedence (handles) "Return the precedence based on HANDLES and `mm-discouraged-alternatives'." - (let ((seq (nreverse (mapcar #'mm-handle-media-type - handles)))) - (dolist (disc (reverse mm-discouraged-alternatives)) - (dolist (elem (copy-sequence seq)) - (when (string-match disc elem) - (setq seq (nconc (delete elem seq) (list elem)))))) - seq)) + (setq handles (reverse handles)) + (dolist (disc (reverse mm-discouraged-alternatives)) + (dolist (handle (copy-sequence handles)) + (when (string-match disc (mm-handle-media-type handle)) + (setq handles (nconc (delete handle handles) (list handle)))))) + ;; Remove empty parts. + (dolist (handle (copy-sequence handles)) + (when (and (bufferp (mm-handle-buffer handle)) + (not (with-current-buffer (mm-handle-buffer handle) + (goto-char (point-min)) + (re-search-forward "[^ \t\n]" nil t)))) + (setq handles (nconc (delete handle handles) (list handle))))) + (mapcar #'mm-handle-media-type handles)) (defun mm-get-content-id (id) "Return the handle(s) referred to by ID." @@ -1463,7 +1501,7 @@ be determined." (or (not image) (if (featurep 'xemacs) ;; XEmacs' glyphs can actually tell us about their width, so - ;; lets be nice and smart about them. + ;; let's be nice and smart about them. (or mm-inline-large-images (and (<= (glyph-width image) (window-pixel-width)) (<= (glyph-height image) (window-pixel-height)))) @@ -1561,7 +1599,7 @@ If RECURSIVE, search recursively." (autoload 'mm-view-pkcs7 "mm-view") -(defun mm-possibly-verify-or-decrypt (parts ctl) +(defun mm-possibly-verify-or-decrypt (parts ctl &optional from) (let ((type (car ctl)) (subtype (cadr (split-string (car ctl) "/"))) (mm-security-handle ctl) ;; (car CTL) is the type. @@ -1576,7 +1614,7 @@ If RECURSIVE, search recursively." ((eq mm-decrypt-option 'known) t) (t (y-or-n-p (format "Decrypt (S/MIME) part? ")))) - (mm-view-pkcs7 parts)) + (mm-view-pkcs7 parts from)) (setq parts (mm-dissect-buffer t))))) ((equal subtype "signed") (unless (and (setq protocol @@ -1675,15 +1713,71 @@ If RECURSIVE, search recursively." (and (eq (mm-body-7-or-8) '7bit) (not (mm-long-lines-p 76)))))) +(declare-function libxml-parse-html-region "xml.c" + (start end &optional base-url)) +(declare-function shr-insert-document "shr" (dom)) +(defvar shr-blocked-images) +(defvar gnus-inhibit-images) +(autoload 'gnus-blocked-images "gnus-art") + (defun mm-shr (handle) - (let ((article-buffer (current-buffer))) + ;; Require since we bind its variables. + (require 'shr) + (let ((article-buffer (current-buffer)) + (shr-content-function (lambda (id) + (let ((handle (mm-get-content-id id))) + (when handle + (mm-with-part handle + (buffer-string)))))) + shr-inhibit-images shr-blocked-images charset char) + (if (and (boundp 'gnus-summary-buffer) + (bufferp gnus-summary-buffer) + (buffer-name gnus-summary-buffer)) + (with-current-buffer gnus-summary-buffer + (setq shr-inhibit-images gnus-inhibit-images + shr-blocked-images (gnus-blocked-images))) + (setq shr-inhibit-images gnus-inhibit-images + shr-blocked-images (gnus-blocked-images))) (unless handle (setq handle (mm-dissect-buffer t))) + (setq charset (mail-content-type-get (mm-handle-type handle) 'charset)) (save-restriction (narrow-to-region (point) (point)) (shr-insert-document (mm-with-part handle - (libxml-parse-html-region (point-min) (point-max))))))) + (insert (prog1 + (if (and charset + (setq charset + (mm-charset-to-coding-system charset)) + (not (eq charset 'ascii))) + (mm-decode-coding-string (buffer-string) charset) + (mm-string-as-multibyte (buffer-string))) + (erase-buffer) + (mm-enable-multibyte))) + (goto-char (point-min)) + (setq case-fold-search t) + (while (re-search-forward + "&#\\(?:x\\([89][0-9a-f]\\)\\|\\(1[2-5][0-9]\\)\\);" nil t) + (when (setq char + (cdr (assq (if (match-beginning 1) + (string-to-number (match-string 1) 16) + (string-to-number (match-string 2))) + mm-extra-numeric-entities))) + (replace-match (char-to-string char)))) + (libxml-parse-html-region (point-min) (point-max)))) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((inhibit-read-only t)) + (delete-region ,(point-min-marker) + ,(point-max-marker)))))))) + +(defun mm-handle-filename (handle) + "Return filename of HANDLE if any." + (or (mail-content-type-get (mm-handle-type handle) + 'name) + (mail-content-type-get (mm-handle-disposition handle) + 'filename))) (provide 'mm-decode)