HCoop / bpt / emacs.git / blame
| Commit | Line | Data |
|---|---|---|
| 715a2ca2 | 1 | ;;; mm-view.el --- functions for viewing MIME objects |
| e84b4b86 TTN |
2 | |
| 3 | ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, | |
| e3fe4da0 | 4 | ;; 2005, 2006, 2007, 2008 Free Software Foundation, Inc. |
| c113de23 GM |
5 | |
| 6 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> | |
| 7 | ;; This file is part of GNU Emacs. | |
| 8 | ||
| 9 | ;; GNU Emacs is free software; you can redistribute it and/or modify | |
| 10 | ;; it under the terms of the GNU General Public License as published by | |
| 5a9dffec | 11 | ;; the Free Software Foundation; either version 3, or (at your option) |
| c113de23 GM |
12 | ;; any later version. |
| 13 | ||
| 14 | ;; GNU Emacs is distributed in the hope that it will be useful, | |
| 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
| 17 | ;; GNU General Public License for more details. | |
| 18 | ||
| 19 | ;; You should have received a copy of the GNU General Public License | |
| 20 | ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
| 3a35cf56 LK |
21 | ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, |
| 22 | ;; Boston, MA 02110-1301, USA. | |
| c113de23 GM |
23 | |
| 24 | ;;; Commentary: | |
| 25 | ||
| 26 | ;;; Code: | |
| 49ad38a1 GM |
27 | (eval-and-compile |
| 28 | (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) | |
| c113de23 GM |
29 | (eval-when-compile (require 'cl)) |
| 30 | (require 'mail-parse) | |
| 31 | (require 'mailcap) | |
| 32 | (require 'mm-bodies) | |
| 33 | (require 'mm-decode) | |
| 01c52d31 | 34 | (require 'smime) |
| c113de23 GM |
35 | |
| 36 | (eval-and-compile | |
| 37 | (autoload 'gnus-article-prepare-display "gnus-art") | |
| 38 | (autoload 'vcard-parse-string "vcard") | |
| 39 | (autoload 'vcard-format-string "vcard") | |
| 40 | (autoload 'fill-flowed "flow-fill") | |
| 01c52d31 | 41 | (autoload 'html2text "html2text" nil t)) |
| c113de23 | 42 | |
| dd3eac76 JB |
43 | (defvar gnus-article-mime-handles) |
| 44 | (defvar gnus-newsgroup-charset) | |
| 45 | (defvar smime-keys) | |
| 46 | (defvar w3m-cid-retrieve-function-alist) | |
| 47 | (defvar w3m-current-buffer) | |
| 48 | (defvar w3m-display-inline-images) | |
| 49 | (defvar w3m-minor-mode-map) | |
| 50 | ||
| 23f87bed MB |
51 | (defvar mm-text-html-renderer-alist |
| 52 | '((w3 . mm-inline-text-html-render-with-w3) | |
| 53 | (w3m . mm-inline-text-html-render-with-w3m) | |
| 73043f7d | 54 | (w3m-standalone . mm-inline-text-html-render-with-w3m-standalone) |
| 23f87bed MB |
55 | (links mm-inline-render-with-file |
| 56 | mm-links-remove-leading-blank | |
| 57 | "links" "-dump" file) | |
| 58 | (lynx mm-inline-render-with-stdin nil | |
| 59 | "lynx" "-dump" "-force_html" "-stdin" "-nolist") | |
| 60 | (html2text mm-inline-render-with-function html2text)) | |
| 61 | "The attributes of renderer types for text/html.") | |
| 62 | ||
| 63 | (defvar mm-text-html-washer-alist | |
| 64 | '((w3 . gnus-article-wash-html-with-w3) | |
| 65 | (w3m . gnus-article-wash-html-with-w3m) | |
| 73043f7d | 66 | (w3m-standalone . gnus-article-wash-html-with-w3m-standalone) |
| 23f87bed MB |
67 | (links mm-inline-wash-with-file |
| 68 | mm-links-remove-leading-blank | |
| 69 | "links" "-dump" file) | |
| 70 | (lynx mm-inline-wash-with-stdin nil | |
| 71 | "lynx" "-dump" "-force_html" "-stdin" "-nolist") | |
| 72 | (html2text html2text)) | |
| 73 | "The attributes of washer types for text/html.") | |
| 74 | ||
| 5f4264e5 | 75 | (defcustom mm-fill-flowed t |
| 01c52d31 | 76 | "If non-nil a format=flowed article will be displayed flowed." |
| 5f4264e5 MB |
77 | :type 'boolean |
| 78 | :version "22.1" | |
| 79 | :group 'mime-display) | |
| 80 | ||
| 23f87bed MB |
81 | ;;; Internal variables. |
| 82 | ||
| c113de23 GM |
83 | ;;; |
| 84 | ;;; Functions for displaying various formats inline | |
| 85 | ;;; | |
| 23f87bed | 86 | |
| c113de23 GM |
87 | (defun mm-inline-image-emacs (handle) |
| 88 | (let ((b (point-marker)) | |
| 89 | buffer-read-only) | |
| c113de23 | 90 | (put-image (mm-get-image handle) b) |
| 23f87bed | 91 | (insert "\n\n") |
| c113de23 GM |
92 | (mm-handle-set-undisplayer |
| 93 | handle | |
| 23f87bed MB |
94 | `(lambda () |
| 95 | (let ((b ,b) | |
| 96 | buffer-read-only) | |
| 97 | (remove-images b b) | |
| 98 | (delete-region b (+ b 2))))))) | |
| c113de23 GM |
99 | |
| 100 | (defun mm-inline-image-xemacs (handle) | |
| 9efa445f DN |
101 | (when (featurep 'xemacs) |
| 102 | (insert "\n\n") | |
| 103 | (forward-char -2) | |
| 104 | (let ((annot (make-annotation (mm-get-image handle) nil 'text)) | |
| 105 | buffer-read-only) | |
| 106 | (mm-handle-set-undisplayer | |
| 107 | handle | |
| 108 | `(lambda () | |
| 109 | (let ((b ,(point-marker)) | |
| 110 | buffer-read-only) | |
| 111 | (delete-annotation ,annot) | |
| 112 | (delete-region (- b 2) b)))) | |
| 113 | (set-extent-property annot 'mm t) | |
| 114 | (set-extent-property annot 'duplicable t)))) | |
| c113de23 GM |
115 | |
| 116 | (eval-and-compile | |
| 722a8409 | 117 | (if (featurep 'xemacs) |
| c113de23 GM |
118 | (defalias 'mm-inline-image 'mm-inline-image-xemacs) |
| 119 | (defalias 'mm-inline-image 'mm-inline-image-emacs))) | |
| 120 | ||
| 49ad38a1 GM |
121 | ;; External. |
| 122 | (declare-function w3-do-setup "ext:w3" ()) | |
| 123 | (declare-function w3-region "ext:w3-display" (st nd)) | |
| 124 | (declare-function w3-prepare-buffer "ext:w3-display" (&rest args)) | |
| 125 | ||
| c113de23 GM |
126 | (defvar mm-w3-setup nil) |
| 127 | (defun mm-setup-w3 () | |
| 128 | (unless mm-w3-setup | |
| 129 | (require 'w3) | |
| 130 | (w3-do-setup) | |
| 131 | (require 'url) | |
| 132 | (require 'w3-vars) | |
| 133 | (require 'url-vars) | |
| 134 | (setq mm-w3-setup t))) | |
| 135 | ||
| 23f87bed MB |
136 | (defun mm-inline-text-html-render-with-w3 (handle) |
| 137 | (mm-setup-w3) | |
| 138 | (let ((text (mm-get-part handle)) | |
| 139 | (b (point)) | |
| 140 | (url-standalone-mode t) | |
| 141 | (url-gateway-unplugged t) | |
| 142 | (w3-honor-stylesheets nil) | |
| 143 | (url-current-object | |
| 144 | (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) | |
| 145 | (width (window-width)) | |
| 146 | (charset (mail-content-type-get | |
| 147 | (mm-handle-type handle) 'charset))) | |
| 148 | (save-excursion | |
| 01c52d31 | 149 | (insert (if charset (mm-decode-string text charset) text)) |
| 23f87bed MB |
150 | (save-restriction |
| 151 | (narrow-to-region b (point)) | |
| 01c52d31 MB |
152 | (unless charset |
| 153 | (goto-char (point-min)) | |
| 154 | (when (or (and (boundp 'w3-meta-content-type-charset-regexp) | |
| 155 | (re-search-forward | |
| 156 | w3-meta-content-type-charset-regexp nil t)) | |
| 157 | (and (boundp 'w3-meta-charset-content-type-regexp) | |
| 158 | (re-search-forward | |
| 159 | w3-meta-charset-content-type-regexp nil t))) | |
| 23f87bed | 160 | (setq charset |
| 01c52d31 MB |
161 | (let ((bsubstr (buffer-substring-no-properties |
| 162 | (match-beginning 2) | |
| 163 | (match-end 2)))) | |
| 164 | (if (fboundp 'w3-coding-system-for-mime-charset) | |
| 165 | (w3-coding-system-for-mime-charset bsubstr) | |
| 166 | (mm-charset-to-coding-system bsubstr)))) | |
| 167 | (delete-region (point-min) (point-max)) | |
| 168 | (insert (mm-decode-string text charset)))) | |
| 23f87bed | 169 | (save-window-excursion |
| c113de23 | 170 | (save-restriction |
| 23f87bed MB |
171 | (let ((w3-strict-width width) |
| 172 | ;; Don't let w3 set the global version of | |
| 173 | ;; this variable. | |
| 174 | (fill-column fill-column)) | |
| 175 | (if (or debug-on-error debug-on-quit) | |
| 176 | (w3-region (point-min) (point-max)) | |
| 177 | (condition-case () | |
| 178 | (w3-region (point-min) (point-max)) | |
| 179 | (error | |
| 180 | (delete-region (point-min) (point-max)) | |
| 181 | (let ((b (point)) | |
| 182 | (charset (mail-content-type-get | |
| 183 | (mm-handle-type handle) 'charset))) | |
| 184 | (if (or (eq charset 'gnus-decoded) | |
| 185 | (eq mail-parse-charset 'gnus-decoded)) | |
| 186 | (save-restriction | |
| 187 | (narrow-to-region (point) (point)) | |
| 188 | (mm-insert-part handle) | |
| 189 | (goto-char (point-max))) | |
| 190 | (insert (mm-decode-string (mm-get-part handle) | |
| 191 | charset)))) | |
| 192 | (message | |
| 193 | "Error while rendering html; showing as text/plain"))))))) | |
| 194 | (mm-handle-set-undisplayer | |
| 195 | handle | |
| 196 | `(lambda () | |
| 197 | (let (buffer-read-only) | |
| 01c52d31 MB |
198 | ,@(if (functionp 'remove-specifier) |
| 199 | '((mapcar (lambda (prop) | |
| 200 | (remove-specifier | |
| 201 | (face-property 'default prop) | |
| 202 | (current-buffer))) | |
| 203 | '(background background-pixmap foreground)))) | |
| 23f87bed MB |
204 | (delete-region ,(point-min-marker) |
| 205 | ,(point-max-marker))))))))) | |
| 206 | ||
| 207 | (defvar mm-w3m-setup nil | |
| 208 | "Whether gnus-article-mode has been setup to use emacs-w3m.") | |
| 209 | ||
| 49ad38a1 GM |
210 | ;; External. |
| 211 | (declare-function w3m-detect-meta-charset "ext:w3m" ()) | |
| 212 | (declare-function w3m-region "ext:w3m" (start end &optional url charset)) | |
| 213 | ||
| 23f87bed MB |
214 | (defun mm-setup-w3m () |
| 215 | "Setup gnus-article-mode to use emacs-w3m." | |
| 216 | (unless mm-w3m-setup | |
| 217 | (require 'w3m) | |
| 218 | (unless (assq 'gnus-article-mode w3m-cid-retrieve-function-alist) | |
| 219 | (push (cons 'gnus-article-mode 'mm-w3m-cid-retrieve) | |
| 220 | w3m-cid-retrieve-function-alist)) | |
| 221 | (setq mm-w3m-setup t)) | |
| 222 | (setq w3m-display-inline-images mm-inline-text-html-with-images)) | |
| 223 | ||
| 224 | (defun mm-w3m-cid-retrieve-1 (url handle) | |
| 54506618 | 225 | (dolist (elem handle) |
| fe62aacc MB |
226 | (when (consp elem) |
| 227 | (when (equal url (mm-handle-id elem)) | |
| 228 | (mm-insert-part elem) | |
| 229 | (throw 'found-handle (mm-handle-media-type elem))) | |
| 230 | (when (and (stringp (car elem)) | |
| 231 | (equal "multipart" (mm-handle-media-supertype elem))) | |
| 232 | (mm-w3m-cid-retrieve-1 url elem))))) | |
| 23f87bed MB |
233 | |
| 234 | (defun mm-w3m-cid-retrieve (url &rest args) | |
| 235 | "Insert a content pointed by URL if it has the cid: scheme." | |
| 236 | (when (string-match "\\`cid:" url) | |
| fe62aacc MB |
237 | (or (catch 'found-handle |
| 238 | (mm-w3m-cid-retrieve-1 | |
| 239 | (setq url (concat "<" (substring url (match-end 0)) ">")) | |
| 240 | (with-current-buffer w3m-current-buffer | |
| 241 | gnus-article-mime-handles))) | |
| 242 | (prog1 | |
| 243 | nil | |
| 244 | (message "Failed to find \"Content-ID: %s\"" url))))) | |
| 23f87bed MB |
245 | |
| 246 | (defun mm-inline-text-html-render-with-w3m (handle) | |
| 247 | "Render a text/html part using emacs-w3m." | |
| 248 | (mm-setup-w3m) | |
| 249 | (let ((text (mm-get-part handle)) | |
| 250 | (b (point)) | |
| 6b554e88 MB |
251 | (charset (or (mail-content-type-get (mm-handle-type handle) 'charset) |
| 252 | mail-parse-charset))) | |
| 23f87bed MB |
253 | (save-excursion |
| 254 | (insert (if charset (mm-decode-string text charset) text)) | |
| 255 | (save-restriction | |
| 256 | (narrow-to-region b (point)) | |
| 257 | (unless charset | |
| 258 | (goto-char (point-min)) | |
| 259 | (when (setq charset (w3m-detect-meta-charset)) | |
| c113de23 | 260 | (delete-region (point-min) (point-max)) |
| 23f87bed MB |
261 | (insert (mm-decode-string text charset)))) |
| 262 | (let ((w3m-safe-url-regexp mm-w3m-safe-url-regexp) | |
| 263 | w3m-force-redisplay) | |
| 264 | (w3m-region (point-min) (point-max) nil charset)) | |
| 265 | (when (and mm-inline-text-html-with-w3m-keymap | |
| 266 | (boundp 'w3m-minor-mode-map) | |
| 267 | w3m-minor-mode-map) | |
| 268 | (add-text-properties | |
| 269 | (point-min) (point-max) | |
| 270 | (list 'keymap w3m-minor-mode-map | |
| 271 | ;; Put the mark meaning this part was rendered by emacs-w3m. | |
| 58090a8d MB |
272 | 'mm-inline-text-html-with-w3m t))) |
| 273 | (mm-handle-set-undisplayer | |
| 274 | handle | |
| 275 | `(lambda () | |
| 01c52d31 | 276 | (let ((inhibit-read-only t)) |
| 58090a8d MB |
277 | (delete-region ,(point-min-marker) |
| 278 | ,(point-max-marker))))))))) | |
| 23f87bed | 279 | |
| 7347faa8 MB |
280 | (defvar mm-w3m-standalone-supports-m17n-p (if (featurep 'mule) 'undecided) |
| 281 | "*T means the w3m command supports the m17n feature.") | |
| 282 | ||
| 283 | (defun mm-w3m-standalone-supports-m17n-p () | |
| 284 | "Say whether the w3m command supports the m17n feature." | |
| 285 | (cond ((eq mm-w3m-standalone-supports-m17n-p t) t) | |
| 286 | ((eq mm-w3m-standalone-supports-m17n-p nil) nil) | |
| 287 | ((not (featurep 'mule)) (setq mm-w3m-standalone-supports-m17n-p nil)) | |
| 288 | ((condition-case nil | |
| 289 | (let ((coding-system-for-write 'iso-2022-jp) | |
| 290 | (coding-system-for-read 'iso-2022-jp) | |
| 291 | (str (mm-decode-coding-string "\ | |
| 8f7abae3 | 292 | \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))) |
| 7347faa8 MB |
293 | (mm-with-multibyte-buffer |
| 294 | (insert str) | |
| 295 | (call-process-region | |
| 296 | (point-min) (point-max) "w3m" t t nil "-dump" | |
| 297 | "-T" "text/html" "-I" "iso-2022-jp" "-O" "iso-2022-jp") | |
| 298 | (goto-char (point-min)) | |
| 299 | (search-forward str nil t))) | |
| 300 | (error nil)) | |
| 301 | (setq mm-w3m-standalone-supports-m17n-p t)) | |
| 302 | (t | |
| 303 | ;;(message "You had better upgrade your w3m command") | |
| 304 | (setq mm-w3m-standalone-supports-m17n-p nil)))) | |
| 305 | ||
| 73043f7d MB |
306 | (defun mm-inline-text-html-render-with-w3m-standalone (handle) |
| 307 | "Render a text/html part using w3m." | |
| 7347faa8 MB |
308 | (if (mm-w3m-standalone-supports-m17n-p) |
| 309 | (let ((source (mm-get-part handle)) | |
| 6b554e88 MB |
310 | (charset (or (mail-content-type-get (mm-handle-type handle) |
| 311 | 'charset) | |
| 312 | (symbol-name mail-parse-charset))) | |
| 7347faa8 MB |
313 | cs) |
| 314 | (unless (and charset | |
| 315 | (setq cs (mm-charset-to-coding-system charset)) | |
| 316 | (not (eq cs 'ascii))) | |
| 317 | ;; The default. | |
| 318 | (setq charset "iso-8859-1" | |
| 319 | cs 'iso-8859-1)) | |
| 320 | (mm-insert-inline | |
| 321 | handle | |
| 322 | (mm-with-unibyte-buffer | |
| 323 | (insert source) | |
| 324 | (mm-enable-multibyte) | |
| 325 | (let ((coding-system-for-write 'binary) | |
| 326 | (coding-system-for-read cs)) | |
| 327 | (call-process-region | |
| 328 | (point-min) (point-max) | |
| 329 | "w3m" t t nil "-dump" "-T" "text/html" | |
| 330 | "-I" charset "-O" charset)) | |
| 331 | (buffer-string)))) | |
| 332 | (mm-inline-render-with-stdin handle nil "w3m" "-dump" "-T" "text/html"))) | |
| 73043f7d | 333 | |
| 23f87bed MB |
334 | (defun mm-links-remove-leading-blank () |
| 335 | ;; Delete the annoying three spaces preceding each line of links | |
| 336 | ;; output. | |
| 337 | (goto-char (point-min)) | |
| 338 | (while (re-search-forward "^ " nil t) | |
| 339 | (delete-region (match-beginning 0) (match-end 0)))) | |
| 340 | ||
| 341 | (defun mm-inline-wash-with-file (post-func cmd &rest args) | |
| 342 | (let ((file (mm-make-temp-file | |
| 343 | (expand-file-name "mm" mm-tmp-directory)))) | |
| 344 | (let ((coding-system-for-write 'binary)) | |
| 345 | (write-region (point-min) (point-max) file nil 'silent)) | |
| 346 | (delete-region (point-min) (point-max)) | |
| 347 | (unwind-protect | |
| 348 | (apply 'call-process cmd nil t nil (mapcar 'eval args)) | |
| 349 | (delete-file file)) | |
| 350 | (and post-func (funcall post-func)))) | |
| 351 | ||
| 352 | (defun mm-inline-wash-with-stdin (post-func cmd &rest args) | |
| 353 | (let ((coding-system-for-write 'binary)) | |
| 354 | (apply 'call-process-region (point-min) (point-max) | |
| 355 | cmd t t nil args)) | |
| 356 | (and post-func (funcall post-func))) | |
| 357 | ||
| 358 | (defun mm-inline-render-with-file (handle post-func cmd &rest args) | |
| 359 | (let ((source (mm-get-part handle))) | |
| 360 | (mm-insert-inline | |
| 361 | handle | |
| 362 | (mm-with-unibyte-buffer | |
| 363 | (insert source) | |
| 364 | (apply 'mm-inline-wash-with-file post-func cmd args) | |
| 365 | (buffer-string))))) | |
| 366 | ||
| 367 | (defun mm-inline-render-with-stdin (handle post-func cmd &rest args) | |
| 368 | (let ((source (mm-get-part handle))) | |
| 369 | (mm-insert-inline | |
| 370 | handle | |
| 371 | (mm-with-unibyte-buffer | |
| 372 | (insert source) | |
| 373 | (apply 'mm-inline-wash-with-stdin post-func cmd args) | |
| 374 | (buffer-string))))) | |
| 375 | ||
| 376 | (defun mm-inline-render-with-function (handle func &rest args) | |
| 377 | (let ((source (mm-get-part handle)) | |
| 6b554e88 MB |
378 | (charset (or (mail-content-type-get (mm-handle-type handle) 'charset) |
| 379 | mail-parse-charset))) | |
| 23f87bed MB |
380 | (mm-insert-inline |
| 381 | handle | |
| 382 | (mm-with-multibyte-buffer | |
| 383 | (insert (if charset | |
| 384 | (mm-decode-string source charset) | |
| 385 | source)) | |
| 386 | (apply func args) | |
| 387 | (buffer-string))))) | |
| 388 | ||
| 389 | (defun mm-inline-text-html (handle) | |
| 390 | (let* ((func (or mm-inline-text-html-renderer mm-text-html-renderer)) | |
| 391 | (entry (assq func mm-text-html-renderer-alist)) | |
| 392 | buffer-read-only) | |
| 393 | (if entry | |
| 394 | (setq func (cdr entry))) | |
| 395 | (cond | |
| 396 | ((functionp func) | |
| 397 | (funcall func handle)) | |
| c113de23 | 398 | (t |
| 23f87bed MB |
399 | (apply (car func) handle (cdr func)))))) |
| 400 | ||
| 401 | (defun mm-inline-text-vcard (handle) | |
| 402 | (let (buffer-read-only) | |
| 403 | (mm-insert-inline | |
| 404 | handle | |
| 405 | (concat "\n-- \n" | |
| 406 | (ignore-errors | |
| 407 | (if (fboundp 'vcard-pretty-print) | |
| 408 | (vcard-pretty-print (mm-get-part handle)) | |
| 409 | (vcard-format-string | |
| 410 | (vcard-parse-string (mm-get-part handle) | |
| 411 | 'vcard-standard-filter)))))))) | |
| 412 | ||
| 413 | (defun mm-inline-text (handle) | |
| 414 | (let ((b (point)) | |
| 415 | (type (mm-handle-media-subtype handle)) | |
| 416 | (charset (mail-content-type-get | |
| 417 | (mm-handle-type handle) 'charset)) | |
| 418 | buffer-read-only) | |
| 419 | (if (or (eq charset 'gnus-decoded) | |
| 420 | ;; This is probably not entirely correct, but | |
| 421 | ;; makes rfc822 parts with embedded multiparts work. | |
| 422 | (eq mail-parse-charset 'gnus-decoded)) | |
| c113de23 | 423 | (save-restriction |
| 23f87bed MB |
424 | (narrow-to-region (point) (point)) |
| 425 | (mm-insert-part handle) | |
| 426 | (goto-char (point-max))) | |
| 427 | (insert (mm-decode-string (mm-get-part handle) charset))) | |
| 5f4264e5 MB |
428 | (when (and mm-fill-flowed |
| 429 | (equal type "plain") | |
| 23f87bed MB |
430 | (equal (cdr (assoc 'format (mm-handle-type handle))) |
| 431 | "flowed")) | |
| 432 | (save-restriction | |
| 433 | (narrow-to-region b (point)) | |
| 434 | (goto-char b) | |
| 01c52d31 MB |
435 | (fill-flowed nil (equal (cdr (assoc 'delsp (mm-handle-type handle))) |
| 436 | "yes")) | |
| 23f87bed MB |
437 | (goto-char (point-max)))) |
| 438 | (save-restriction | |
| 439 | (narrow-to-region b (point)) | |
| 23f87bed MB |
440 | (when (or (equal type "enriched") |
| 441 | (equal type "richtext")) | |
| 53cfefc8 | 442 | (set-text-properties (point-min) (point-max) nil) |
| 23f87bed MB |
443 | (ignore-errors |
| 444 | (enriched-decode (point-min) (point-max)))) | |
| 445 | (mm-handle-set-undisplayer | |
| 446 | handle | |
| 447 | `(lambda () | |
| 448 | (let (buffer-read-only) | |
| 449 | (delete-region ,(point-min-marker) | |
| 450 | ,(point-max-marker)))))))) | |
| c113de23 GM |
451 | |
| 452 | (defun mm-insert-inline (handle text) | |
| 453 | "Insert TEXT inline from HANDLE." | |
| 23f87bed | 454 | (let ((b (point))) |
| c113de23 | 455 | (insert text) |
| 01c52d31 MB |
456 | (unless (bolp) |
| 457 | (insert "\n")) | |
| c113de23 GM |
458 | (mm-handle-set-undisplayer |
| 459 | handle | |
| 460 | `(lambda () | |
| 461 | (let (buffer-read-only) | |
| 462 | (delete-region ,(set-marker (make-marker) b) | |
| 463 | ,(set-marker (make-marker) (point)))))))) | |
| 464 | ||
| 465 | (defun mm-inline-audio (handle) | |
| 466 | (message "Not implemented")) | |
| 467 | ||
| 468 | (defun mm-view-sound-file () | |
| 469 | (message "Not implemented")) | |
| 470 | ||
| 471 | (defun mm-w3-prepare-buffer () | |
| 472 | (require 'w3) | |
| 6833e8ba | 473 | (let ((url-standalone-mode t) |
| 23f87bed MB |
474 | (url-gateway-unplugged t) |
| 475 | (w3-honor-stylesheets nil)) | |
| c113de23 GM |
476 | (w3-prepare-buffer))) |
| 477 | ||
| 478 | (defun mm-view-message () | |
| 479 | (mm-enable-multibyte) | |
| 480 | (let (handles) | |
| 481 | (let (gnus-article-mime-handles) | |
| 482 | ;; Double decode problem may happen. See mm-inline-message. | |
| 483 | (run-hooks 'gnus-article-decode-hook) | |
| 484 | (gnus-article-prepare-display) | |
| 485 | (setq handles gnus-article-mime-handles)) | |
| 486 | (when handles | |
| 487 | (setq gnus-article-mime-handles | |
| 23f87bed | 488 | (mm-merge-handles gnus-article-mime-handles handles)))) |
| c113de23 GM |
489 | (fundamental-mode) |
| 490 | (goto-char (point-min))) | |
| 491 | ||
| 492 | (defun mm-inline-message (handle) | |
| 493 | (let ((b (point)) | |
| 4e728580 | 494 | (bolp (bolp)) |
| c113de23 GM |
495 | (charset (mail-content-type-get |
| 496 | (mm-handle-type handle) 'charset)) | |
| 497 | gnus-displaying-mime handles) | |
| 498 | (when (and charset | |
| 499 | (stringp charset)) | |
| 500 | (setq charset (intern (downcase charset))) | |
| 501 | (when (eq charset 'us-ascii) | |
| 502 | (setq charset nil))) | |
| 503 | (save-excursion | |
| 504 | (save-restriction | |
| 505 | (narrow-to-region b b) | |
| 506 | (mm-insert-part handle) | |
| 507 | (let (gnus-article-mime-handles | |
| 4e728580 SZ |
508 | ;; disable prepare hook |
| 509 | gnus-article-prepare-hook | |
| c113de23 | 510 | (gnus-newsgroup-charset |
| 34128042 MB |
511 | (unless (eq charset 'gnus-decoded) ;; mm-uu might set it. |
| 512 | (or charset gnus-newsgroup-charset)))) | |
| 23f87bed MB |
513 | (let ((gnus-original-article-buffer (mm-handle-buffer handle))) |
| 514 | (run-hooks 'gnus-article-decode-hook)) | |
| c113de23 GM |
515 | (gnus-article-prepare-display) |
| 516 | (setq handles gnus-article-mime-handles)) | |
| 4e728580 SZ |
517 | (goto-char (point-min)) |
| 518 | (unless bolp | |
| 519 | (insert "\n")) | |
| c113de23 GM |
520 | (goto-char (point-max)) |
| 521 | (unless (bolp) | |
| 522 | (insert "\n")) | |
| 523 | (insert "----------\n\n") | |
| 524 | (when handles | |
| 525 | (setq gnus-article-mime-handles | |
| 23f87bed | 526 | (mm-merge-handles gnus-article-mime-handles handles))) |
| c113de23 GM |
527 | (mm-handle-set-undisplayer |
| 528 | handle | |
| 529 | `(lambda () | |
| 530 | (let (buffer-read-only) | |
| 722a8409 | 531 | (if (fboundp 'remove-specifier) |
| c113de23 GM |
532 | ;; This is only valid on XEmacs. |
| 533 | (mapcar (lambda (prop) | |
| 534 | (remove-specifier | |
| 535 | (face-property 'default prop) (current-buffer))) | |
| 722a8409 | 536 | '(background background-pixmap foreground))) |
| c113de23 GM |
537 | (delete-region ,(point-min-marker) ,(point-max-marker))))))))) |
| 538 | ||
| ce9401f3 | 539 | (defun mm-display-inline-fontify (handle mode) |
| 01c52d31 MB |
540 | (let ((charset (mail-content-type-get (mm-handle-type handle) 'charset)) |
| 541 | text coding-system) | |
| 542 | (unless (eq charset 'gnus-decoded) | |
| 543 | (mm-with-unibyte-buffer | |
| 544 | (mm-insert-part handle) | |
| 545 | (mm-decompress-buffer | |
| 546 | (or (mail-content-type-get (mm-handle-disposition handle) 'name) | |
| 547 | (mail-content-type-get (mm-handle-disposition handle) 'filename)) | |
| 548 | t t) | |
| 549 | (unless charset | |
| 550 | (setq coding-system (mm-find-buffer-file-coding-system))) | |
| 551 | (setq text (buffer-string)))) | |
| 23f87bed MB |
552 | ;; XEmacs @#$@ version of font-lock refuses to fully turn itself |
| 553 | ;; on for buffers whose name begins with " ". That's why we use | |
| 01c52d31 MB |
554 | ;; `with-current-buffer'/`generate-new-buffer' rather than |
| 555 | ;; `with-temp-buffer'. | |
| 556 | (with-current-buffer (generate-new-buffer "*fontification*") | |
| 557 | (buffer-disable-undo) | |
| 558 | (mm-enable-multibyte) | |
| 559 | (insert (cond ((eq charset 'gnus-decoded) | |
| 560 | (with-current-buffer (mm-handle-buffer handle) | |
| 561 | (buffer-string))) | |
| 562 | (coding-system | |
| 563 | (mm-decode-coding-string text coding-system)) | |
| 564 | (charset | |
| 565 | (mm-decode-string text charset)) | |
| 566 | (t | |
| 567 | text))) | |
| 568 | (require 'font-lock) | |
| 569 | (let ((font-lock-maximum-size nil) | |
| 570 | ;; Disable support modes, e.g., jit-lock, lazy-lock, etc. | |
| 571 | (font-lock-mode-hook nil) | |
| 572 | (font-lock-support-mode nil) | |
| 573 | ;; I find font-lock a bit too verbose. | |
| 574 | (font-lock-verbose nil)) | |
| 575 | (funcall mode) | |
| 576 | ;; The mode function might have already turned on font-lock. | |
| 577 | (unless (symbol-value 'font-lock-mode) | |
| 578 | (font-lock-fontify-buffer))) | |
| 579 | ;; By default, XEmacs font-lock uses non-duplicable text | |
| 580 | ;; properties. This code forces all the text properties | |
| 581 | ;; to be copied along with the text. | |
| 9efa445f | 582 | (when (featurep 'xemacs) |
| 01c52d31 MB |
583 | (map-extents (lambda (ext ignored) |
| 584 | (set-extent-property ext 'duplicable t) | |
| 585 | nil) | |
| 586 | nil nil nil nil nil 'text-prop)) | |
| 587 | (setq text (buffer-string)) | |
| 588 | (kill-buffer (current-buffer))) | |
| c113de23 GM |
589 | (mm-insert-inline handle text))) |
| 590 | ||
| 23f87bed MB |
591 | ;; Shouldn't these functions check whether the user even wants to use |
| 592 | ;; font-lock? At least under XEmacs, this fontification is pretty | |
| 593 | ;; much unconditional. Also, it would be nice to change for the size | |
| 594 | ;; of the fontified region. | |
| 595 | ||
| ce9401f3 DL |
596 | (defun mm-display-patch-inline (handle) |
| 597 | (mm-display-inline-fontify handle 'diff-mode)) | |
| 598 | ||
| 599 | (defun mm-display-elisp-inline (handle) | |
| 600 | (mm-display-inline-fontify handle 'emacs-lisp-mode)) | |
| 601 | ||
| 01c52d31 MB |
602 | (defun mm-display-dns-inline (handle) |
| 603 | (mm-display-inline-fontify handle 'dns-mode)) | |
| 604 | ||
| 23f87bed MB |
605 | ;; id-signedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) |
| 606 | ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 2 } | |
| 607 | (defvar mm-pkcs7-signed-magic | |
| 608 | (mm-string-as-unibyte | |
| 01c52d31 MB |
609 | (mapconcat 'char-to-string |
| 610 | (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c | |
| 611 | ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e | |
| 612 | ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 | |
| 613 | ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x02) ""))) | |
| 23f87bed MB |
614 | |
| 615 | ;; id-envelopedData OBJECT IDENTIFIER ::= { iso(1) member-body(2) | |
| 616 | ;; us(840) rsadsi(113549) pkcs(1) pkcs7(7) 3 } | |
| 617 | (defvar mm-pkcs7-enveloped-magic | |
| 618 | (mm-string-as-unibyte | |
| 01c52d31 MB |
619 | (mapconcat 'char-to-string |
| 620 | (list ?\x30 ?\x5c ?\x28 ?\x80 ?\x5c ?\x7c ?\x81 ?\x2e ?\x5c | |
| 621 | ?\x7c ?\x82 ?\x2e ?\x2e ?\x5c ?\x7c ?\x83 ?\x2e ?\x2e | |
| 622 | ?\x2e ?\x5c ?\x29 ?\x06 ?\x09 ?\x5c ?\x2a ?\x86 ?\x48 | |
| 623 | ?\x86 ?\xf7 ?\x0d ?\x01 ?\x07 ?\x03) ""))) | |
| 23f87bed MB |
624 | |
| 625 | (defun mm-view-pkcs7-get-type (handle) | |
| 626 | (mm-with-unibyte-buffer | |
| 627 | (mm-insert-part handle) | |
| 628 | (cond ((looking-at mm-pkcs7-enveloped-magic) | |
| 629 | 'enveloped) | |
| 630 | ((looking-at mm-pkcs7-signed-magic) | |
| 631 | 'signed) | |
| 632 | (t | |
| 633 | (error "Could not identify PKCS#7 type"))))) | |
| 634 | ||
| 635 | (defun mm-view-pkcs7 (handle) | |
| 636 | (case (mm-view-pkcs7-get-type handle) | |
| 637 | (enveloped (mm-view-pkcs7-decrypt handle)) | |
| 638 | (signed (mm-view-pkcs7-verify handle)) | |
| 639 | (otherwise (error "Unknown or unimplemented PKCS#7 type")))) | |
| 640 | ||
| 641 | (defun mm-view-pkcs7-verify (handle) | |
| 01c52d31 MB |
642 | (let ((verified nil)) |
| 643 | (with-temp-buffer | |
| 644 | (insert "MIME-Version: 1.0\n") | |
| 645 | (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") | |
| 646 | (insert-buffer-substring (mm-handle-buffer handle)) | |
| 647 | (setq verified (smime-verify-region (point-min) (point-max)))) | |
| 648 | (goto-char (point-min)) | |
| 649 | (mm-insert-part handle) | |
| 650 | (if (search-forward "Content-Type: " nil t) | |
| 651 | (delete-region (point-min) (match-beginning 0))) | |
| 652 | (goto-char (point-max)) | |
| 653 | (if (re-search-backward "--\r?\n?" nil t) | |
| 654 | (delete-region (match-end 0) (point-max))) | |
| 655 | (unless verified | |
| 656 | (insert-buffer-substring smime-details-buffer))) | |
| 23f87bed MB |
657 | (goto-char (point-min)) |
| 658 | (while (search-forward "\r\n" nil t) | |
| 659 | (replace-match "\n")) | |
| 23f87bed MB |
660 | t) |
| 661 | ||
| 23f87bed MB |
662 | (defun mm-view-pkcs7-decrypt (handle) |
| 663 | (insert-buffer-substring (mm-handle-buffer handle)) | |
| 664 | (goto-char (point-min)) | |
| 665 | (insert "MIME-Version: 1.0\n") | |
| 666 | (mm-insert-headers "application/pkcs7-mime" "base64" "smime.p7m") | |
| 667 | (smime-decrypt-region | |
| 668 | (point-min) (point-max) | |
| 669 | (if (= (length smime-keys) 1) | |
| 670 | (cadar smime-keys) | |
| 671 | (smime-get-key-by-email | |
| 01c52d31 | 672 | (completing-read |
| 81df110a | 673 | (concat "Decipher using key" |
| 01c52d31 | 674 | (if smime-keys (concat "(default " (caar smime-keys) "): ") |
| 81df110a | 675 | ": ")) |
| 23f87bed MB |
676 | smime-keys nil nil nil nil (car-safe (car-safe smime-keys)))))) |
| 677 | (goto-char (point-min)) | |
| 678 | (while (search-forward "\r\n" nil t) | |
| 679 | (replace-match "\n")) | |
| 680 | (goto-char (point-min))) | |
| 681 | ||
| c113de23 GM |
682 | (provide 'mm-view) |
| 683 | ||
| ab5796a9 | 684 | ;;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2 |
| 715a2ca2 | 685 | ;;; mm-view.el ends here |