X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=19a79cd3dc0c63b4bef4df980dbfa31c53ea46a5;hb=afe49bba768037615b6d4795edb7b666c26a8360;hp=cc8a4cc4cf60fc70b1248122fe6d302ceabeeb0c;hpb=027a90912122f2cb3e36d82310f32962e3ce2f71;p=elisp%2Fgnus.git-

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index cc8a4cc..19a79cd 100644
--- a/lisp/mm-decode.el
+++ b/lisp/mm-decode.el
@@ -1,5 +1,5 @@
 ;;; mm-decode.el --- Functions for decoding MIME things
-;; Copyright (C) 1998,99 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
 
 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;;	MORIOKA Tomohiko <morioka@jaist.ac.jp>
@@ -25,14 +25,19 @@
 ;;; Code:
 
 (require 'mail-parse)
-(require 'mailcap)
+(require 'gnus-mailcap)
 (require 'mm-bodies)
+(eval-when-compile (require 'cl))
+
+(eval-and-compile
+  (autoload 'mm-inline-partial "mm-partial"))
 
 (defgroup mime-display ()
   "Display of MIME in mail and news articles."
   :link '(custom-manual "(emacs-mime)Customization")
   :group 'mail
-  :group 'news)
+  :group 'news
+  :group 'multimedia)
 
 ;;; Convenience macros.
 
@@ -113,6 +118,7 @@
     ("text/x-patch" mm-display-patch-inline
      (lambda (handle)
        (locate-library "diff-mode")))
+    ("application/emacs-lisp" mm-display-elisp-inline identity)
     ("text/html"
      mm-inline-text
      (lambda (handle)
@@ -124,6 +130,7 @@
 	   (locate-library "vcard"))))
     ("message/delivery-status" mm-inline-text identity)
     ("message/rfc822" mm-inline-message identity)
+    ("message/partial" mm-inline-partial identity)
     ("text/.*" mm-inline-text identity)
     ("audio/wav" mm-inline-audio
      (lambda (handle)
@@ -146,6 +153,7 @@
 
 (defcustom mm-inlined-types
   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
+    "message/partial" "application/emacs-lisp"
     "application/pgp-signature")
   "List of media types that are to be displayed inline."
   :type '(repeat string)
@@ -154,7 +162,8 @@
 (defcustom mm-automatic-display
   '("text/plain" "text/enriched" "text/richtext" "text/html"
     "text/x-vcard" "image/.*" "message/delivery-status" "multipart/.*"
-    "message/rfc822" "text/x-patch" "application/pgp-signature")
+    "message/rfc822" "text/x-patch" "application/pgp-signature" 
+    "application/emacs-lisp")
   "A list of MIME types to be displayed automatically."
   :type '(repeat string)
   :group 'mime-display)
@@ -179,7 +188,7 @@
 Viewing agents are supposed to view the last possible part of a message,
 as that is supposed to be the richest.  However, users may prefer other
 types instead, and this list says what types are most unwanted.  If,
-for instance, text/html parts are very unwanted, and text/richtech are
+for instance, text/html parts are very unwanted, and text/richtext are
 somewhat unwanted, then the value of this variable should be set
 to:
 
@@ -204,6 +213,11 @@ to:
 (defvar mm-last-shell-command "")
 (defvar mm-content-id-alist nil)
 
+;; According to RFC2046, in particular, in a digest, the default
+;; Content-Type value for a body part is changed from "text/plain" to
+;; "message/rfc822".
+(defvar mm-dissect-default-type "text/plain")
+
 ;;; The functions.
 
 (defun mm-dissect-buffer (&optional no-strict-mime)
@@ -220,10 +234,12 @@ to:
 		cd (mail-fetch-field "content-disposition")
 		description (mail-fetch-field "content-description")
 		id (mail-fetch-field "content-id"))))
+      (when cte
+	(setq cte (mail-header-strip cte)))
       (if (or (not ctl)
 	      (not (string-match "/" (car ctl))))
 	  (mm-dissect-singlepart
-	   '("text/plain") 
+	   (list mm-dissect-default-type)
 	   (and cte (intern (downcase (mail-header-remove-whitespace
 				       (mail-header-remove-comments
 					cte)))))
@@ -237,7 +253,10 @@ to:
 	 result
 	 (cond
 	  ((equal type "multipart")
-	   (cons (car ctl) (mm-dissect-multipart ctl)))
+	   (let ((mm-dissect-default-type (if (equal subtype "digest")
+					      "message/rfc822"
+					    "text/plain")))
+	     (cons (car ctl) (mm-dissect-multipart ctl))))
 	  (t
 	   (mm-dissect-singlepart
 	    ctl
@@ -255,7 +274,9 @@ to:
 
 (defun mm-dissect-singlepart (ctl cte &optional force cdl description id)
   (when (or force
-	    (not (equal "text/plain" (car ctl))))
+	    (if (equal "text/plain" (car ctl))
+		(assoc 'format ctl)
+	      t))
     (let ((res (mm-make-handle
 		(mm-copy-to-buffer) ctl cte nil cdl description nil id)))
       (push (car res) mm-dissection-list)
@@ -277,7 +298,8 @@ to:
 		(if (re-search-backward close-delimiter nil t)
 		    (match-beginning 0)
 		  (point-max)))))
-    (while (search-forward boundary end t)
+    (setq boundary (concat (regexp-quote boundary) "[ \t]*$"))
+    (while (re-search-forward boundary end t)
       (goto-char (match-beginning 0))
       (when start
 	(save-excursion
@@ -349,6 +371,7 @@ external if displayed external."
 	    (buffer-disable-undo)
 	    (mm-set-buffer-file-coding-system mm-binary-coding-system)
 	    (insert-buffer-substring cur)
+	    (goto-char (point-min))
 	    (message "Viewing with %s" method)
 	    (let ((mm (current-buffer))
 		  (non-viewer (assq 'non-viewer
@@ -386,7 +409,7 @@ external if displayed external."
 		 (unwind-protect
 		     (start-process "*display*" nil
 				    "xterm"
-				    "-e" shell-file-name 
+				    "-e" shell-file-name
 				    shell-command-switch
 				    (mm-mailcap-command
 				     method file (mm-handle-type handle)))
@@ -401,7 +424,7 @@ external if displayed external."
 		    (unwind-protect
 			(progn
 			  (call-process shell-file-name nil
-					(setq buffer 
+					(setq buffer
 					      (generate-new-buffer "*mm*"))
 					nil
 					shell-command-switch
@@ -433,24 +456,32 @@ external if displayed external."
 (defun mm-mailcap-command (method file type-list)
   (let ((ctl (cdr type-list))
 	(beg 0)
+	(uses-stdin t)
 	out sub total)
-    (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t" method beg)
+    (while (string-match "%{\\([^}]+\\)}\\|%s\\|%t\\|%%" method beg)
       (push (substring method beg (match-beginning 0)) out)
       (setq beg (match-end 0)
 	    total (match-string 0 method)
 	    sub (match-string 1 method))
       (cond
+       ((string= total "%%")
+	(push "%" out))
        ((string= total "%s")
+	(setq uses-stdin nil)
 	(push (mm-quote-arg file) out))
        ((string= total "%t")
 	(push (mm-quote-arg (car type-list)) out))
        (t
 	(push (mm-quote-arg (or (cdr (assq (intern sub) ctl)) "")) out))))
     (push (substring method beg (length method)) out)
+    (if uses-stdin
+	(progn
+	  (push "<" out)
+	  (push (mm-quote-arg file) out)))
     (mapconcat 'identity (nreverse out) "")))
     
 (defun mm-remove-parts (handles)
-  "Remove the displayed MIME parts represented by HANDLE."
+  "Remove the displayed MIME parts represented by HANDLES."
   (if (and (listp handles)
 	   (bufferp (car handles)))
       (mm-remove-part handles)
@@ -467,7 +498,7 @@ external if displayed external."
 	  (mm-remove-part handle)))))))
 
 (defun mm-destroy-parts (handles)
-  "Remove the displayed MIME parts represented by HANDLE."
+  "Remove the displayed MIME parts represented by HANDLES."
   (if (and (listp handles)
 	   (bufferp (car handles)))
       (mm-destroy-part handles)
@@ -614,7 +645,7 @@ external if displayed external."
     (save-excursion
       (if (member (mm-handle-media-supertype handle) '("text" "message"))
 	  (with-temp-buffer
-	    (insert-buffer-substring (mm-handle-buffer handle))
+ 	    (insert-buffer-substring (mm-handle-buffer handle))
 	    (mm-decode-content-transfer-encoding
 	     (mm-handle-encoding handle)
 	     (mm-handle-media-type handle))
@@ -681,6 +712,8 @@ external if displayed external."
 	 (method (completing-read "Viewer: " methods)))
     (when (string= method "")
       (error "No method given"))
+    (if (string-match "^[^% \t]+$" method) 
+	(setq method (concat method " %s")))
     (mm-display-external (copy-sequence handle) method)))
 
 (defun mm-preferred-alternative (handles &optional preferred)
@@ -706,9 +739,8 @@ external if displayed external."
     result))
 
 (defun mm-preferred-alternative-precedence (handles)
-  "Return the precedence based on HANDLES and mm-discouraged-alternatives."
-  (let ((seq (nreverse (mapcar (lambda (h)
-				 (mm-handle-media-type h))
+  "Return the precedence based on HANDLES and `mm-discouraged-alternatives'."
+  (let ((seq (nreverse (mapcar #'mm-handle-media-type
 			       handles))))
     (dolist (disc (reverse mm-discouraged-alternatives))
       (dolist (elem (copy-sequence seq))
@@ -738,38 +770,60 @@ external if displayed external."
 	  (prog1
 	      (setq spec
 		    (ignore-errors
-		      (cond
-		       ((equal type "xbm")
-			;; xbm images require special handling, since
-			;; the only way to create glyphs from these
-			;; (without a ton of work) is to write them
-			;; out to a file, and then create a file
-			;; specifier.
-			(let ((file (make-temp-name
-				     (expand-file-name "emm.xbm"
-						       mm-tmp-directory))))
-			  (unwind-protect
-			      (progn
-				(write-region (point-min) (point-max) file)
-				(make-glyph (list (cons 'x file))))
-			    (ignore-errors
-			      (delete-file file)))))
-		       (t
-			(make-glyph
-			 (vector (intern type) :data (buffer-string)))))))
+		     ;; Avoid testing `make-glyph' since W3 may define
+		     ;; a bogus version of it.
+		      (if (fboundp 'create-image)
+			  (create-image (buffer-string) (intern type) 'data-p)
+			(cond
+			 ((equal type "xbm")
+			  ;; xbm images require special handling, since
+			  ;; the only way to create glyphs from these
+			  ;; (without a ton of work) is to write them
+			  ;; out to a file, and then create a file
+			  ;; specifier.
+			  (let ((file (make-temp-name
+				       (expand-file-name "emm.xbm"
+							 mm-tmp-directory))))
+			    (unwind-protect
+				(progn
+				  (write-region (point-min) (point-max) file)
+				  (make-glyph (list (cons 'x file))))
+			      (ignore-errors
+			       (delete-file file)))))
+			 (t
+			  (make-glyph
+			   (vector (intern type) :data (buffer-string))))))))
 	    (mm-handle-set-cache handle spec))))))
 
 (defun mm-image-fit-p (handle)
   "Say whether the image in HANDLE will fit the current window."
   (let ((image (mm-get-image handle)))
-    (or mm-inline-large-images
-	(and (< (glyph-width image) (window-pixel-width))
-	     (< (glyph-height image) (window-pixel-height))))))
+    (if (fboundp 'glyph-width)
+	;; XEmacs' glyphs can actually tell us about their width, so
+	;; lets be nice and smart about them.
+	(or mm-inline-large-images
+	    (and (< (glyph-width image) (window-pixel-width))
+		 (< (glyph-height image) (window-pixel-height))))
+      (let* ((size (image-size image))
+	     (w (car size))
+	     (h (cdr size)))
+	(or mm-inline-large-images
+	    (and (< h (1- (window-height))) ; Don't include mode line.
+		 (< w (window-width))))))))
 
 (defun mm-valid-image-format-p (format)
   "Say whether FORMAT can be displayed natively by Emacs."
-  (and (fboundp 'valid-image-instantiator-format-p)
-       (valid-image-instantiator-format-p format)))
+  (cond
+   ;; Handle XEmacs
+   ((fboundp 'valid-image-instantiator-format-p)
+    (valid-image-instantiator-format-p format))
+   ;; Handle Emacs 21
+   ((fboundp 'image-type-available-p)
+    (and (display-graphic-p)
+	 (image-type-available-p format)))
+   ;; Nobody else can do images yet.
+   (t
+    nil)))
 
 (defun mm-valid-and-fit-image-p (format handle)
   "Say whether FORMAT can be displayed natively and HANDLE fits the window."
@@ -779,4 +833,4 @@ external if displayed external."
 
 (provide 'mm-decode)
 
-;; mm-decode.el ends here
+;;; mm-decode.el ends here