X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=bd9e704144eb4fbd60be542e46fe6c481dad1424;hb=0007de6d40db139c025a8b2cba9ef04ee4837608;hp=171afac31ffec210a92525eee0943a5fd96c7d65;hpb=e200fdc58ef97f1b02534d49a588c5721101b696;p=gnus diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el index 171afac31..bd9e70414 100644 --- a/lisp/mm-decode.el +++ b/lisp/mm-decode.el @@ -1,7 +1,7 @@ ;;; 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, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, +;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; MORIOKA Tomohiko @@ -24,7 +24,7 @@ ;;; Code: -;; For Emacs < 22.2. +;; For Emacs <22.2 and XEmacs. (eval-and-compile (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) @@ -105,10 +105,8 @@ ,disposition ,description ,cache ,id)) (defcustom mm-text-html-renderer - (cond ((executable-find "w3m") - (if (locate-library "w3m") - 'w3m - 'w3m-standalone)) + (cond ((fboundp 'libxml-parse-html-region) 'shr) + ((executable-find "w3m") 'gnus-w3m) ((executable-find "links") 'links) ((executable-find "lynx") 'lynx) ((locate-library "w3") 'w3) @@ -117,6 +115,8 @@ "Render of HTML contents. It is one of defined renderer types, or a rendering function. The defined renderer types are: +`shr': use Gnus simple HTML renderer; +`gnus-w3m' : use Gnus renderer based on w3m; `w3m' : use emacs-w3m; `w3m-standalone': use w3m; `links': use links; @@ -124,9 +124,11 @@ The defined renderer types are: `w3' : use Emacs/W3; `html2text' : use html2text; nil : use external viewer (default web browser)." - :version "23.0" ;; No Gnus - :type '(choice (const w3) - (const w3m :tag "emacs-w3m") + :version "24.1" + :type '(choice (const shr) + (const gnus-w3m) + (const w3) + (const w3m :tag "emacs-w3m") (const w3m-standalone :tag "standalone w3m" ) (const links) (const lynx) @@ -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 @@ -243,8 +241,7 @@ before the external MIME handler is invoked." ("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) @@ -369,8 +366,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 @@ -623,7 +624,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))) @@ -665,7 +666,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 +696,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") @@ -1148,13 +1150,15 @@ in HANDLE." ;; time to adjust it, since we know at this point that it should ;; be unibyte. `(let* ((handle ,handle)) - (with-temp-buffer - (mm-disable-multibyte) - (insert-buffer-substring (mm-handle-buffer handle)) - (mm-decode-content-transfer-encoding - (mm-handle-encoding handle) - (mm-handle-media-type handle)) - ,@forms))) + (when (and (mm-handle-buffer handle) + (buffer-name (mm-handle-buffer handle))) + (with-temp-buffer + (mm-disable-multibyte) + (insert-buffer-substring (mm-handle-buffer handle)) + (mm-decode-content-transfer-encoding + (mm-handle-encoding handle) + (mm-handle-media-type handle)) + ,@forms)))) (put 'mm-with-part 'lisp-indent-function 1) (put 'mm-with-part 'edebug-form-spec '(body)) @@ -1247,9 +1251,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 "Save MIME part to: ") - (or mm-default-directory default-directory) - nil nil (or filename ""))) + (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? " @@ -1301,27 +1313,30 @@ text/\\(\\sw+\\)\\(?:\;\\s-*charset=\\(.+\\)\\)?[\"'][^>]*>" nil t) (mm-write-region (point-min) (point-max) file nil nil nil 'binary t) (set-default-file-modes current-file-modes))))) -(defun mm-pipe-part (handle) - "Pipe HANDLE to a process." - (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) - (command - (gnus-read-shell-command - "Shell command on MIME part: " mm-last-shell-command))) +(defun mm-pipe-part (handle &optional cmd) + "Pipe HANDLE to a process. +Use CMD as the process." + (let ((name (mail-content-type-get (mm-handle-type handle) 'name)) + (command (or cmd + (gnus-read-shell-command + "Shell command on MIME part: " mm-last-shell-command)))) (mm-with-unibyte-buffer (mm-insert-part handle) (mm-add-meta-html-tag handle) (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)) (methods - (mapcar (lambda (i) (list (cdr (assoc 'viewer i)))) + (mapcar (lambda (i) (cdr (assoc 'viewer i))) (mailcap-mime-info type 'all))) (method (let ((minibuffer-local-completion-map mm-viewer-completion-map)) - (completing-read "Viewer: " methods)))) + (gnus-completing-read "Viewer" methods)))) (when (string= method "") (error "No method given")) (if (string-match "^[^% \t]+$" method) @@ -1473,7 +1488,7 @@ be determined." ;; Handle XEmacs ((fboundp 'valid-image-instantiator-format-p) (valid-image-instantiator-format-p format)) - ;; Handle Emacs 21 + ;; Handle Emacs ((fboundp 'image-type-available-p) (and (display-graphic-p) (image-type-available-p format))) @@ -1554,7 +1569,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. @@ -1569,7 +1584,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 @@ -1668,7 +1683,52 @@ 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) + ;; 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) + (if (and (boundp '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 + (when (and charset + (setq charset (mm-charset-to-coding-system charset)) + (not (eq charset 'ascii))) + (insert (prog1 + (mm-decode-coding-string (buffer-string) charset) + (erase-buffer) + (mm-enable-multibyte)))) + (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)))))))) + (provide 'mm-decode) -;; arch-tag: 4f35d360-56b8-4030-9388-3ed82d359b9b ;;; mm-decode.el ends here