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

;;; mm-view.el --- Functions for viewing MIME objects
;; Copyright (C) 1998, 1999, 2000 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")
  (autoload 'diff-mode "diff-mode"))

;;;
;;; 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)
  (let ((b (point))
	(annot (make-annotation (mm-get-image handle) nil 'text))
	buffer-read-only)
    (insert "\n")
    (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-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 (w3-coding-system-for-mime-charset 
				   (buffer-substring-no-properties 
				    (match-beginning 2) 
				    (match-end 2)))
				  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)
		      (url-standalone-mode t))
		  (condition-case var
		      (w3-region (point-min) (point-max))
		    (error)))))
	    (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)))))))))
     ((or (equal type "enriched")
	  (equal type "richtext"))
      (save-excursion
	(mm-with-unibyte-buffer
	  (mm-insert-part handle)
	  (save-window-excursion
	    (enriched-decode (point-min) (point-max))
	    (setq text (buffer-string)))))
      (mm-insert-inline handle text))
     ((equal type "x-vcard")
      (mm-insert-inline
       handle
       (concat "\n-- \n"
	       (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))
	    (mm-insert-part handle)
	  (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)
	  (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))
    (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))
	(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-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
Commit	Line	Data
c113de23 GM	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
722a8409	67	(if (featurep 'xemacs)
c113de23 GM	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)
722a8409	254	(if (fboundp 'remove-specifier)
c113de23 GM	255	;; This is only valid on XEmacs.
	256	(mapcar (lambda (prop)
	257	(remove-specifier
	258	(face-property 'default prop) (current-buffer)))
722a8409	259	'(background background-pixmap foreground)))
c113de23 GM	260	(delete-region ,(point-min-marker) ,(point-max-marker)))))))))
c113de23 GM	261
ce9401f3	262	(defun mm-display-inline-fontify (handle mode)
c113de23 GM	263	(let (text)
	264	(with-temp-buffer
	265	(mm-insert-part handle)
ce9401f3	266	(funcall mode)
c113de23 GM	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
ce9401f3 DL	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
c113de23 GM	282	(provide 'mm-view)
	283
	284	;; mm-view.el ends here