| 1 | ;;; mm-view.el --- Functions for viewing MIME objects |
| 2 | ;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. |
| 3 | |
| 4 | ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> |
| 5 | ;; This file is part of GNU Emacs. |
| 6 | |
| 7 | ;; GNU Emacs is free software; you can redistribute it and/or modify |
| 8 | ;; it under the terms of the GNU General Public License as published by |
| 9 | ;; the Free Software Foundation; either version 2, or (at your option) |
| 10 | ;; any later version. |
| 11 | |
| 12 | ;; GNU Emacs is distributed in the hope that it will be useful, |
| 13 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 14 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 15 | ;; GNU General Public License for more details. |
| 16 | |
| 17 | ;; You should have received a copy of the GNU General Public License |
| 18 | ;; along with GNU Emacs; see the file COPYING. If not, write to the |
| 19 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, |
| 20 | ;; Boston, MA 02111-1307, USA. |
| 21 | |
| 22 | ;;; Commentary: |
| 23 | |
| 24 | ;;; Code: |
| 25 | |
| 26 | (eval-when-compile (require 'cl)) |
| 27 | (require 'mail-parse) |
| 28 | (require 'mailcap) |
| 29 | (require 'mm-bodies) |
| 30 | (require 'mm-decode) |
| 31 | |
| 32 | (eval-and-compile |
| 33 | (autoload 'gnus-article-prepare-display "gnus-art") |
| 34 | (autoload 'vcard-parse-string "vcard") |
| 35 | (autoload 'vcard-format-string "vcard") |
| 36 | (autoload 'fill-flowed "flow-fill") |
| 37 | (autoload 'diff-mode "diff-mode")) |
| 38 | |
| 39 | ;;; |
| 40 | ;;; Functions for displaying various formats inline |
| 41 | ;;; |
| 42 | (defun mm-inline-image-emacs (handle) |
| 43 | (let ((b (point-marker)) |
| 44 | buffer-read-only) |
| 45 | (insert "\n") |
| 46 | (put-image (mm-get-image handle) b) |
| 47 | (mm-handle-set-undisplayer |
| 48 | handle |
| 49 | `(lambda () (remove-images ,b (1+ ,b)))))) |
| 50 | |
| 51 | (defun mm-inline-image-xemacs (handle) |
| 52 | (let ((b (point)) |
| 53 | (annot (make-annotation (mm-get-image handle) nil 'text)) |
| 54 | buffer-read-only) |
| 55 | (insert "\n") |
| 56 | (mm-handle-set-undisplayer |
| 57 | handle |
| 58 | `(lambda () |
| 59 | (let (buffer-read-only) |
| 60 | (delete-annotation ,annot) |
| 61 | (delete-region ,(set-marker (make-marker) b) |
| 62 | ,(set-marker (make-marker) (point)))))) |
| 63 | (set-extent-property annot 'mm t) |
| 64 | (set-extent-property annot 'duplicable t))) |
| 65 | |
| 66 | (eval-and-compile |
| 67 | (if (featurep 'xemacs) |
| 68 | (defalias 'mm-inline-image 'mm-inline-image-xemacs) |
| 69 | (defalias 'mm-inline-image 'mm-inline-image-emacs))) |
| 70 | |
| 71 | (defvar mm-w3-setup nil) |
| 72 | (defun mm-setup-w3 () |
| 73 | (unless mm-w3-setup |
| 74 | (require 'w3) |
| 75 | (w3-do-setup) |
| 76 | (require 'url) |
| 77 | (require 'w3-vars) |
| 78 | (require 'url-vars) |
| 79 | (setq mm-w3-setup t))) |
| 80 | |
| 81 | (defun mm-inline-text (handle) |
| 82 | (let ((type (mm-handle-media-subtype handle)) |
| 83 | text buffer-read-only) |
| 84 | (cond |
| 85 | ((equal type "html") |
| 86 | (mm-setup-w3) |
| 87 | (setq text (mm-get-part handle)) |
| 88 | (let ((b (point)) |
| 89 | (url-standalone-mode t) |
| 90 | (url-current-object |
| 91 | (url-generic-parse-url (format "cid:%s" (mm-handle-id handle)))) |
| 92 | (width (window-width)) |
| 93 | (charset (mail-content-type-get |
| 94 | (mm-handle-type handle) 'charset))) |
| 95 | (save-excursion |
| 96 | (insert text) |
| 97 | (save-restriction |
| 98 | (narrow-to-region b (point)) |
| 99 | (goto-char (point-min)) |
| 100 | (if (or (and (boundp 'w3-meta-content-type-charset-regexp) |
| 101 | (re-search-forward |
| 102 | w3-meta-content-type-charset-regexp nil t)) |
| 103 | (and (boundp 'w3-meta-charset-content-type-regexp) |
| 104 | (re-search-forward |
| 105 | w3-meta-charset-content-type-regexp nil t))) |
| 106 | (setq charset (or (w3-coding-system-for-mime-charset |
| 107 | (buffer-substring-no-properties |
| 108 | (match-beginning 2) |
| 109 | (match-end 2))) |
| 110 | charset))) |
| 111 | (delete-region (point-min) (point-max)) |
| 112 | (insert (mm-decode-string text charset)) |
| 113 | (save-window-excursion |
| 114 | (save-restriction |
| 115 | (let ((w3-strict-width width) |
| 116 | ;; Don't let w3 set the global version of |
| 117 | ;; this variable. |
| 118 | (fill-column fill-column) |
| 119 | (url-standalone-mode t)) |
| 120 | (condition-case var |
| 121 | (w3-region (point-min) (point-max)) |
| 122 | (error))))) |
| 123 | (mm-handle-set-undisplayer |
| 124 | handle |
| 125 | `(lambda () |
| 126 | (let (buffer-read-only) |
| 127 | (if (functionp 'remove-specifier) |
| 128 | (mapcar (lambda (prop) |
| 129 | (remove-specifier |
| 130 | (face-property 'default prop) |
| 131 | (current-buffer))) |
| 132 | '(background background-pixmap foreground))) |
| 133 | (delete-region ,(point-min-marker) |
| 134 | ,(point-max-marker))))))))) |
| 135 | ((or (equal type "enriched") |
| 136 | (equal type "richtext")) |
| 137 | (save-excursion |
| 138 | (mm-with-unibyte-buffer |
| 139 | (mm-insert-part handle) |
| 140 | (save-window-excursion |
| 141 | (enriched-decode (point-min) (point-max)) |
| 142 | (setq text (buffer-string))))) |
| 143 | (mm-insert-inline handle text)) |
| 144 | ((equal type "x-vcard") |
| 145 | (mm-insert-inline |
| 146 | handle |
| 147 | (concat "\n-- \n" |
| 148 | (if (fboundp 'vcard-pretty-print) |
| 149 | (vcard-pretty-print (mm-get-part handle)) |
| 150 | (vcard-format-string |
| 151 | (vcard-parse-string (mm-get-part handle) |
| 152 | 'vcard-standard-filter)))))) |
| 153 | (t |
| 154 | (let ((b (point)) |
| 155 | (charset (mail-content-type-get |
| 156 | (mm-handle-type handle) 'charset))) |
| 157 | (if (or (eq charset 'gnus-decoded) |
| 158 | ;; This is probably not entirely correct, but |
| 159 | ;; makes rfc822 parts with embedded multiparts work. |
| 160 | (eq mail-parse-charset 'gnus-decoded)) |
| 161 | (mm-insert-part handle) |
| 162 | (insert (mm-decode-string (mm-get-part handle) charset))) |
| 163 | (when (and (equal type "plain") |
| 164 | (equal (cdr (assoc 'format (mm-handle-type handle))) |
| 165 | "flowed")) |
| 166 | (save-restriction |
| 167 | (narrow-to-region b (point)) |
| 168 | (goto-char b) |
| 169 | (fill-flowed) |
| 170 | (goto-char (point-max)))) |
| 171 | (save-restriction |
| 172 | (narrow-to-region b (point)) |
| 173 | (set-text-properties (point-min) (point-max) nil) |
| 174 | (mm-handle-set-undisplayer |
| 175 | handle |
| 176 | `(lambda () |
| 177 | (let (buffer-read-only) |
| 178 | (delete-region ,(point-min-marker) |
| 179 | ,(point-max-marker))))))))))) |
| 180 | |
| 181 | (defun mm-insert-inline (handle text) |
| 182 | "Insert TEXT inline from HANDLE." |
| 183 | (let ((b (point))) |
| 184 | (insert text) |
| 185 | (mm-handle-set-undisplayer |
| 186 | handle |
| 187 | `(lambda () |
| 188 | (let (buffer-read-only) |
| 189 | (delete-region ,(set-marker (make-marker) b) |
| 190 | ,(set-marker (make-marker) (point)))))))) |
| 191 | |
| 192 | (defun mm-inline-audio (handle) |
| 193 | (message "Not implemented")) |
| 194 | |
| 195 | (defun mm-view-sound-file () |
| 196 | (message "Not implemented")) |
| 197 | |
| 198 | (defun mm-w3-prepare-buffer () |
| 199 | (require 'w3) |
| 200 | (let ((url-standalone-mode t)) |
| 201 | (w3-prepare-buffer))) |
| 202 | |
| 203 | (defun mm-view-message () |
| 204 | (mm-enable-multibyte) |
| 205 | (let (handles) |
| 206 | (let (gnus-article-mime-handles) |
| 207 | ;; Double decode problem may happen. See mm-inline-message. |
| 208 | (run-hooks 'gnus-article-decode-hook) |
| 209 | (gnus-article-prepare-display) |
| 210 | (setq handles gnus-article-mime-handles)) |
| 211 | (when handles |
| 212 | (setq gnus-article-mime-handles |
| 213 | (nconc gnus-article-mime-handles |
| 214 | (if (listp (car handles)) |
| 215 | handles (list handles)))))) |
| 216 | (fundamental-mode) |
| 217 | (goto-char (point-min))) |
| 218 | |
| 219 | (defun mm-inline-message (handle) |
| 220 | (let ((b (point)) |
| 221 | (charset (mail-content-type-get |
| 222 | (mm-handle-type handle) 'charset)) |
| 223 | gnus-displaying-mime handles) |
| 224 | (when (and charset |
| 225 | (stringp charset)) |
| 226 | (setq charset (intern (downcase charset))) |
| 227 | (when (eq charset 'us-ascii) |
| 228 | (setq charset nil))) |
| 229 | (save-excursion |
| 230 | (save-restriction |
| 231 | (narrow-to-region b b) |
| 232 | (mm-insert-part handle) |
| 233 | (let (gnus-article-mime-handles |
| 234 | ;; disable prepare hook |
| 235 | gnus-article-prepare-hook |
| 236 | (gnus-newsgroup-charset |
| 237 | (or charset gnus-newsgroup-charset))) |
| 238 | (run-hooks 'gnus-article-decode-hook) |
| 239 | (gnus-article-prepare-display) |
| 240 | (setq handles gnus-article-mime-handles)) |
| 241 | (goto-char (point-max)) |
| 242 | (unless (bolp) |
| 243 | (insert "\n")) |
| 244 | (insert "----------\n\n") |
| 245 | (when handles |
| 246 | (setq gnus-article-mime-handles |
| 247 | (nconc gnus-article-mime-handles |
| 248 | (if (listp (car handles)) |
| 249 | handles (list handles))))) |
| 250 | (mm-handle-set-undisplayer |
| 251 | handle |
| 252 | `(lambda () |
| 253 | (let (buffer-read-only) |
| 254 | (if (fboundp 'remove-specifier) |
| 255 | ;; This is only valid on XEmacs. |
| 256 | (mapcar (lambda (prop) |
| 257 | (remove-specifier |
| 258 | (face-property 'default prop) (current-buffer))) |
| 259 | '(background background-pixmap foreground))) |
| 260 | (delete-region ,(point-min-marker) ,(point-max-marker))))))))) |
| 261 | |
| 262 | (defun mm-display-inline-fontify (handle mode) |
| 263 | (let (text) |
| 264 | (with-temp-buffer |
| 265 | (mm-insert-part handle) |
| 266 | (funcall mode) |
| 267 | (font-lock-fontify-buffer) |
| 268 | (when (fboundp 'extent-list) |
| 269 | (map-extents (lambda (ext ignored) |
| 270 | (set-extent-property ext 'duplicable t) |
| 271 | nil) |
| 272 | nil nil nil nil nil 'text-prop)) |
| 273 | (setq text (buffer-string))) |
| 274 | (mm-insert-inline handle text))) |
| 275 | |
| 276 | (defun mm-display-patch-inline (handle) |
| 277 | (mm-display-inline-fontify handle 'diff-mode)) |
| 278 | |
| 279 | (defun mm-display-elisp-inline (handle) |
| 280 | (mm-display-inline-fontify handle 'emacs-lisp-mode)) |
| 281 | |
| 282 | (provide 'mm-view) |
| 283 | |
| 284 | ;; mm-view.el ends here |