X-Git-Url: http://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-view.el;h=5a90f015aedcdaf11e917e7abfdc3ffd3f9fb21d;hp=ffaf0ed68ba10e840196668fd15aa4fc0218e325;hb=a030e58d75e8dcaff893d0618f6ac0daa2ca9823;hpb=9b139a13c0650a18872ebd64849560a97554afa8 diff --git a/lisp/mm-view.el b/lisp/mm-view.el index ffaf0ed68..5a90f015a 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -1,43 +1,45 @@ ;;; mm-view.el --- functions for viewing MIME objects -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006, 2007 Free Software Foundation, Inc. +;; Copyright (C) 1998-2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen ;; This file is part of GNU Emacs. -;; GNU Emacs is free software; you can redistribute it and/or modify +;; GNU Emacs is free software: you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation; either version 3, or (at your option) -;; any later version. +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs; see the file COPYING. If not, write to the -;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -;; Boston, MA 02110-1301, USA. +;; along with GNU Emacs. If not, see . ;;; Commentary: ;;; Code: +;; For Emacs <22.2 and XEmacs. +(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) -(eval-and-compile - (autoload 'gnus-article-prepare-display "gnus-art") - (autoload 'vcard-parse-string "vcard") - (autoload 'vcard-format-string "vcard") - (autoload 'fill-flowed "flow-fill") - (autoload 'html2text "html2text" nil t)) +(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") +(autoload 'fill-flowed "flow-fill") +(autoload 'html2text "html2text" nil t) (defvar gnus-article-mime-handles) (defvar gnus-newsgroup-charset) @@ -48,74 +50,90 @@ (defvar w3m-minor-mode-map) (defvar mm-text-html-renderer-alist - '((w3 . mm-inline-text-html-render-with-w3) + '((shr . mm-shr) + (w3 . mm-inline-text-html-render-with-w3) (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)) - buffer-read-only) - (put-image (mm-get-image handle) b) + (inhibit-read-only t)) + (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\n") (mm-handle-set-undisplayer handle `(lambda () (let ((b ,b) - buffer-read-only) + (inhibit-read-only t)) (remove-images b b) (delete-region b (+ b 2))))))) (defun mm-inline-image-xemacs (handle) - (insert "\n\n") - (forward-char -2) - (let ((annot (make-annotation (mm-get-image handle) nil 'text)) - buffer-read-only) - (mm-handle-set-undisplayer - handle - `(lambda () - (let ((b ,(point-marker)) - buffer-read-only) - (delete-annotation ,annot) - (delete-region (- b 2) b)))) - (set-extent-property annot 'mm t) - (set-extent-property annot 'duplicable t))) + (when (featurep 'xemacs) + (insert "\n\n") + (forward-char -2) + (let ((annot (make-annotation (mm-get-image handle) nil 'text)) + (inhibit-read-only t)) + (mm-handle-set-undisplayer + handle + `(lambda () + (let ((b ,(point-marker)) + (inhibit-read-only t)) + (delete-annotation ,annot) + (delete-region (- b 2) b)))) + (set-extent-property annot 'mm t) + (set-extent-property annot 'duplicable t)))) (eval-and-compile (if (featurep 'xemacs) (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 @@ -187,19 +205,22 @@ (mm-handle-set-undisplayer handle `(lambda () - (let (buffer-read-only) + (let ((inhibit-read-only t)) ,@(if (functionp 'remove-specifier) - '((mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) - (current-buffer))) - '(background background-pixmap foreground)))) + '((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.") +;; External. +(declare-function w3m-detect-meta-charset "ext:w3m" ()) +(declare-function w3m-region "ext:w3m" (start end &optional url charset)) + (defun mm-setup-w3m () "Setup gnus-article-mode to use emacs-w3m." (unless mm-w3m-setup @@ -251,14 +272,35 @@ (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) w3m-force-redisplay) (w3m-region (point-min) (point-max) nil charset)) + ;; Put the mark meaning this part was rendered by emacs-w3m. + (put-text-property (point-min) (point-max) + 'mm-inline-text-html-with-w3m t) (when (and mm-inline-text-html-with-w3m-keymap (boundp 'w3m-minor-mode-map) w3m-minor-mode-map) - (add-text-properties - (point-min) (point-max) - (list 'keymap w3m-minor-mode-map - ;; Put the mark meaning this part was rendered by emacs-w3m. - 'mm-inline-text-html-with-w3m t))) + (if (and (boundp 'w3m-link-map) + w3m-link-map) + (let* ((start (point-min)) + (end (point-max)) + (on (get-text-property start 'w3m-href-anchor)) + (map (copy-keymap w3m-link-map)) + next) + (set-keymap-parent map w3m-minor-mode-map) + (while (< start end) + (if on + (progn + (setq next (or (text-property-any start end + 'w3m-href-anchor nil) + end)) + (put-text-property start next 'keymap map)) + (setq next (or (text-property-not-all start end + 'w3m-href-anchor nil) + end)) + (put-text-property start next 'keymap w3m-minor-mode-map)) + (setq start next + on (not on)))) + (put-text-property (point-min) (point-max) + 'keymap w3m-minor-mode-map))) (mm-handle-set-undisplayer handle `(lambda () @@ -278,7 +320,7 @@ (let ((coding-system-for-write 'iso-2022-jp) (coding-system-for-read 'iso-2022-jp) (str (mm-decode-coding-string "\ -\e$B#D#o#e#s!!#w#3#m!!#s#u#p#p#o#r#t#s!!#m#1#7#n!)\e(B" 'iso-2022-jp))) +\e$B#D#o#e#s!!#w#3#m!!#s#u#p#p#o#r#t!!#m#1#7#n!)\e(B" 'iso-2022-jp))) (mm-with-multibyte-buffer (insert str) (call-process-region @@ -376,9 +418,9 @@ (buffer-string))))) (defun mm-inline-text-html (handle) - (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer)) + (let* ((func mm-text-html-renderer) (entry (assq func mm-text-html-renderer-alist)) - buffer-read-only) + (inhibit-read-only t)) (if entry (setq func (cdr entry))) (cond @@ -388,7 +430,7 @@ (apply (car func) handle (cdr func)))))) (defun mm-inline-text-vcard (handle) - (let (buffer-read-only) + (let ((inhibit-read-only t)) (mm-insert-inline handle (concat "\n-- \n" @@ -404,7 +446,7 @@ (type (mm-handle-media-subtype handle)) (charset (mail-content-type-get (mm-handle-type handle) 'charset)) - buffer-read-only) + (inhibit-read-only t)) (if (or (eq charset 'gnus-decoded) ;; This is probably not entirely correct, but ;; makes rfc822 parts with embedded multiparts work. @@ -413,7 +455,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))) @@ -426,15 +468,14 @@ (goto-char (point-max)))) (save-restriction (narrow-to-region b (point)) - (when (or (equal type "enriched") - (equal type "richtext")) - (set-text-properties (point-min) (point-max) nil) + (when (member type '("enriched" "richtext")) + (set-text-properties (point-min) (point-max) nil) (ignore-errors (enriched-decode (point-min) (point-max)))) (mm-handle-set-undisplayer handle `(lambda () - (let (buffer-read-only) + (let ((inhibit-read-only t)) (delete-region ,(point-min-marker) ,(point-max-marker)))))))) @@ -447,9 +488,9 @@ (mm-handle-set-undisplayer handle `(lambda () - (let (buffer-read-only) - (delete-region ,(set-marker (make-marker) b) - ,(set-marker (make-marker) (point)))))))) + (let ((inhibit-read-only t)) + (delete-region ,(copy-marker b) + ,(copy-marker (point)))))))) (defun mm-inline-audio (handle) (message "Not implemented")) @@ -516,24 +557,24 @@ (mm-handle-set-undisplayer handle `(lambda () - (let (buffer-read-only) + (let ((inhibit-read-only t)) (if (fboundp 'remove-specifier) ;; This is only valid on XEmacs. - (mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) (current-buffer))) - '(background background-pixmap foreground))) + (dolist (prop '(background background-pixmap foreground)) + (remove-specifier + (face-property 'default prop) (current-buffer)))) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) -(defun mm-display-inline-fontify (handle mode) +(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))) @@ -561,19 +602,28 @@ (font-lock-support-mode nil) ;; I find font-lock a bit too verbose. (font-lock-verbose nil)) - (funcall mode) + (setq buffer-file-name (mm-handle-filename handle)) + (set (make-local-variable 'enable-local-variables) nil) + (if mode + (funcall mode) + (set-auto-mode)) ;; The mode function might have already turned on font-lock. - (unless (symbol-value 'font-lock-mode) + ;; Do not fontify if the guess mode is fundamental. + (unless (or (symbol-value 'font-lock-mode) + (eq major-mode 'fundamental-mode)) (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. - (when (fboundp 'extent-list) + (when (featurep 'xemacs) (map-extents (lambda (ext ignored) (set-extent-property ext 'duplicable t) 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))) @@ -591,25 +641,29 @@ (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 - (mm-string-as-unibyte - (mapconcat 'char-to-string - (list ?\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) ""))) + "\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") ;; id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 } (defvar mm-pkcs7-enveloped-magic - (mm-string-as-unibyte - (mapconcat 'char-to-string - (list ?\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) ""))) + "\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") (defun mm-view-pkcs7-get-type (handle) (mm-with-unibyte-buffer @@ -621,9 +675,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")))) @@ -648,21 +702,26 @@ (replace-match "\n")) t) -(defun mm-view-pkcs7-decrypt (handle) +(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")) @@ -670,5 +729,4 @@ (provide 'mm-view) -;;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2 ;;; mm-view.el ends here