X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-view.el;h=42e21cad514dd0a310abf4ee6da3c613be54a1a6;hp=52685822597381877085c5009f3780ce1727b08e;hb=e200fdc58ef97f1b02534d49a588c5721101b696;hpb=05a5b19a052e831ac19b97b8875638e17e53e157 diff --git a/lisp/mm-view.el b/lisp/mm-view.el index 526858225..42e21cad5 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -1,42 +1,41 @@ ;;; mm-view.el --- functions for viewing MIME objects -;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, -;; 2005, 2006 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 ;; 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 2, 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: - +(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) -(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-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) @@ -84,37 +83,43 @@ (defun mm-inline-image-emacs (handle) (let ((b (point-marker)) - buffer-read-only) + (inhibit-read-only t)) (put-image (mm-get-image handle) 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 @@ -186,19 +191,22 @@ (mm-handle-set-undisplayer handle `(lambda () - (let (buffer-read-only) - (if (functionp 'remove-specifier) - (mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) - (current-buffer))) - '(background background-pixmap foreground))) + (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.") +;; 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 @@ -236,7 +244,8 @@ (mm-setup-w3m) (let ((text (mm-get-part handle)) (b (point)) - (charset (mail-content-type-get (mm-handle-type handle) 'charset))) + (charset (or (mail-content-type-get (mm-handle-type handle) 'charset) + mail-parse-charset))) (save-excursion (insert (if charset (mm-decode-string text charset) text)) (save-restriction @@ -249,24 +258,39 @@ (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 () - (let (buffer-read-only) - (if (functionp 'remove-specifier) - (mapcar (lambda (prop) - (remove-specifier - (face-property 'default prop) - (current-buffer))) - '(background background-pixmap foreground))) + (let ((inhibit-read-only t)) (delete-region ,(point-min-marker) ,(point-max-marker))))))))) @@ -282,7 +306,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 @@ -300,7 +324,9 @@ "Render a text/html part using w3m." (if (mm-w3m-standalone-supports-m17n-p) (let ((source (mm-get-part handle)) - (charset (mail-content-type-get (mm-handle-type handle) 'charset)) + (charset (or (mail-content-type-get (mm-handle-type handle) + 'charset) + (symbol-name mail-parse-charset))) cs) (unless (and charset (setq cs (mm-charset-to-coding-system charset)) @@ -366,7 +392,8 @@ (defun mm-inline-render-with-function (handle func &rest args) (let ((source (mm-get-part handle)) - (charset (mail-content-type-get (mm-handle-type handle) 'charset))) + (charset (or (mail-content-type-get (mm-handle-type handle) 'charset) + mail-parse-charset))) (mm-insert-inline handle (mm-with-multibyte-buffer @@ -379,7 +406,7 @@ (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)) - buffer-read-only) + (inhibit-read-only t)) (if entry (setq func (cdr entry))) (cond @@ -389,7 +416,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" @@ -405,7 +432,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. @@ -427,15 +454,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)))))))) @@ -448,9 +474,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")) @@ -517,13 +543,12 @@ (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) @@ -569,7 +594,7 @@ ;; 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) @@ -595,22 +620,14 @@ ;; 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 @@ -671,5 +688,5 @@ (provide 'mm-view) -;;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2 +;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2 ;;; mm-view.el ends here