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 (cadr (split-string (car (mm-handle-type 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 (re-search-forward
  85                      w3-meta-content-type-charset-regexp nil t)
  86                     (re-search-forward
  87                      w3-meta-charset-content-type-regexp nil t))
  88                 (setq charset (w3-coding-system-for-mime-charset
  89                                (buffer-substring-no-properties
  90                                 (match-beginning 2)
  91                                 (match-end 2)))))
  92             (mm-decode-body charset)
  93             (save-window-excursion
  94               (save-restriction
  95                 (let ((w3-strict-width width)
  96                       (url-standalone-mode t))
  97                   (condition-case var
  98                       (w3-region (point-min) (point-max))
  99                     (error)))))
 100 ;;;         (narrow-to-region (1+ (point-min)) (point-max))
 101             (mm-handle-set-undisplayer
 102              handle
 103              `(lambda ()
 104                 (let (buffer-read-only)
 105                   (if (functionp 'remove-specifier)
 106                       (mapc (lambda (prop)
 107                               (remove-specifier
 108                                (face-property 'default prop) (current-buffer)))
 109                             '(background background-pixmap foreground)))
 110                   (delete-region ,(point-min-marker)
 111                                  ,(point-max-marker)))))))))
 112      ((or (equal type "enriched")
 113           (equal type "richtext"))
 114       (save-excursion
 115         (mm-with-unibyte-buffer
 116           (mm-insert-part handle)
 117           (save-window-excursion
 118             (enriched-decode (point-min) (point-max))
 119             (setq text (buffer-string)))))
 120       (mm-insert-inline handle text))
 121      ((equal type "x-vcard")
 122       (mm-insert-inline
 123        handle
 124        (concat "\n-- \n"
 125                (vcard-format-string
 126                 (vcard-parse-string (mm-get-part handle)
 127                                     'vcard-standard-filter)))))
 128      (t
 129       (setq text (mm-get-part handle))
 130       (let ((b (point))
 131             (charset (mail-content-type-get
 132                       (mm-handle-type handle) 'charset)))
 133         (insert (mm-decode-string text charset))
 134         (save-restriction
 135           (narrow-to-region b (point))
 136           (set-text-properties (point-min) (point-max) nil)
 137           (mm-handle-set-undisplayer
 138            handle
 139            `(lambda ()
 140               (let (buffer-read-only)
 141                 (delete-region ,(point-min-marker)
 142                                ,(point-max-marker)))))))))))
 143
 144 (defun mm-insert-inline (handle text)
 145   "Insert TEXT inline from HANDLE."
 146   (let ((b (point)))
 147     (insert text)
 148     (mm-handle-set-undisplayer
 149      handle
 150      `(lambda ()
 151         (let (buffer-read-only)
 152           (delete-region ,(set-marker (make-marker) b)
 153                          ,(set-marker (make-marker) (point))))))))
 154
 155 (defun mm-inline-audio (handle)
 156   (message "Not implemented"))
 157
 158 (defun mm-view-sound-file ()
 159   (message "Not implemented"))
 160
 161 (defun mm-w3-prepare-buffer ()
 162   (require 'w3)
 163   (let ((url-standalone-mode t))
 164     (w3-prepare-buffer)))
 165
 166 (defun mm-view-message ()
 167   (mm-enable-multibyte)
 168   (gnus-article-prepare-display)
 169   (run-hooks 'gnus-article-decode-hook)
 170   (fundamental-mode)
 171   (goto-char (point-min)))
 172
 173 (defun mm-inline-message (handle)
 174   (let ((b (point)) gnus-displaying-mime handles)
 175     (save-excursion
 176       (save-restriction
 177         (narrow-to-region b b)
 178         (mm-insert-part handle)
 179         (let (gnus-article-mime-handles)
 180           (run-hooks 'gnus-article-decode-hook)
 181           (gnus-article-prepare-display)
 182           (setq handles gnus-article-mime-handles))
 183         (if handles
 184             (setq gnus-article-mime-handles
 185                   (append gnus-article-mime-handles handles)))
 186         (mm-handle-set-undisplayer
 187          handle
 188          `(lambda ()
 189             (let (buffer-read-only)
 190               (mapc (lambda (prop)
 191                       (remove-specifier
 192                        (face-property 'default prop) (current-buffer)))
 193                     '(background background-pixmap foreground))
 194               (delete-region ,(point-min-marker) ,(point-max-marker)))))))))
 195
 196 (provide 'mm-view)
 197
 198 ;; mm-view.el ends here