cgit.sxemacs.org Git - gnus/blob - lisp/mm-view.el

   1 ;;; mm-view.el --- Functions for viewing MIME objects
   2 ;; Copyright (C) 1998,99 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 (require 'mail-parse)
  27 (require 'mailcap)
  28 (require 'mm-bodies)
  29 (require 'mm-decode)
  30
  31 (eval-and-compile
  32   (autoload 'gnus-article-prepare-display "gnus-art")
  33   (autoload 'vcard-parse-string "vcard")
  34   (autoload 'vcard-format-string "vcard"))
  35
  36 ;;;
  37 ;;; Functions for displaying various formats inline
  38 ;;;
  39
  40 (defun mm-inline-image (handle)
  41   (let ((b (point))
  42         (annot (make-annotation (mm-get-image handle) nil 'text))
  43         buffer-read-only)
  44     (insert "\n")
  45     (mm-handle-set-undisplayer
  46      handle
  47      `(lambda ()
  48         (let (buffer-read-only)
  49           (delete-annotation ,annot)
  50           (delete-region ,(set-marker (make-marker) b)
  51                          ,(set-marker (make-marker) (point))))))
  52     (set-extent-property annot 'mm t)
  53     (set-extent-property annot 'duplicable t)))
  54
  55 (defvar mm-w3-setup nil)
  56 (defun mm-setup-w3 ()
  57   (unless mm-w3-setup
  58     (require 'w3)
  59     (w3-do-setup)
  60     (require 'url)
  61     (require 'w3-vars)
  62     (require 'url-vars)
  63     (setq mm-w3-setup t)))
  64
  65 (defun mm-inline-text (handle)
  66   (let ((type (mm-handle-media-subtype handle))
  67         text buffer-read-only)
  68     (cond
  69      ((equal type "html")
  70       (mm-setup-w3)
  71       (setq text (mm-get-part handle))
  72       (let ((b (point))
  73             (url-standalone-mode t)
  74             (url-current-object
  75              (url-generic-parse-url (format "cid:%s" (mm-handle-id handle))))
  76             (width (window-width))
  77             (charset (mail-content-type-get
  78                       (mm-handle-type handle) 'charset)))
  79         (save-excursion
  80           (insert text)
  81           (save-restriction
  82             (narrow-to-region b (point))
  83             (goto-char (point-min))
  84             (if (or (and (boundp 'w3-meta-content-type-charset-regexp)
  85                          (re-search-forward
  86                           w3-meta-content-type-charset-regexp nil t))
  87                     (and (boundp 'w3-meta-charset-content-type-regexp)
  88                          (re-search-forward
  89                           w3-meta-charset-content-type-regexp nil t)))
  90                 (setq charset (w3-coding-system-for-mime-charset
  91                                (buffer-substring-no-properties
  92                                 (match-beginning 2)
  93                                 (match-end 2)))))
  94             (delete-region (point-min) (point-max))
  95             (insert (mm-decode-string text charset))
  96             (save-window-excursion
  97               (save-restriction
  98                 (let ((w3-strict-width width)
  99                       (url-standalone-mode t))
 100                   (condition-case var
 101                       (w3-region (point-min) (point-max))
 102                     (error)))))
 103             (mm-handle-set-undisplayer
 104              handle
 105              `(lambda ()
 106                 (let (buffer-read-only)
 107                   (if (functionp 'remove-specifier)
 108                       (mapc (lambda (prop)
 109                               (remove-specifier
 110                                (face-property 'default prop) (current-buffer)))
 111                             '(background background-pixmap foreground)))
 112                   (delete-region ,(point-min-marker)
 113                                  ,(point-max-marker)))))))))
 114      ((or (equal type "enriched")
 115           (equal type "richtext"))
 116       (save-excursion
 117         (mm-with-unibyte-buffer
 118           (mm-insert-part handle)
 119           (save-window-excursion
 120             (enriched-decode (point-min) (point-max))
 121             (setq text (buffer-string)))))
 122       (mm-insert-inline handle text))
 123      ((equal type "x-vcard")
 124       (mm-insert-inline
 125        handle
 126        (concat "\n-- \n"
 127                (vcard-format-string
 128                 (vcard-parse-string (mm-get-part handle)
 129                                     'vcard-standard-filter)))))
 130      (t
 131       (setq text (mm-get-part handle))
 132       (let ((b (point))
 133             (charset (mail-content-type-get
 134                       (mm-handle-type handle) 'charset)))
 135         (insert (mm-decode-string text charset))
 136         (save-restriction
 137           (narrow-to-region b (point))
 138           (set-text-properties (point-min) (point-max) nil)
 139           (mm-handle-set-undisplayer
 140            handle
 141            `(lambda ()
 142               (let (buffer-read-only)
 143                 (delete-region ,(point-min-marker)
 144                                ,(point-max-marker)))))))))))
 145
 146 (defun mm-insert-inline (handle text)
 147   "Insert TEXT inline from HANDLE."
 148   (let ((b (point)))
 149     (insert text)
 150     (mm-handle-set-undisplayer
 151      handle
 152      `(lambda ()
 153         (let (buffer-read-only)
 154           (delete-region ,(set-marker (make-marker) b)
 155                          ,(set-marker (make-marker) (point))))))))
 156
 157 (defun mm-inline-audio (handle)
 158   (message "Not implemented"))
 159
 160 (defun mm-view-sound-file ()
 161   (message "Not implemented"))
 162
 163 (defun mm-w3-prepare-buffer ()
 164   (require 'w3)
 165   (let ((url-standalone-mode t))
 166     (w3-prepare-buffer)))
 167
 168 (defun mm-view-message ()
 169   (mm-enable-multibyte)
 170   (gnus-article-prepare-display)
 171   (run-hooks 'gnus-article-decode-hook)
 172   (fundamental-mode)
 173   (goto-char (point-min)))
 174
 175 (defun mm-inline-message (handle)
 176   (let ((b (point))
 177         gnus-displaying-mime handles)
 178     (save-excursion
 179       (save-restriction
 180         (narrow-to-region b b)
 181         (mm-insert-part handle)
 182         (let (gnus-article-mime-handles)
 183           (run-hooks 'gnus-article-decode-hook)
 184           (gnus-article-prepare-display)
 185           (setq handles gnus-article-mime-handles))
 186         (when handles
 187           (setq gnus-article-mime-handles
 188                 (append gnus-article-mime-handles handles)))
 189         (mm-handle-set-undisplayer
 190          handle
 191          `(lambda ()
 192             (let (buffer-read-only)
 193               (ignore-errors
 194                 ;; This is only valid on XEmacs.
 195                 (mapc (lambda (prop)
 196                         (remove-specifier
 197                          (face-property 'default prop) (current-buffer)))
 198                       '(background background-pixmap foreground)))
 199               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
 200
 201 (provide 'mm-view)
 202
 203 ;; mm-view.el ends here