[bpt/emacs.git] / lisp / gnus / mm-view.el

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

;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
;; 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)

;;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2
;;; mm-view.el ends here
Commit	Line	Data
715a2ca2	1	;;; mm-view.el --- functions for viewing MIME objects
39e72e55	2	;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
c113de23 GM	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")
39e72e55 GM	37	(unless (fboundp 'diff-mode)
39e72e55 GM	38	(autoload 'diff-mode "diff-mode" "" t nil)))
c113de23 GM	39
	40	;;;
	41	;;; Functions for displaying various formats inline
	42	;;;
	43	(defun mm-inline-image-emacs (handle)
	44	(let ((b (point-marker))
	45	buffer-read-only)
	46	(insert "\n")
	47	(put-image (mm-get-image handle) b)
	48	(mm-handle-set-undisplayer
	49	handle
	50	`(lambda () (remove-images ,b (1+ ,b))))))
	51
	52	(defun mm-inline-image-xemacs (handle)
4e728580 SZ	53	(insert "\n")
4e728580 SZ	54	(forward-char -1)
c113de23 GM	55	(let ((b (point))
	56	(annot (make-annotation (mm-get-image handle) nil 'text))
	57	buffer-read-only)
c113de23 GM	58	(mm-handle-set-undisplayer
	59	handle
	60	`(lambda ()
	61	(let (buffer-read-only)
	62	(delete-annotation ,annot)
	63	(delete-region ,(set-marker (make-marker) b)
	64	,(set-marker (make-marker) (point))))))
	65	(set-extent-property annot 'mm t)
	66	(set-extent-property annot 'duplicable t)))
	67
	68	(eval-and-compile
722a8409	69	(if (featurep 'xemacs)
c113de23 GM	70	(defalias 'mm-inline-image 'mm-inline-image-xemacs)
	71	(defalias 'mm-inline-image 'mm-inline-image-emacs)))
	72
	73	(defvar mm-w3-setup nil)
	74	(defun mm-setup-w3 ()
	75	(unless mm-w3-setup
	76	(require 'w3)
	77	(w3-do-setup)
	78	(require 'url)
	79	(require 'w3-vars)
	80	(require 'url-vars)
	81	(setq mm-w3-setup t)))
	82
	83	(defun mm-inline-text (handle)
	84	(let ((type (mm-handle-media-subtype handle))
	85	text buffer-read-only)
	86	(cond
	87	((equal type "html")
	88	(mm-setup-w3)
	89	(setq text (mm-get-part handle))
	90	(let ((b (point))
	91	(url-standalone-mode t)
6833e8ba	92	(url-gateway-unplugged t)
c113de23 GM	93	(url-current-object
	94	(url-generic-parse-url (format "cid:%s" (mm-handle-id handle))))
	95	(width (window-width))
	96	(charset (mail-content-type-get
	97	(mm-handle-type handle) 'charset)))
	98	(save-excursion
	99	(insert text)
	100	(save-restriction
	101	(narrow-to-region b (point))
	102	(goto-char (point-min))
	103	(if (or (and (boundp 'w3-meta-content-type-charset-regexp)
	104	(re-search-forward
	105	w3-meta-content-type-charset-regexp nil t))
	106	(and (boundp 'w3-meta-charset-content-type-regexp)
	107	(re-search-forward
	108	w3-meta-charset-content-type-regexp nil t)))
4e728580 SZ	109	(setq charset
	110	(or (let ((bsubstr (buffer-substring-no-properties
	111	(match-beginning 2)
	112	(match-end 2))))
	113	(if (fboundp 'w3-coding-system-for-mime-charset)
	114	(w3-coding-system-for-mime-charset bsubstr)
	115	(mm-charset-to-coding-system bsubstr)))
	116	charset)))
c113de23 GM	117	(delete-region (point-min) (point-max))
	118	(insert (mm-decode-string text charset))
	119	(save-window-excursion
	120	(save-restriction
	121	(let ((w3-strict-width width)
	122	;; Don't let w3 set the global version of
	123	;; this variable.
6833e8ba	124	(fill-column fill-column))
c113de23 GM	125	(condition-case var
c113de23 GM	126	(w3-region (point-min) (point-max))
4e728580 SZ	127	(error
	128	(delete-region (point-min) (point-max))
	129	(let ((b (point))
	130	(charset (mail-content-type-get
	131	(mm-handle-type handle) 'charset)))
	132	(if (or (eq charset 'gnus-decoded)
	133	(eq mail-parse-charset 'gnus-decoded))
	134	(save-restriction
	135	(narrow-to-region (point) (point))
	136	(mm-insert-part handle)
	137	(goto-char (point-max)))
	138	(insert (mm-decode-string (mm-get-part handle)
	139	charset))))
	140	(message
	141	"Error while rendering html; showing as text/plain"))))))
c113de23 GM	142	(mm-handle-set-undisplayer
	143	handle
	144	`(lambda ()
	145	(let (buffer-read-only)
	146	(if (functionp 'remove-specifier)
	147	(mapcar (lambda (prop)
	148	(remove-specifier
	149	(face-property 'default prop)
	150	(current-buffer)))
	151	'(background background-pixmap foreground)))
	152	(delete-region ,(point-min-marker)
	153	,(point-max-marker)))))))))
c113de23 GM	154	((equal type "x-vcard")
	155	(mm-insert-inline
	156	handle
	157	(concat "\n-- \n"
4e728580 SZ	158	(ignore-errors
	159	(if (fboundp 'vcard-pretty-print)
	160	(vcard-pretty-print (mm-get-part handle))
	161	(vcard-format-string
	162	(vcard-parse-string (mm-get-part handle)
	163	'vcard-standard-filter)))))))
c113de23 GM	164	(t
	165	(let ((b (point))
	166	(charset (mail-content-type-get
	167	(mm-handle-type handle) 'charset)))
	168	(if (or (eq charset 'gnus-decoded)
	169	;; This is probably not entirely correct, but
4e728580	170	;; makes rfc822 parts with embedded multiparts work.
c113de23	171	(eq mail-parse-charset 'gnus-decoded))
4e728580 SZ	172	(save-restriction
	173	(narrow-to-region (point) (point))
	174	(mm-insert-part handle)
	175	(goto-char (point-max)))
c113de23 GM	176	(insert (mm-decode-string (mm-get-part handle) charset)))
	177	(when (and (equal type "plain")
	178	(equal (cdr (assoc 'format (mm-handle-type handle)))
	179	"flowed"))
	180	(save-restriction
	181	(narrow-to-region b (point))
	182	(goto-char b)
	183	(fill-flowed)
	184	(goto-char (point-max))))
	185	(save-restriction
	186	(narrow-to-region b (point))
	187	(set-text-properties (point-min) (point-max) nil)
4e728580 SZ	188	(when (or (equal type "enriched")
	189	(equal type "richtext"))
	190	(enriched-decode (point-min) (point-max)))
c113de23 GM	191	(mm-handle-set-undisplayer
	192	handle
	193	`(lambda ()
	194	(let (buffer-read-only)
	195	(delete-region ,(point-min-marker)
	196	,(point-max-marker)))))))))))
	197
	198	(defun mm-insert-inline (handle text)
	199	"Insert TEXT inline from HANDLE."
	200	(let ((b (point)))
	201	(insert text)
	202	(mm-handle-set-undisplayer
	203	handle
	204	`(lambda ()
	205	(let (buffer-read-only)
	206	(delete-region ,(set-marker (make-marker) b)
	207	,(set-marker (make-marker) (point))))))))
	208
	209	(defun mm-inline-audio (handle)
	210	(message "Not implemented"))
	211
	212	(defun mm-view-sound-file ()
	213	(message "Not implemented"))
	214
	215	(defun mm-w3-prepare-buffer ()
	216	(require 'w3)
6833e8ba SZ	217	(let ((url-standalone-mode t)
6833e8ba SZ	218	(url-gateway-unplugged t))
c113de23 GM	219	(w3-prepare-buffer)))
	220
	221	(defun mm-view-message ()
	222	(mm-enable-multibyte)
	223	(let (handles)
	224	(let (gnus-article-mime-handles)
	225	;; Double decode problem may happen. See mm-inline-message.
	226	(run-hooks 'gnus-article-decode-hook)
	227	(gnus-article-prepare-display)
	228	(setq handles gnus-article-mime-handles))
	229	(when handles
	230	(setq gnus-article-mime-handles
a1506d29 JB	231	(nconc gnus-article-mime-handles
a1506d29 JB	232	(if (listp (car handles))
c113de23 GM	233	handles (list handles))))))
	234	(fundamental-mode)
	235	(goto-char (point-min)))
	236
	237	(defun mm-inline-message (handle)
	238	(let ((b (point))
4e728580	239	(bolp (bolp))
c113de23 GM	240	(charset (mail-content-type-get
	241	(mm-handle-type handle) 'charset))
	242	gnus-displaying-mime handles)
	243	(when (and charset
	244	(stringp charset))
	245	(setq charset (intern (downcase charset)))
	246	(when (eq charset 'us-ascii)
	247	(setq charset nil)))
	248	(save-excursion
	249	(save-restriction
	250	(narrow-to-region b b)
	251	(mm-insert-part handle)
	252	(let (gnus-article-mime-handles
4e728580 SZ	253	;; disable prepare hook
4e728580 SZ	254	gnus-article-prepare-hook
c113de23 GM	255	(gnus-newsgroup-charset
	256	(or charset gnus-newsgroup-charset)))
	257	(run-hooks 'gnus-article-decode-hook)
	258	(gnus-article-prepare-display)
	259	(setq handles gnus-article-mime-handles))
4e728580 SZ	260	(goto-char (point-min))
	261	(unless bolp
	262	(insert "\n"))
c113de23 GM	263	(goto-char (point-max))
	264	(unless (bolp)
	265	(insert "\n"))
	266	(insert "----------\n\n")
	267	(when handles
	268	(setq gnus-article-mime-handles
a1506d29 JB	269	(nconc gnus-article-mime-handles
a1506d29 JB	270	(if (listp (car handles))
c113de23 GM	271	handles (list handles)))))
	272	(mm-handle-set-undisplayer
	273	handle
	274	`(lambda ()
	275	(let (buffer-read-only)
722a8409	276	(if (fboundp 'remove-specifier)
c113de23 GM	277	;; This is only valid on XEmacs.
	278	(mapcar (lambda (prop)
	279	(remove-specifier
	280	(face-property 'default prop) (current-buffer)))
722a8409	281	'(background background-pixmap foreground)))
c113de23 GM	282	(delete-region ,(point-min-marker) ,(point-max-marker)))))))))
c113de23 GM	283
ce9401f3	284	(defun mm-display-inline-fontify (handle mode)
c113de23 GM	285	(let (text)
	286	(with-temp-buffer
	287	(mm-insert-part handle)
ce9401f3	288	(funcall mode)
c113de23 GM	289	(font-lock-fontify-buffer)
	290	(when (fboundp 'extent-list)
	291	(map-extents (lambda (ext ignored)
	292	(set-extent-property ext 'duplicable t)
	293	nil)
	294	nil nil nil nil nil 'text-prop))
	295	(setq text (buffer-string)))
	296	(mm-insert-inline handle text)))
	297
ce9401f3 DL	298	(defun mm-display-patch-inline (handle)
	299	(mm-display-inline-fontify handle 'diff-mode))
	300
	301	(defun mm-display-elisp-inline (handle)
	302	(mm-display-inline-fontify handle 'emacs-lisp-mode))
	303
c113de23 GM	304	(provide 'mm-view)
c113de23 GM	305
ab5796a9	306	;;; arch-tag: b60e749a-d05c-47f2-bccd-bdaa59327cb2
715a2ca2	307	;;; mm-view.el ends here