view lisp/gnus/mm-view.el @ 47641:172cf7391545

(calc-bug-address, calc-scan-for-dels, calc-stack) (calc-stack-top, calc-always-load-extensions) (calc-line-numbering, calc-line-breaking, calc-display-just) (calc-display-origin, calc-number-radix, calc-leading-zeros) (calc-group-digits, calc-group-char, calc-point-char) (calc-frac-format, calc-prefer-frac, calc-hms-format) (calc-date-format, calc-float-format, calc-complex-format) (calc-full-float-format, calc-complex-mode, calc-infinite-mode) (calc-display-strings, calc-matrix-just, calc-break-vectors) (calc-full-vectors, calc-full-trail-vectors, calc-vector-commas) (calc-vector-brackets, calc-matrix-brackets, calc-language) (calc-language-option, calc-function-open, calc-function-open) (calc-function-close, calc-language-output-filter) (calc-language-input-filter, calc-radix-formatter) (calc-left-label, calc-right-label, calc-word-size) (calc-previous-modulo, calc-simplify-mode, calc-auto-recompute) (calc-display-raw, calc-internal-prec, calc-inverse-flag) (calc-hyperbolic-flag, calc-keep-args-flag, calc-angle-mode) (calc-algebraic-mode, calc-incomplete-algebraic-mode) (calc-symbolic-mode, calc-matrix-mode, calc-shift-prefix) (calc-window-height, calc-display-trail, calc-show-selections) (calc-use-selections, calc-assoc-selections) (calc-display-working-message, calc-auto-why, calc-timing) (calc-display-sci-high, calc-display-sci-low, calc-other-modes) (calc-other-modes, calc-Y-help-msgs, calc-loaded-settings-file): Make into real defvars. (calc-mode-var-list): Delete. (calc-mode-save-mode, calc-standard-date-formats) (calc-autorange-units, calc-was-keypad-mode, calc-full-mode) (calc-user-parse-tables, calc-gnuplot-default-device) (calc-gnuplot-default-output, calc-gnuplot-print-device) (calc-gnuplot-print-output, calc-gnuplot-geometry) (calc-graph-default-resolution, calc-graph-default-resolution-3d) (calc-invocation-macro, calc-show-banner): Make into defvars, taken from `calc-mode-var-list'. (calc-emacs-type-epoch, calc-emacs-type-19) (calc-emacs-type-lucid, calc-emacs-type-gnu19): Make into defvars. (calc-version, calc-version-date, calc-trail-pointer) (calc-trail-overlay, calc-undo-list, calc-redo-list) (calc-main-buffer, calc-trail-buffer, calc-why, calc-next-why) (calc-inverse-flag, calc-hyperbolic-flag, calc-keep-args-flag) (calc-last-kill, calc-previous-alg-entry, calc-dollar-values) (calc-dollar-used, calc-hashes-used, calc-quick-prev-results) (calc-said-hello, calc-executing-macro, calc-any-selections) (calc-help-phase, calc-full-help-flag, calc-refresh-count) (calc-display-dirty, calc-prepared-composition) (calc-selection-cache-default-entry, calc-embedded-info) (calc-embedded-active, calc-standalone-flag, var-EvalRules) (math-eval-rules-cache-tag, math-radix-explicit-format) (math-expr-function-mapping, math-expr-variable-mapping) (math-read-expr-quotes, math-working-step, math-working-step-2) (var-i, var-pi, var-e, var-phi, var-gamma, var-Modes): Make into defvars, from toplevel setq. (calc-mode-map): Set up keymap in more modern fashion. (calc-dispatch-map): Ditto. (calc-command-flags, calc-final-point-line) (calc-final-point-column): Defvar. (calc-do): Use `save-current-buffer' instead of `save-excursion'. (sel-mode): Defvar. (calc-any-evaltos): Ditto. (calc-buffer, calc-prev-char, calc-prev-prev-char) (calc-digit-value): Ditto. (math-eval-rules-cache, math-eval-rules-cache-other): Ditto. (math-sub-bignum): Bind `diff'. (calc-selection-cache-entry): Defvar. (calc-count-lines): Reference `pos' instead of `newpos'.

;;; mm-view.el --- functions for viewing MIME objects
;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.

;; Author: Lars Magne Ingebrigtsen <[e-mail]>
;; 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)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.	 See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(eval-when-compile (require 'cl))
(require 'mail-parse)
(require 'mailcap)
(require 'mm-bodies)
(require 'mm-decode)

(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")
  (unless (fboundp 'diff-mode)
    (autoload 'diff-mode "diff-mode" "" t nil)))

;;;
;;; Functions for displaying various formats inline
;;;
(defun mm-inline-image-emacs (handle)
  (let ((b (point-marker))
	buffer-read-only)
    (insert "\n")
    (put-image (mm-get-image handle) b)
    (mm-handle-set-undisplayer
     handle
     `(lambda () (remove-images ,b (1+ ,b))))))

(defun mm-inline-image-xemacs (handle)
  (insert "\n")
  (forward-char -1)
  (let ((b (point))
	(annot (make-annotation (mm-get-image handle) nil 'text))
	buffer-read-only)
    (mm-handle-set-undisplayer
     handle
     `(lambda ()
	(let (buffer-read-only)
	  (delete-annotation ,annot)
	  (delete-region ,(set-marker (make-marker) b)
			 ,(set-marker (make-marker) (point))))))
    (set-extent-property annot 'mm t)
    (set-extent-property annot 'duplicable t)))

(eval-and-compile
  (if (featurep 'xemacs)
      (defalias 'mm-inline-image 'mm-inline-image-xemacs)
    (defalias 'mm-inline-image 'mm-inline-image-emacs)))

(defvar mm-w3-setup nil)
(defun mm-setup-w3 ()
  (unless mm-w3-setup
    (require 'w3)
    (w3-do-setup)
    (require 'url)
    (require 'w3-vars)
    (require 'url-vars)
    (setq mm-w3-setup t)))

(defun mm-inline-text (handle)
  (let ((type (mm-handle-media-subtype handle))
	text buffer-read-only)
    (cond
     ((equal type "html")
      (mm-setup-w3)
      (setq text (mm-get-part handle))
      (let ((b (point))
	    (url-standalone-mode t)
	    (url-gateway-unplugged t)
	    (url-current-object
	     (url-generic-parse-url (format "cid:%s" (mm-handle-id handle))))
	    (width (window-width))
	    (charset (mail-content-type-get
		      (mm-handle-type handle) 'charset)))
	(save-excursion
	  (insert text)
	  (save-restriction
	    (narrow-to-region b (point))
	    (goto-char (point-min))
	    (if (or (and (boundp 'w3-meta-content-type-charset-regexp)
			 (re-search-forward
			  w3-meta-content-type-charset-regexp nil t))
		    (and (boundp 'w3-meta-charset-content-type-regexp)
			 (re-search-forward
			  w3-meta-charset-content-type-regexp nil t)))
		(setq charset
		      (or (let ((bsubstr (buffer-substring-no-properties
					  (match-beginning 2)
					  (match-end 2))))
			    (if (fboundp 'w3-coding-system-for-mime-charset)
				(w3-coding-system-for-mime-charset bsubstr)
			      (mm-charset-to-coding-system bsubstr)))
			  charset)))
	    (delete-region (point-min) (point-max))
	    (insert (mm-decode-string text charset))
	    (save-window-excursion
	      (save-restriction
		(let ((w3-strict-width width)
		      ;; Don't let w3 set the global version of
		      ;; this variable.
		      (fill-column fill-column))
		  (condition-case var
		      (w3-region (point-min) (point-max))
		    (error
		     (delete-region (point-min) (point-max))
		     (let ((b (point))
			   (charset (mail-content-type-get
				     (mm-handle-type handle) 'charset)))
		       (if (or (eq charset 'gnus-decoded)
			       (eq mail-parse-charset 'gnus-decoded))
			   (save-restriction
			     (narrow-to-region (point) (point))
			     (mm-insert-part handle)
			     (goto-char (point-max)))
			 (insert (mm-decode-string (mm-get-part handle)
						   charset))))
		     (message
		      "Error while rendering html; showing as text/plain"))))))
	    (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)))
		  (delete-region ,(point-min-marker)
				 ,(point-max-marker)))))))))
     ((equal type "x-vcard")
      (mm-insert-inline
       handle
       (concat "\n-- \n"
	       (ignore-errors
		 (if (fboundp 'vcard-pretty-print)
		     (vcard-pretty-print (mm-get-part handle))
		   (vcard-format-string
		    (vcard-parse-string (mm-get-part handle)
					'vcard-standard-filter)))))))
     (t
      (let ((b (point))
	    (charset (mail-content-type-get
		      (mm-handle-type handle) 'charset)))
	(if (or (eq charset 'gnus-decoded)
		;; This is probably not entirely correct, but
		;; makes rfc822 parts with embedded multiparts work.
		(eq mail-parse-charset 'gnus-decoded))
	    (save-restriction
	      (narrow-to-region (point) (point))
	      (mm-insert-part handle)
	      (goto-char (point-max)))
	  (insert (mm-decode-string (mm-get-part handle) charset)))
	(when (and (equal type "plain")
		   (equal (cdr (assoc 'format (mm-handle-type handle)))
			  "flowed"))
	  (save-restriction
	    (narrow-to-region b (point))
	    (goto-char b)
	    (fill-flowed)
	    (goto-char (point-max))))
	(save-restriction
	  (narrow-to-region b (point))
	  (set-text-properties (point-min) (point-max) nil)
	  (when (or (equal type "enriched")
		    (equal type "richtext"))
	    (enriched-decode (point-min) (point-max)))
	  (mm-handle-set-undisplayer
	   handle
	   `(lambda ()
	      (let (buffer-read-only)
		(delete-region ,(point-min-marker)
			       ,(point-max-marker)))))))))))

(defun mm-insert-inline (handle text)
  "Insert TEXT inline from HANDLE."
  (let ((b (point)))
    (insert text)
    (mm-handle-set-undisplayer
     handle
     `(lambda ()
	(let (buffer-read-only)
	  (delete-region ,(set-marker (make-marker) b)
			 ,(set-marker (make-marker) (point))))))))

(defun mm-inline-audio (handle)
  (message "Not implemented"))

(defun mm-view-sound-file ()
  (message "Not implemented"))

(defun mm-w3-prepare-buffer ()
  (require 'w3)
  (let ((url-standalone-mode t)
	(url-gateway-unplugged t))
    (w3-prepare-buffer)))

(defun mm-view-message ()
  (mm-enable-multibyte)
  (let (handles)
    (let (gnus-article-mime-handles)
      ;; Double decode problem may happen.  See mm-inline-message.
      (run-hooks 'gnus-article-decode-hook)
      (gnus-article-prepare-display)
      (setq handles gnus-article-mime-handles))
    (when handles
      (setq gnus-article-mime-handles
	    (nconc gnus-article-mime-handles 
		   (if (listp (car handles)) 
		       handles (list handles))))))
  (fundamental-mode)
  (goto-char (point-min)))

(defun mm-inline-message (handle)
  (let ((b (point))
	(bolp (bolp))
	(charset (mail-content-type-get
		  (mm-handle-type handle) 'charset))
	gnus-displaying-mime handles)
    (when (and charset
	       (stringp charset))
      (setq charset (intern (downcase charset)))
      (when (eq charset 'us-ascii)
	(setq charset nil)))
    (save-excursion
      (save-restriction
	(narrow-to-region b b)
	(mm-insert-part handle)
	(let (gnus-article-mime-handles
	      ;; disable prepare hook
	      gnus-article-prepare-hook
	      (gnus-newsgroup-charset
	       (or charset gnus-newsgroup-charset)))
	  (run-hooks 'gnus-article-decode-hook)
	  (gnus-article-prepare-display)
	  (setq handles gnus-article-mime-handles))
	(goto-char (point-min))
	(unless bolp
	  (insert "\n"))
	(goto-char (point-max))
	(unless (bolp)
	  (insert "\n"))
	(insert "----------\n\n")
	(when handles
	  (setq gnus-article-mime-handles
		(nconc gnus-article-mime-handles 
		       (if (listp (car handles)) 
			   handles (list handles)))))
	(mm-handle-set-undisplayer
	 handle
	 `(lambda ()
	    (let (buffer-read-only)
	      (if (fboundp 'remove-specifier)
		  ;; This is only valid on XEmacs.
		  (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-display-inline-fontify (handle mode)
  (let (text)
    (with-temp-buffer
      (mm-insert-part handle)
      (funcall mode)
      (font-lock-fontify-buffer)
      (when (fboundp 'extent-list)
	(map-extents (lambda (ext ignored)
		       (set-extent-property ext 'duplicable t)
		       nil)
		     nil nil nil nil nil 'text-prop))
      (setq text (buffer-string)))
    (mm-insert-inline handle text)))

(defun mm-display-patch-inline (handle)
  (mm-display-inline-fontify handle 'diff-mode))

(defun mm-display-elisp-inline (handle)
  (mm-display-inline-fontify handle 'emacs-lisp-mode))

(provide 'mm-view)

;;; mm-view.el ends here