X-Git-Url: https://cgit.sxemacs.org/?p=gnus;a=blobdiff_plain;f=lisp%2Fmm-view.el;h=1a2d940e2e5be967ad1613acbe76b0d81b57fb23;hp=7ba9115b9dd004b35e9a69a69837e66f0a0e1dc6;hb=c9a393eeb329a99695566342a9f03b8a30000898;hpb=e5b801c287295e0df6ecde6c91ae715ef8bd4f0a diff --git a/lisp/mm-view.el b/lisp/mm-view.el index 7ba9115b9..1a2d940e2 100644 --- a/lisp/mm-view.el +++ b/lisp/mm-view.el @@ -1,65 +1,80 @@ ;;; mm-view.el --- functions for viewing MIME objects -;; Copyright (C) 1998, 1999, 2000, 2001, 2002 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., 59 Temple Place - Suite 330, -;; Boston, MA 02111-1307, 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) - -(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") - (unless (fboundp 'diff-mode) - (autoload 'diff-mode "diff-mode" "" t nil))) +(require 'smime) + +(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) +(defvar smime-keys) +(defvar w3m-cid-retrieve-function-alist) +(defvar w3m-current-buffer) +(defvar w3m-display-inline-images) +(defvar w3m-minor-mode-map) (defvar mm-text-html-renderer-alist '((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) (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") + "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") + "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) + ;;; Internal variables. ;;; @@ -68,34 +83,43 @@ (defun mm-inline-image-emacs (handle) (let ((b (point-marker)) - buffer-read-only) - (insert "\n") + (inhibit-read-only t)) (put-image (mm-get-image handle) b) + (insert "\n\n") (mm-handle-set-undisplayer handle - `(lambda () (remove-images ,b (1+ ,b)))))) + `(lambda () + (let ((b ,b) + (inhibit-read-only t)) + (remove-images b b) + (delete-region b (+ b 2))))))) (defun mm-inline-image-xemacs (handle) - (insert "\n") - (forward-char -1) - (let ((b (point)) - (annot (make-annotation (mm-get-image handle) nil 'text)) - buffer-read-only) - (mm-handle-set-undisplayer - handle - `(lambda () - (let (buffer-read-only) - (delete-annotation ,annot) - (delete-region ,(set-marker (make-marker) b) - ,(set-marker (make-marker) (point)))))) - (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 @@ -119,189 +143,210 @@ (charset (mail-content-type-get (mm-handle-type handle) 'charset))) (save-excursion - (insert text) + (insert (if charset (mm-decode-string text charset) text)) (save-restriction (narrow-to-region b (point)) - (goto-char (point-min)) - (if (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))) + (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 - (or (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))) - charset))) - (delete-region (point-min) (point-max)) - (insert (mm-decode-string text 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)) - (condition-case var + (if (or debug-on-error debug-on-quit) (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)) + (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")))))) + (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 (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-mode-map nil - "Local keymap for inlined text/html part rendered by emacs-w3m. It will -be different from `w3m-mode-map' to use in the article buffer.") - -(defvar mm-w3m-mode-command-alist - '((backward-char) - (describe-mode) - (forward-char) - (goto-line) - (next-line) - (previous-line) - (w3m-antenna) - (w3m-antenna-add-current-url) - (w3m-bookmark-add-current-url) - (w3m-bookmark-add-this-url) - (w3m-bookmark-view) - (w3m-close-window) - (w3m-copy-buffer) - (w3m-delete-buffer) - (w3m-dtree) - (w3m-edit-current-url) - (w3m-edit-this-url) - (w3m-gohome) - (w3m-goto-url) - (w3m-goto-url-new-session) - (w3m-history) - (w3m-history-restore-position) - (w3m-history-store-position) - (w3m-namazu) - (w3m-next-buffer) - (w3m-previous-buffer) - (w3m-quit) - (w3m-redisplay-with-charset) - (w3m-reload-this-page) - (w3m-scroll-down-or-previous-url) - (w3m-scroll-up-or-next-url) - (w3m-search) - (w3m-select-buffer) - (w3m-switch-buffer) - (w3m-view-header) - (w3m-view-parent-page) - (w3m-view-previous-page) - (w3m-view-source) - (w3m-weather)) - "Alist of commands to use for emacs-w3m in the article buffer. Each -element looks like (FROM-COMMAND . TO-COMMAND); FROM-COMMAND should be -registered in `w3m-mode-map' which will be substituted by TO-COMMAND -in `mm-w3m-mode-map'. If TO-COMMAND is nil, an article command key -will not be substituted.") - -(defvar mm-w3m-mode-dont-bind-keys (list [up] [right] [left] [down]) - "List of keys which should not be bound for the emacs-w3m commands.") - (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 (require 'w3m) - (unless mm-w3m-mode-map - (setq mm-w3m-mode-map (copy-keymap w3m-mode-map)) - (dolist (def mm-w3m-mode-command-alist) - (condition-case nil - (substitute-key-definition (car def) (cdr def) mm-w3m-mode-map) - (error))) - (dolist (key mm-w3m-mode-dont-bind-keys) - (condition-case nil - (define-key mm-w3m-mode-map key nil) - (error)))) (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist) (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve) w3m-cid-retrieve-function-alist)) - (setq mm-w3m-setup t))) + (setq mm-w3m-setup t)) + (setq w3m-display-inline-images mm-inline-text-html-with-images)) + +(defun mm-w3m-cid-retrieve-1 (url handle) + (dolist (elem handle) + (when (consp elem) + (when (equal url (mm-handle-id elem)) + (mm-insert-part elem) + (throw 'found-handle (mm-handle-media-type elem))) + (when (and (stringp (car elem)) + (equal "multipart" (mm-handle-media-supertype elem))) + (mm-w3m-cid-retrieve-1 url elem))))) (defun mm-w3m-cid-retrieve (url &rest args) "Insert a content pointed by URL if it has the cid: scheme." (when (string-match "\\`cid:" url) - (setq url (concat "<" (substring url (match-end 0)) ">")) - (catch 'found-handle - (dolist (handle (with-current-buffer w3m-current-buffer - gnus-article-mime-handles)) - (when (and (listp handle) - (equal url (mm-handle-id handle))) - (mm-insert-part handle) - (throw 'found-handle (mm-handle-media-type handle))))))) + (or (catch 'found-handle + (mm-w3m-cid-retrieve-1 + (setq url (concat "<" (substring url (match-end 0)) ">")) + (with-current-buffer w3m-current-buffer + gnus-article-mime-handles))) + (prog1 + nil + (message "Failed to find \"Content-ID: %s\"" url))))) (defun mm-inline-text-html-render-with-w3m (handle) "Render a text/html part using emacs-w3m." (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 text) + (insert (if charset (mm-decode-string text charset) text)) (save-restriction (narrow-to-region b (point)) - (goto-char (point-min)) - (when (re-search-forward w3m-meta-content-type-charset-regexp nil t) - (setq charset (or (w3m-charset-to-coding-system (match-string 2)) - charset))) - (when charset - (delete-region (point-min) (point-max)) - (insert (mm-decode-string text charset))) - (let ((w3m-safe-url-regexp (if mm-inline-text-html-with-images - nil - "\\`cid:")) - (w3m-display-inline-images mm-inline-text-html-with-images) + (unless charset + (goto-char (point-min)) + (when (setq charset (w3m-detect-meta-charset)) + (delete-region (point-min) (point-max)) + (insert (mm-decode-string text charset)))) + (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) w3m-force-redisplay) - (w3m-region (point-min) (point-max))) - (when mm-inline-text-html-with-w3m-keymap - (add-text-properties - (point-min) (point-max) - (append '(mm-inline-text-html-with-w3m t) - (gnus-local-map-property mm-w3m-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))) - (delete-region ,(point-min-marker) - ,(point-max-marker)))))))) + (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) + (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 ((inhibit-read-only t)) + (delete-region ,(point-min-marker) + ,(point-max-marker))))))))) + +(defvar mm-w3m-standalone-supports-m17n-p (if (featurep 'mule) 'undecided) + "*T means the w3m command supports the m17n feature.") + +(defun mm-w3m-standalone-supports-m17n-p () + "Say whether the w3m command supports the m17n feature." + (cond ((eq mm-w3m-standalone-supports-m17n-p t) t) + ((eq mm-w3m-standalone-supports-m17n-p nil) nil) + ((not (featurep 'mule)) (setq mm-w3m-standalone-supports-m17n-p nil)) + ((condition-case nil + (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!!#m#1#7#n!)\e(B" 'iso-2022-jp))) + (mm-with-multibyte-buffer + (insert str) + (call-process-region + (point-min) (point-max) "w3m" t t nil "-dump" + "-T" "text/html" "-I" "iso-2022-jp" "-O" "iso-2022-jp") + (goto-char (point-min)) + (search-forward str nil t))) + (error nil)) + (setq mm-w3m-standalone-supports-m17n-p t)) + (t + ;;(message "You had better upgrade your w3m command") + (setq mm-w3m-standalone-supports-m17n-p nil)))) + +(defun mm-inline-text-html-render-with-w3m-standalone (handle) + "Render a text/html part using w3m." + (if (mm-w3m-standalone-supports-m17n-p) + (let ((source (mm-get-part handle)) + (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)) + (not (eq cs 'ascii))) + ;; The default. + (setq charset "iso-8859-1" + cs 'iso-8859-1)) + (mm-insert-inline + handle + (mm-with-unibyte-buffer + (insert source) + (mm-enable-multibyte) + (let ((coding-system-for-write 'binary) + (coding-system-for-read cs)) + (call-process-region + (point-min) (point-max) + "w3m" t t nil "-dump" "-T" "text/html" + "-I" charset "-O" charset)) + (buffer-string)))) + (mm-inline-render-with-stdin handle nil "w3m" "-dump" "-T" "text/html"))) (defun mm-links-remove-leading-blank () ;; Delete the annoying three spaces preceding each line of links @@ -311,7 +356,7 @@ will not be substituted.") (delete-region (match-beginning 0) (match-end 0)))) (defun mm-inline-wash-with-file (post-func cmd &rest args) - (let ((file (make-temp-name + (let ((file (mm-make-temp-file (expand-file-name "mm" mm-tmp-directory)))) (let ((coding-system-for-write 'binary)) (write-region (point-min) (point-max) file nil 'silent)) @@ -346,28 +391,32 @@ will not be substituted.") (buffer-string))))) (defun mm-inline-render-with-function (handle func &rest args) - (let ((source (mm-get-part handle))) + (let ((source (mm-get-part handle)) + (charset (or (mail-content-type-get (mm-handle-type handle) 'charset) + mail-parse-charset))) (mm-insert-inline handle - (mm-with-unibyte-buffer - (insert source) + (mm-with-multibyte-buffer + (insert (if charset + (mm-decode-string source charset) + source)) (apply func args) (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)) - buffer-read-only) + (inhibit-read-only t)) (if entry (setq func (cdr entry))) (cond - ((gnus-functionp func) + ((functionp func) (funcall func handle)) (t (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" @@ -383,7 +432,7 @@ will not be substituted.") (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. @@ -393,24 +442,26 @@ will not be substituted.") (mm-insert-part handle) (goto-char (point-max))) (insert (mm-decode-string (mm-get-part handle) charset))) - (when (and (equal type "plain") + (when (and mm-fill-flowed + (equal type "plain") (equal (cdr (assoc 'format (mm-handle-type handle))) "flowed")) (save-restriction (narrow-to-region b (point)) (goto-char b) - (fill-flowed) + (fill-flowed nil (equal (cdr (assoc 'delsp (mm-handle-type handle))) + "yes")) (goto-char (point-max)))) (save-restriction (narrow-to-region b (point)) - (set-text-properties (point-min) (point-max) nil) - (when (or (equal type "enriched") - (equal type "richtext")) - (enriched-decode (point-min) (point-max))) + (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)))))))) @@ -418,12 +469,14 @@ will not be substituted.") "Insert TEXT inline from HANDLE." (let ((b (point))) (insert text) + (unless (bolp) + (insert "\n")) (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")) @@ -471,8 +524,10 @@ will not be substituted.") ;; disable prepare hook gnus-article-prepare-hook (gnus-newsgroup-charset - (or charset gnus-newsgroup-charset))) - (run-hooks 'gnus-article-decode-hook) + (unless (eq charset 'gnus-decoded) ;; mm-uu might set it. + (or charset gnus-newsgroup-charset)))) + (let ((gnus-original-article-buffer (mm-handle-buffer handle))) + (run-hooks 'gnus-article-decode-hook)) (gnus-article-prepare-display) (setq handles gnus-article-mime-handles)) (goto-char (point-min)) @@ -488,42 +543,64 @@ will not be substituted.") (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) - (let (text) + (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)) + t t) + (unless charset + (setq coding-system (mm-find-buffer-file-coding-system))) + (setq text (buffer-string)))) ;; XEmacs @#$@ version of font-lock refuses to fully turn itself ;; on for buffers whose name begins with " ". That's why we use - ;; save-current-buffer/get-buffer-create rather than - ;; with-temp-buffer. - (save-current-buffer - (set-buffer (generate-new-buffer "*fontification*")) - (unwind-protect - (progn - (buffer-disable-undo) - (mm-insert-part handle) - (funcall mode) - (require 'font-lock) - (let ((font-lock-verbose nil)) - ;; I find font-lock a bit too verbose. - (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) - (map-extents (lambda (ext ignored) - (set-extent-property ext 'duplicable t) - nil) - nil nil nil nil nil 'text-prop)) - (setq text (buffer-string))) - (kill-buffer (current-buffer)))) + ;; `with-current-buffer'/`generate-new-buffer' rather than + ;; `with-temp-buffer'. + (with-current-buffer (generate-new-buffer "*fontification*") + (buffer-disable-undo) + (mm-enable-multibyte) + (insert (cond ((eq charset 'gnus-decoded) + (with-current-buffer (mm-handle-buffer handle) + (buffer-string))) + (coding-system + (mm-decode-coding-string text coding-system)) + (charset + (mm-decode-string text charset)) + (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))) + ;; 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 (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)) + (kill-buffer (current-buffer))) (mm-insert-inline handle text))) ;; Shouldn't these functions check whether the user even wants to use @@ -537,27 +614,20 @@ will not be substituted.") (defun mm-display-elisp-inline (handle) (mm-display-inline-fontify handle 'emacs-lisp-mode)) +(defun mm-display-dns-inline (handle) + (mm-display-inline-fontify handle 'dns-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 - (apply 'concat - (mapcar '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 - (apply 'concat - (mapcar '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 @@ -572,10 +642,32 @@ will not be substituted.") (defun mm-view-pkcs7 (handle) (case (mm-view-pkcs7-get-type handle) (enveloped (mm-view-pkcs7-decrypt handle)) + (signed (mm-view-pkcs7-verify handle)) (otherwise (error "Unknown or unimplemented PKCS#7 type")))) +(defun mm-view-pkcs7-verify (handle) + (let ((verified nil)) + (with-temp-buffer + (insert "MIME-Version: 1.0\n") + (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") + (insert-buffer-substring (mm-handle-buffer handle)) + (setq verified (smime-verify-region (point-min) (point-max)))) + (goto-char (point-min)) + (mm-insert-part handle) + (if (search-forward "Content-Type: " nil t) + (delete-region (point-min) (match-beginning 0))) + (goto-char (point-max)) + (if (re-search-backward "--\r?\n?" nil t) + (delete-region (match-end 0) (point-max))) + (unless verified + (insert-buffer-substring smime-details-buffer))) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + t) + (defun mm-view-pkcs7-decrypt (handle) - (insert-buffer (mm-handle-buffer handle)) + (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") @@ -584,10 +676,15 @@ will not be substituted.") (if (= (length smime-keys) 1) (cadar smime-keys) (smime-get-key-by-email - (completing-read "Decrypt this part with which key? " - smime-keys nil nil - (and (listp (car-safe smime-keys)) - (caar smime-keys))))))) + (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)))))) + (goto-char (point-min)) + (while (search-forward "\r\n" nil t) + (replace-match "\n")) + (goto-char (point-min))) (provide 'mm-view)