X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fmm-decode.el;h=6e8413ead0c99eb0bf9cb7162eeeb17c764507d9;hb=dc7a23b64c97173277fb5565e73924aaff57956e;hp=07b85ec706553ab5c4fb91eec22c772057211436;hpb=a67202d3efa5620f9e737e3037153035938f382d;p=gnus

diff --git a/lisp/mm-decode.el b/lisp/mm-decode.el
index 07b85ec70..6e8413ead 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>
@@ -27,6 +27,16 @@
 (require 'mail-parse)
 (require '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)
 
 ;;; Convenience macros.
 
@@ -64,7 +74,7 @@
   `(list ,buffer ,type ,encoding ,undisplayer
 	 ,disposition ,description ,cache ,id))
 
-(defvar mm-inline-media-tests
+(defcustom mm-inline-media-tests
   '(("image/jpeg"
      mm-inline-image
      (lambda (handle)
@@ -114,9 +124,11 @@
     ("text/x-vcard"
      mm-inline-text
      (lambda (handle)
-       (locate-library "vcard")))
+       (or (featurep 'vcard)
+	   (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)
@@ -131,41 +143,55 @@
     ("multipart/alternative" ignore identity)
     ("multipart/mixed" ignore identity)
     ("multipart/related" ignore identity))
-  "Alist of media types/test that say whether the media types can be displayed inline.")
+  "Alist of media types/tests saying whether types can be displayed inline."
+  :type '(repeat (list (string :tag "MIME type")
+		       (function :tag "Display function")
+		       (function :tag "Display test")))
+  :group 'mime-display)
 
-(defvar mm-inlined-types
+(defcustom mm-inlined-types
   '("image/.*" "text/.*" "message/delivery-status" "message/rfc822"
+    "message/partial"
     "application/pgp-signature")
-  "List of media types that are to be displayed inline.")
+  "List of media types that are to be displayed inline."
+  :type '(repeat string)
+  :group 'mime-display)
   
-(defvar mm-automatic-display
+(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")
-  "A list of MIME types to be displayed automatically.")
-
-(defvar mm-attachment-override-types '("text/x-vcard")
-  "Types that should have \"attachment\" ignored if they can be displayed inline.")
-
-(defvar mm-inline-override-types nil
-  "Types that should be treated as attachments even if they can be displayed inline.")
-
-(defvar mm-inline-override-types nil
-  "Types that should be treated as attachments even if they can be displayed inline.")
-
-(defvar mm-automatic-external-display nil
-  "List of MIME type regexps that will be displayed externally automatically.")
-
-(defvar mm-discouraged-alternatives nil
+  "A list of MIME types to be displayed automatically."
+  :type '(repeat string)
+  :group 'mime-display)
+
+(defcustom mm-attachment-override-types '("text/x-vcard")
+  "Types to have \"attachment\" ignored if they can be displayed inline."
+  :type '(repeat string)
+  :group 'mime-display)
+
+(defcustom mm-inline-override-types nil
+  "Types to be treated as attachments even if they can be displayed inline."
+  :type '(repeat string)
+  :group 'mime-display)
+
+(defcustom mm-automatic-external-display nil
+  "List of MIME type regexps that will be displayed externally automatically."
+  :type '(repeat string)
+  :group 'mime-display)
+
+(defcustom mm-discouraged-alternatives nil
   "List of MIME types that are discouraged when viewing multipart/alternative.
 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:
 
- (\"text/html\" \"text/richtext\")")
+ (\"text/html\" \"text/richtext\")"
+  :type '(repeat string)
+  :group 'mime-display)
 
 (defvar mm-tmp-directory
   (cond ((fboundp 'temp-directory) (temp-directory))
@@ -173,8 +199,10 @@ to:
 	("/tmp/"))
   "Where mm will store its temporary files.")
 
-(defvar mm-inline-large-images nil
-  "If non-nil, then all images fit in the buffer.")
+(defcustom mm-inline-large-images nil
+  "If non-nil, then all images fit in the buffer."
+  :type 'boolean
+  :group 'mime-display)
 
 ;;; Internal variables.
 
@@ -198,10 +226,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") 
+	   '("text/plain")
 	   (and cte (intern (downcase (mail-header-remove-whitespace
 				       (mail-header-remove-comments
 					cte)))))
@@ -233,7 +263,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)
@@ -248,13 +280,13 @@ to:
 (defun mm-dissect-multipart (ctl)
   (goto-char (point-min))
   (let* ((boundary (concat "\n--" (mail-content-type-get ctl 'boundary)))
-	(close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
-	start parts
-	(end (save-excursion
-	       (goto-char (point-max))
-	       (if (re-search-backward close-delimiter nil t)
-		   (match-beginning 0)
-		 (point-max)))))
+	 (close-delimiter (concat (regexp-quote boundary) "--[ \t]*$"))
+	 start parts
+	 (end (save-excursion
+		(goto-char (point-max))
+		(if (re-search-backward close-delimiter nil t)
+		    (match-beginning 0)
+		  (point-max)))))
     (while (search-forward boundary end t)
       (goto-char (match-beginning 0))
       (when start
@@ -307,108 +339,136 @@ external if displayed external."
 		  (mm-insert-inline handle (mm-get-part handle))
 		  'inline)
 	      (mm-display-external
-	       handle (or method 'mailcap-save-binary-file))
-	      'external)))))))
+	       handle (or method 'mailcap-save-binary-file)))))))))
 
 (defun mm-display-external (handle method)
   "Display HANDLE using METHOD."
-  (mm-with-unibyte-buffer
-    (if (functionp method)
-	(let ((cur (current-buffer)))
-	  (if (eq method 'mailcap-save-binary-file)
-	      (progn
-		(set-buffer (generate-new-buffer "*mm*"))
-		(setq method nil))
-	    (mm-insert-part handle)
-	    (let ((win (get-buffer-window cur t)))
-	      (when win
-		(select-window win)))
-	    (switch-to-buffer (generate-new-buffer "*mm*")))
-	  (buffer-disable-undo)
-	  (mm-set-buffer-file-coding-system mm-binary-coding-system)
-	  (insert-buffer-substring cur)
+  (let ((outbuf (current-buffer)))
+    (mm-with-unibyte-buffer
+      (if (functionp method)
+	  (let ((cur (current-buffer)))
+	    (if (eq method 'mailcap-save-binary-file)
+		(progn
+		  (set-buffer (generate-new-buffer "*mm*"))
+		  (setq method nil))
+	      (mm-insert-part handle)
+	      (let ((win (get-buffer-window cur t)))
+		(when win
+		  (select-window win)))
+	      (switch-to-buffer (generate-new-buffer "*mm*")))
+	    (buffer-disable-undo)
+	    (mm-set-buffer-file-coding-system mm-binary-coding-system)
+	    (insert-buffer-substring cur)
+	    (message "Viewing with %s" method)
+	    (let ((mm (current-buffer))
+		  (non-viewer (assq 'non-viewer
+				    (mailcap-mime-info
+				     (mm-handle-media-type handle) t))))
+	      (unwind-protect
+		  (if method
+		      (funcall method)
+		    (mm-save-part handle))
+		(when (and (not non-viewer)
+			   method)
+		  (mm-handle-set-undisplayer handle mm)))))
+	;; The function is a string to be executed.
+	(mm-insert-part handle)
+	(let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
+	       (filename (mail-content-type-get
+			  (mm-handle-disposition handle) 'filename))
+	       (mime-info (mailcap-mime-info
+			   (mm-handle-media-type handle) t))
+	       (needsterm (or (assoc "needsterm" mime-info)
+			      (assoc "needsterminal" mime-info)))
+	       (copiousoutput (assoc "copiousoutput" mime-info))
+	       file buffer)
+	  ;; We create a private sub-directory where we store our files.
+	  (make-directory dir)
+	  (set-file-modes dir 448)
+	  (if filename
+	      (setq file (expand-file-name (file-name-nondirectory filename)
+					   dir))
+	    (setq file (make-temp-name (expand-file-name "mm." dir))))
+	  (let ((coding-system-for-write mm-binary-coding-system))
+	    (write-region (point-min) (point-max) file nil 'nomesg))
 	  (message "Viewing with %s" method)
-	  (let ((mm (current-buffer))
-		(non-viewer (assq 'non-viewer
-				  (mailcap-mime-info
-				   (mm-handle-media-type handle) t))))
-	    (unwind-protect
-		(if method
-		    (funcall method)
-		  (mm-save-part handle))
-	      (when (and (not non-viewer)
-			 method)
-		(mm-handle-set-undisplayer handle mm)))))
-      ;; The function is a string to be executed.
-      (mm-insert-part handle)
-      (let* ((dir (make-temp-name (expand-file-name "emm." mm-tmp-directory)))
-	     (filename (mail-content-type-get
-			(mm-handle-disposition handle) 'filename))
-	     (mime-info (mailcap-mime-info
-			 (mm-handle-media-type handle) t))
-	     (needsterm (or (assoc "needsterm" mime-info)
-			    (assoc "needsterminal" mime-info)))
-	     (copiousoutput (assoc "copiousoutput" mime-info))
-	     process file buffer)
-	;; We create a private sub-directory where we store our files.
-	(make-directory dir)
-	(set-file-modes dir 448)
-	(if filename
-	    (setq file (expand-file-name (file-name-nondirectory filename)
-					 dir))
-	  (setq file (make-temp-name (expand-file-name "mm." dir))))
-	(let ((coding-system-for-write mm-binary-coding-system))
-	  (write-region (point-min) (point-max) file nil 'nomesg))
-	(message "Viewing with %s" method)
-	(unwind-protect
-	    (setq process
-		  (cond (needsterm
-			 (start-process "*display*" nil
-					"xterm"
-					"-e" shell-file-name "-c"
-					(mm-mailcap-command
-					 method file (mm-handle-type handle))))
-			(copiousoutput
-			 (start-process "*display*"
-					(setq buffer 
-					      (generate-new-buffer "*mm*"))
-					shell-file-name
-					"-c"
-					(mm-mailcap-command
-					 method file (mm-handle-type handle)))
-			 (switch-to-buffer buffer))
-			(t
-			 (start-process "*display*"
+	  (cond (needsterm
+		 (unwind-protect
+		     (start-process "*display*" nil
+				    "xterm"
+				    "-e" shell-file-name
+				    shell-command-switch
+				    (mm-mailcap-command
+				     method file (mm-handle-type handle)))
+		   (mm-handle-set-undisplayer handle (cons file buffer)))
+		 (message "Displaying %s..." (format method file))
+		 'external)
+		(copiousoutput
+		 (with-current-buffer outbuf
+		   (forward-line 1)
+		   (mm-insert-inline
+		    handle
+		    (unwind-protect
+			(progn
+			  (call-process shell-file-name nil
 					(setq buffer
 					      (generate-new-buffer "*mm*"))
-					shell-file-name
-					"-c"
+					nil
+					shell-command-switch
 					(mm-mailcap-command
-					 method file (mm-handle-type handle))))))
-	  (mm-handle-set-undisplayer handle (cons file buffer)))
-	(message "Displaying %s..." (format method file))))))
-
+					 method file (mm-handle-type handle)))
+			  (if (buffer-live-p buffer)
+			      (save-excursion
+				(set-buffer buffer)
+				(buffer-string))))
+		      (progn
+			(ignore-errors (delete-file file))
+			(ignore-errors (delete-directory
+					(file-name-directory file)))
+			(ignore-errors (kill-buffer buffer))))))
+		 'inline)
+		(t
+		 (unwind-protect
+		     (start-process "*display*"
+				    (setq buffer
+					  (generate-new-buffer "*mm*"))
+				    shell-file-name
+				    shell-command-switch
+				    (mm-mailcap-command
+				     method file (mm-handle-type handle)))
+		   (mm-handle-set-undisplayer handle (cons file buffer)))
+		 (message "Displaying %s..." (format method file))
+		 '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)
@@ -416,6 +476,7 @@ external if displayed external."
       (while (setq handle (pop handles))
 	(cond
 	 ((stringp handle)
+	  ;; Do nothing.
 	  )
 	 ((and (listp handle)
 	       (stringp (car handle)))
@@ -424,7 +485,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)
@@ -432,6 +493,7 @@ external if displayed external."
       (while (setq handle (pop handles))
 	(cond
 	 ((stringp handle)
+	  ;; Do nothing.
 	  )
 	 ((and (listp handle)
 	       (stringp (car handle)))
@@ -635,6 +697,8 @@ external if displayed external."
 	  (mapcar (lambda (i) (list (cdr (assoc 'viewer i))))
 		  (mailcap-mime-info type 'all)))
 	 (method (completing-read "Viewer: " methods)))
+    (when (string= method "")
+      (error "No method given"))
     (mm-display-external (copy-sequence handle) method)))
 
 (defun mm-preferred-alternative (handles &optional preferred)
@@ -660,9 +724,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))
@@ -692,38 +755,56 @@ 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)))))))
+		      (if (fboundp 'make-glyph)
+			  (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)))))
+			(create-image (buffer-string) (intern type) 'data-p))))
 	    (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's just inline everything under Emacs 21, since the image
+      ;; specification there doesn't actually get the width/height
+      ;; until you render the image.
+      t)))
 
 (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."
@@ -733,4 +814,4 @@ external if displayed external."
 
 (provide 'mm-decode)
 
-;; mm-decode.el ends here
+;;; mm-decode.el ends here