;;; mm-view.el --- functions for viewing MIME objects
;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004,
-;; 2005, 2006 Free Software Foundation, Inc.
+;; 2005, 2006, 2007 Free Software Foundation, Inc.
;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; This file is part of GNU Emacs.
;; 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)
+;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;; GNU Emacs is distributed in the hope that it will be useful,
(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"))
+ (autoload 'html2text "html2text" nil t))
(defvar gnus-article-mime-handles)
(defvar gnus-newsgroup-charset)
(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.
(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))
+ 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))))
(eval-and-compile
(if (featurep 'xemacs)
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)))
+ ,@(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)))))))))
(defun mm-w3m-cid-retrieve-1 (url handle)
(dolist (elem handle)
- (when (listp elem)
- (if (equal url (mm-handle-id elem))
- (progn
- (mm-insert-part elem)
- (throw 'found-handle (mm-handle-media-type elem))))
- (if (equal "multipart" (mm-handle-media-supertype elem))
- (mm-w3m-cid-retrieve-1 url elem)))))
+ (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)
- (catch 'found-handle
- (mm-w3m-cid-retrieve-1 (concat "<" (substring url (match-end 0)) ">")
- (with-current-buffer w3m-current-buffer
- gnus-article-mime-handles)))))
+ (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 (if charset (mm-decode-string text charset) text))
(save-restriction
(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)))))))))
"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))
(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
(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))
;; disable prepare hook
gnus-article-prepare-hook
(gnus-newsgroup-charset
- (or charset gnus-newsgroup-charset)))
+ (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)
(buffer-disable-undo)
(mm-enable-multibyte)
(insert (cond ((eq charset 'gnus-decoded)
- (mm-insert-part handle))
+ (with-current-buffer (mm-handle-buffer handle)
+ (buffer-string)))
(coding-system
(mm-decode-coding-string text coding-system))
(charset
;; 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)
(otherwise (error "Unknown or unimplemented PKCS#7 type"))))
(defun mm-view-pkcs7-verify (handle)
- ;; A bogus implementation of PKCS#7. FIXME::
- (mm-insert-part handle)
- (goto-char (point-min))
- (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)))
+ (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"))
- (message "Verify signed PKCS#7 message is unimplemented.")
- (sit-for 1)
t)
(defun mm-view-pkcs7-decrypt (handle)
projects / gnus / blobdiff