X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-view.el;h=edc2d39cd0f457f3ac5ac28dc70b8eea1a887279;hb=9dbfed5956f7f235367d0e04b7e865b9df36ebd1;hp=1a2d940e2e5be967ad1613acbe76b0d81b57fb23;hpb=c9a393eeb329a99695566342a9f03b8a30000898;p=gnus diff --git a/lisp/mm-view.el b/lisp/mm-view.el index 1a2d940e2..edc2d39cd 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -1,7 +1,6 @@ ;;; mm-view.el --- functions for viewing MIME objects -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; Copyright (C) 1998-2015 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. @@ -22,15 +21,17 @@ ;;; Commentary: ;;; Code: -(eval-and-compile - (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) + (eval-when-compile (require 'cl)) (require 'mail-parse) (require 'mailcap) (require 'mm-bodies) (require 'mm-decode) (require 'smime) +(require 'mml-smime) +(autoload 'gnus-completing-read "gnus-util") +(autoload 'gnus-window-inside-pixel-edges "gnus-ems") (autoload 'gnus-article-prepare-display "gnus-art") (autoload 'vcard-parse-string "vcard") (autoload 'vcard-format-string "vcard") @@ -46,58 +47,68 @@ (defvar w3m-minor-mode-map) (defvar mm-text-html-renderer-alist - '((w3 . mm-inline-text-html-render-with-w3) + '((shr . mm-shr) (w3m . mm-inline-text-html-render-with-w3m) (w3m-standalone . mm-inline-text-html-render-with-w3m-standalone) + (gnus-w3m . gnus-article-html) (links mm-inline-render-with-file mm-links-remove-leading-blank "links" "-dump" file) - (lynx mm-inline-render-with-stdin nil - "lynx" "-dump" "-force_html" "-stdin" "-nolist") - (html2text mm-inline-render-with-function html2text)) + (lynx mm-inline-render-with-stdin nil + "lynx" "-dump" "-force_html" "-stdin" "-nolist") + (html2text mm-inline-render-with-function html2text)) "The attributes of renderer types for text/html.") -(defvar mm-text-html-washer-alist - '((w3 . gnus-article-wash-html-with-w3) - (w3m . gnus-article-wash-html-with-w3m) - (w3m-standalone . gnus-article-wash-html-with-w3m-standalone) - (links mm-inline-wash-with-file - mm-links-remove-leading-blank - "links" "-dump" file) - (lynx mm-inline-wash-with-stdin nil - "lynx" "-dump" "-force_html" "-stdin" "-nolist") - (html2text html2text)) - "The attributes of washer types for text/html.") - (defcustom mm-fill-flowed t "If non-nil a format=flowed article will be displayed flowed." :type 'boolean :version "22.1" :group 'mime-display) +(defcustom mm-inline-large-images-proportion 0.9 + "Maximum proportion of large image resized when +`mm-inline-large-images' is set to resize." + :type 'float + :version "24.1" + :group 'mime-display) + ;;; Internal variables. ;;; ;;; Functions for displaying various formats inline ;;; +(autoload 'gnus-rescale-image "gnus-util") + (defun mm-inline-image-emacs (handle) (let ((b (point-marker)) (inhibit-read-only t)) - (put-image (mm-get-image handle) b) - (insert "\n\n") + (put-image + (let ((image (mm-get-image handle))) + (if (eq mm-inline-large-images 'resize) + (gnus-rescale-image + image + (let ((edges (gnus-window-inside-pixel-edges + (get-buffer-window (current-buffer))))) + (cons (truncate (* mm-inline-large-images-proportion + (- (nth 2 edges) (nth 0 edges)))) + (truncate (* mm-inline-large-images-proportion + (- (nth 3 edges) (nth 1 edges))))))) + image)) + b) + (insert "\n") (mm-handle-set-undisplayer handle `(lambda () (let ((b ,b) (inhibit-read-only t)) (remove-images b b) - (delete-region b (+ b 2))))))) + (delete-region b (1+ b))))))) (defun mm-inline-image-xemacs (handle) (when (featurep 'xemacs) - (insert "\n\n") - (forward-char -2) + (insert "\n") + (forward-char -1) (let ((annot (make-annotation (mm-get-image handle) nil 'text)) (inhibit-read-only t)) (mm-handle-set-undisplayer @@ -106,7 +117,7 @@ (let ((b ,(point-marker)) (inhibit-read-only t)) (delete-annotation ,annot) - (delete-region (- b 2) b)))) + (delete-region (1- b) b)))) (set-extent-property annot 'mm t) (set-extent-property annot 'duplicable t)))) @@ -115,91 +126,6 @@ (defalias 'mm-inline-image 'mm-inline-image-xemacs) (defalias 'mm-inline-image 'mm-inline-image-emacs))) -;; External. -(declare-function w3-do-setup "ext:w3" ()) -(declare-function w3-region "ext:w3-display" (st nd)) -(declare-function w3-prepare-buffer "ext:w3-display" (&rest args)) - -(defvar mm-w3-setup nil) -(defun mm-setup-w3 () - (unless mm-w3-setup - (require 'w3) - (w3-do-setup) - (require 'url) - (require 'w3-vars) - (require 'url-vars) - (setq mm-w3-setup t))) - -(defun mm-inline-text-html-render-with-w3 (handle) - (mm-setup-w3) - (let ((text (mm-get-part handle)) - (b (point)) - (url-standalone-mode t) - (url-gateway-unplugged t) - (w3-honor-stylesheets nil) - (url-current-object - (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) - (width (window-width)) - (charset (mail-content-type-get - (mm-handle-type handle) 'charset))) - (save-excursion - (insert (if charset (mm-decode-string text charset) text)) - (save-restriction - (narrow-to-region b (point)) - (unless charset - (goto-char (point-min)) - (when (or (and (boundp 'w3-meta-content-type-charset-regexp) - (re-search-forward - w3-meta-content-type-charset-regexp nil t)) - (and (boundp 'w3-meta-charset-content-type-regexp) - (re-search-forward - w3-meta-charset-content-type-regexp nil t))) - (setq charset - (let ((bsubstr (buffer-substring-no-properties - (match-beginning 2) - (match-end 2)))) - (if (fboundp 'w3-coding-system-for-mime-charset) - (w3-coding-system-for-mime-charset bsubstr) - (mm-charset-to-coding-system bsubstr)))) - (delete-region (point-min) (point-max)) - (insert (mm-decode-string text charset)))) - (save-window-excursion - (save-restriction - (let ((w3-strict-width width) - ;; Don't let w3 set the global version of - ;; this variable. - (fill-column fill-column)) - (if (or debug-on-error debug-on-quit) - (w3-region (point-min) (point-max)) - (condition-case () - (w3-region (point-min) (point-max)) - (error - (delete-region (point-min) (point-max)) - (let ((b (point)) - (charset (mail-content-type-get - (mm-handle-type handle) 'charset))) - (if (or (eq charset 'gnus-decoded) - (eq mail-parse-charset 'gnus-decoded)) - (save-restriction - (narrow-to-region (point) (point)) - (mm-insert-part handle) - (goto-char (point-max))) - (insert (mm-decode-string (mm-get-part handle) - charset)))) - (message - "Error while rendering html; showing as text/plain"))))))) - (mm-handle-set-undisplayer - handle - `(lambda () - (let ((inhibit-read-only t)) - ,@(if (functionp 'remove-specifier) - '((dolist (prop '(background background-pixmap foreground)) - (remove-specifier - (face-property 'default prop) - (current-buffer))))) - (delete-region ,(point-min-marker) - ,(point-max-marker))))))))) - (defvar mm-w3m-setup nil "Whether gnus-article-mode has been setup to use emacs-w3m.") @@ -328,9 +254,10 @@ 'charset) (symbol-name mail-parse-charset))) cs) - (unless (and charset - (setq cs (mm-charset-to-coding-system charset)) - (not (eq cs 'ascii))) + (if (and charset + (setq cs (mm-charset-to-coding-system charset nil t)) + (not (eq cs 'ascii))) + (setq charset (format "%s" (mm-coding-system-to-mime-charset cs))) ;; The default. (setq charset "iso-8859-1" cs 'iso-8859-1)) @@ -404,16 +331,18 @@ (buffer-string))))) (defun mm-inline-text-html (handle) - (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer)) - (entry (assq func mm-text-html-renderer-alist)) - (inhibit-read-only t)) - (if entry - (setq func (cdr entry))) - (cond - ((functionp func) - (funcall func handle)) - (t - (apply (car func) handle (cdr func)))))) + (if (stringp (car handle)) + (mapcar 'mm-inline-text-html (cdr handle)) + (let* ((func mm-text-html-renderer) + (entry (assq func mm-text-html-renderer-alist)) + (inhibit-read-only t)) + (if entry + (setq func (cdr entry))) + (cond + ((functionp func) + (funcall func handle)) + (t + (apply (car func) handle (cdr func))))))) (defun mm-inline-text-vcard (handle) (let ((inhibit-read-only t)) @@ -441,7 +370,7 @@ (narrow-to-region (point) (point)) (mm-insert-part handle) (goto-char (point-max))) - (insert (mm-decode-string (mm-get-part handle) charset))) + (mm-display-inline-fontify handle)) (when (and mm-fill-flowed (equal type "plain") (equal (cdr (assoc 'format (mm-handle-type handle))) @@ -462,7 +391,7 @@ handle `(lambda () (let ((inhibit-read-only t)) - (delete-region ,(point-min-marker) + (delete-region ,(copy-marker (point-min) t) ,(point-max-marker)))))))) (defun mm-insert-inline (handle text) @@ -475,22 +404,12 @@ handle `(lambda () (let ((inhibit-read-only t)) - (delete-region ,(copy-marker b) - ,(copy-marker (point)))))))) + (delete-region ,(copy-marker b t) + ,(point-marker))))))) (defun mm-inline-audio (handle) (message "Not implemented")) -(defun mm-view-sound-file () - (message "Not implemented")) - -(defun mm-w3-prepare-buffer () - (require 'w3) - (let ((url-standalone-mode t) - (url-gateway-unplugged t) - (w3-honor-stylesheets nil)) - (w3-prepare-buffer))) - (defun mm-view-message () (mm-enable-multibyte) (let (handles) @@ -551,15 +470,18 @@ (face-property 'default prop) (current-buffer)))) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) -(defun mm-display-inline-fontify (handle mode) +;; Shut up byte-compiler. +(defvar font-lock-mode-hook) +(defun mm-display-inline-fontify (handle &optional mode) + "Insert HANDLE inline fontifying with MODE. +If MODE is not set, try to find mode automatically." (let ((charset (mail-content-type-get (mm-handle-type handle) 'charset)) text coding-system) (unless (eq charset 'gnus-decoded) (mm-with-unibyte-buffer (mm-insert-part handle) (mm-decompress-buffer - (or (mail-content-type-get (mm-handle-disposition handle) 'name) - (mail-content-type-get (mm-handle-disposition handle) 'filename)) + (mm-handle-filename handle) t t) (unless charset (setq coding-system (mm-find-buffer-file-coding-system))) @@ -581,16 +503,30 @@ (t text))) (require 'font-lock) - (let ((font-lock-maximum-size nil) - ;; Disable support modes, e.g., jit-lock, lazy-lock, etc. - (font-lock-mode-hook nil) - (font-lock-support-mode nil) - ;; I find font-lock a bit too verbose. - (font-lock-verbose nil)) - (funcall mode) - ;; The mode function might have already turned on font-lock. - (unless (symbol-value 'font-lock-mode) - (font-lock-fontify-buffer))) + ;; I find font-lock a bit too verbose. + (let ((font-lock-verbose nil) + (font-lock-support-mode nil)) + ;; Disable support modes, e.g., jit-lock, lazy-lock, etc. + ;; Note: XEmacs people use `font-lock-mode-hook' to run those modes. + (set (make-local-variable 'font-lock-mode-hook) nil) + (setq buffer-file-name (mm-handle-filename handle)) + (set (make-local-variable 'enable-local-variables) nil) + (with-demoted-errors + (if mode + (save-window-excursion + (switch-to-buffer (current-buffer)) + (funcall mode)) + (let ((auto-mode-alist + (delq (rassq 'doc-view-mode-maybe auto-mode-alist) + (copy-sequence auto-mode-alist)))) + (set-auto-mode))) + ;; The mode function might have already turned on font-lock. + ;; Do not fontify if the guess mode is fundamental. + (unless (or font-lock-mode + (eq major-mode 'fundamental-mode)) + (if (fboundp 'font-lock-ensure) + (font-lock-ensure) + (font-lock-fontify-buffer))))) ;; By default, XEmacs font-lock uses non-duplicable text ;; properties. This code forces all the text properties ;; to be copied along with the text. @@ -600,6 +536,9 @@ nil) nil nil nil nil nil 'text-prop)) (setq text (buffer-string)) + ;; Set buffer unmodified to avoid confirmation when killing the + ;; buffer. + (set-buffer-modified-p nil) (kill-buffer (current-buffer))) (mm-insert-inline handle text))) @@ -617,17 +556,41 @@ (defun mm-display-dns-inline (handle) (mm-display-inline-fontify handle 'dns-mode)) +(defun mm-display-org-inline (handle) + "Show an Org mode text from HANDLE inline." + (mm-display-inline-fontify handle 'org-mode)) + +(defun mm-display-shell-script-inline (handle) + "Show a shell script from HANDLE inline." + (mm-display-inline-fontify handle 'shell-script-mode)) + +(defun mm-display-javascript-inline (handle) + "Show JavsScript code from HANDLE inline." + (mm-display-inline-fontify handle 'javascript-mode)) + ;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 } (defvar mm-pkcs7-signed-magic - "\x30\x5c\x28\x80\x5c\x7c\x81\x2e\x5c\x7c\x82\x2e\x2e\x5c\x7c\x83\x2e\x2e\ -\x2e\x5c\x29\x06\x09\x5c\x2a\x86\x48\x86\xf7\x0d\x01\x07\x02") + (concat + "0" + "\\(\\(\x80\\)" + "\\|\\(\x81\\(.\\|\n\\)\\{1\\}\\)" + "\\|\\(\x82\\(.\\|\n\\)\\{2\\}\\)" + "\\|\\(\x83\\(.\\|\n\\)\\{3\\}\\)" + "\\)" + "\x06\x09\\*\x86H\x86\xf7\x0d\x01\x07\x02")) ;; id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 } (defvar mm-pkcs7-enveloped-magic - "\x30\x5c\x28\x80\x5c\x7c\x81\x2e\x5c\x7c\x82\x2e\x2e\x5c\x7c\x83\x2e\x2e\ -\x2e\x5c\x29\x06\x09\x5c\x2a\x86\x48\x86\xf7\x0d\x01\x07\x03") + (concat + "0" + "\\(\\(\x80\\)" + "\\|\\(\x81\\(.\\|\n\\)\\{1\\}\\)" + "\\|\\(\x82\\(.\\|\n\\)\\{2\\}\\)" + "\\|\\(\x83\\(.\\|\n\\)\\{3\\}\\)" + "\\)" + "\x06\x09\\*\x86H\x86\xf7\x0d\x01\x07\x03")) (defun mm-view-pkcs7-get-type (handle) (mm-with-unibyte-buffer @@ -639,9 +602,9 @@ (t (error "Could not identify PKCS#7 type"))))) -(defun mm-view-pkcs7 (handle) +(defun mm-view-pkcs7 (handle &optional from) (case (mm-view-pkcs7-get-type handle) - (enveloped (mm-view-pkcs7-decrypt handle)) + (enveloped (mm-view-pkcs7-decrypt handle from)) (signed (mm-view-pkcs7-verify handle)) (otherwise (error "Unknown or unimplemented PKCS#7 type")))) @@ -666,21 +629,28 @@ (replace-match "\n")) t) -(defun mm-view-pkcs7-decrypt (handle) +(autoload 'epg-decrypt-string "epg") + +(defun mm-view-pkcs7-decrypt (handle &optional from) (insert-buffer-substring (mm-handle-buffer handle)) (goto-char (point-min)) - (insert "MIME-Version: 1.0\n") - (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") - (smime-decrypt-region - (point-min) (point-max) - (if (= (length smime-keys) 1) - (cadar smime-keys) - (smime-get-key-by-email - (completing-read - (concat "Decipher using key" - (if smime-keys (concat "(default " (caar smime-keys) "): ") - ": ")) - smime-keys nil nil nil nil (car-safe (car-safe smime-keys)))))) + (if (eq mml-smime-use 'epg) + ;; Use EPG/gpgsm + (let ((part (base64-decode-string (buffer-string)))) + (erase-buffer) + (insert (epg-decrypt-string (epg-make-context 'CMS) part))) + ;; Use openssl + (insert "MIME-Version: 1.0\n") + (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") + (smime-decrypt-region + (point-min) (point-max) + (if (= (length smime-keys) 1) + (cadar smime-keys) + (smime-get-key-by-email + (gnus-completing-read + "Decipher using key" + smime-keys nil nil nil (car-safe (car-safe smime-keys))))) + from)) (goto-char (point-min)) (while (search-forward "\r\n" nil t) (replace-match "\n"))