X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=mime-image.el;h=915fa35601da6af80cdc724fed4747e8d5892b8a;hb=refs%2Fheads%2Fmaster;hp=d5e4aa0f3d3b47d68ccf0211503970ce8ae5810b;hpb=cc0a722ec13e11cd7aa00db6929cb2505d1c9556;p=elisp%2Fsemi.git

diff --git a/mime-image.el b/mime-image.el
index d5e4aa0..915fa35 100644
--- a/mime-image.el
+++ b/mime-image.el
@@ -4,8 +4,9 @@
 ;; Copyright (C) 1996 Dan Rich
 
 ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
-;;         Dan Rich <drich@morpheus.corp.sgi.com>
-;; Maintainer: MORIOKA Tomohiko <morioka@jaist.ac.jp>
+;;	Dan Rich <drich@morpheus.corp.sgi.com>
+;;	Daiki Ueno <ueno@ueda.info.waseda.ac.jp>
+;;	Katsumi Yamaoka  <yamaoka@jpl.org>
 ;; Created: 1995/12/15
 ;;	Renamed: 1997/2/21 from tm-image.el
 
@@ -25,8 +26,8 @@
 
 ;; You should have received a copy of the GNU General Public License
 ;; along with GNU XEmacs; see the file COPYING.  If not, write to the
-;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
+;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
+;; Boston, MA 02110-1301, USA.
 
 ;;; Commentary:
 ;;	If you use this program with MULE, please install
@@ -34,102 +35,153 @@
 
 ;;; Code:
 
-(require 'mime-view)
-(require 'alist)
+(eval-when-compile (require 'cl))
 
-(cond ((featurep 'xemacs)
-       (require 'images)
-       
-       (defun-maybe image-inline-p (format)
-	 (or (memq format image-native-formats)
-	     (find-if (function
-		       (lambda (native)
-			 (image-converter-chain format native)
-			 ))
-		      image-native-formats)
-	     ))
-       
-       (image-register-netpbm-utilities)
-       (image-register-converter 'pic 'ppm "pictoppm")
-       (image-register-converter 'mag 'ppm "magtoppm")
-       
-       (defun bitmap-insert-xbm-file (file)
-	 (let ((gl (make-glyph (list (cons 'x file))))
-	       (e (make-extent (point) (point)))
-	       )
-	   (set-extent-end-glyph e gl)
-	   ))
-       
-       ;;
-       ;; X-Face
-       ;;
-       (autoload 'highlight-headers "highlight-headers")
-       
-       (defun mime-preview-x-face-function-use-highlight-headers ()
-	 (highlight-headers (point-min) (re-search-forward "^$" nil t) t)
-	 )
-       
-       (add-hook 'mime-display-header-hook
-		 'mime-preview-x-face-function-use-highlight-headers)
-       
-       )
-      ((featurep 'mule)
-       ;; for MULE 2.* or mule merged EMACS
-       (require 'x-face-mule)
-
-       (defvar image-native-formats '(xbm))
-       
-       (defun-maybe image-inline-p (format)
-	 (memq format image-native-formats)
-	 )
-       
-       (defun-maybe image-normalize (format data)
-	 (and (eq format 'xbm)
-	      (vector 'xbm ':data data)
-	      ))
-       
-       ;;
-       ;; X-Face
-       ;;
-       (if (exec-installed-p uncompface-program exec-path)
-	   (add-hook 'mime-display-header-hook
-		     'x-face-decode-message-header)
-	 )
-       ))
-
-(or (fboundp 'image-invalid-glyph-p)
-    (defsubst image-invalid-glyph-p (glyph)
-      (or (null (aref glyph 0))
-	  (null (aref glyph 2))
-	  (equal (aref glyph 2) "")
-	  ))
-    )
-
-(mapcar (function
-	 (lambda (rule)
-	   (let ((type    (car rule))
-		 (subtype (nth 1 rule))
-		 (format  (nth 2 rule)))
-	     (if (image-inline-p format)
-		 (ctree-set-calist-strictly
-		  'mime-preview-condition
-		  (list (cons 'type type)(cons 'subtype subtype)
-			'(body . visible)
-			(cons 'body-presentation-method #'mime-display-image)
-			(cons 'image-format format))
-		  )))))
-	'((image jpeg		jpeg)
-	  (image gif		gif)
-	  (image tiff		tiff)
-	  (image x-tiff		tiff)
-	  (image xbm		xbm)
-	  (image x-xbm		xbm)
-	  (image x-xpixmap	xpm)
-	  (image x-pic		pic)
-	  (image x-mag		mag)
-	  (image png		png)
-	  ))
+(eval-when-compile (require 'static))
 
+(require 'mime-view)
+(require 'alist)
+(require 'path-util)
+
+(defsubst mime-image-normalize-xbm-buffer (buffer)
+  (save-excursion
+    (set-buffer buffer)
+    (let ((case-fold-search t) width height xbytes right margin)
+      (goto-char (point-min))
+      (or (re-search-forward "_width[\t ]+\\([0-9]+\\)" nil t)
+	  (error "!! Illegal xbm file format in the buffer: %s"
+		 (current-buffer)))
+      (setq width (string-to-int (match-string 1))
+	    xbytes (/ (+ width 7) 8))
+      (goto-char (point-min))
+      (or (re-search-forward "_height[\t ]+\\([0-9]+\\)" nil t)
+	  (error "!! Illegal xbm file format in the buffer: %s"
+		 (current-buffer)))
+      (setq height (string-to-int (match-string 1)))
+      (goto-char (point-min))
+      (re-search-forward "0x[0-9a-f][0-9a-f],")
+      (delete-region (point-min) (match-beginning 0))
+      (goto-char (point-min))
+      (while (re-search-forward "[\n\r\t ,;}]" nil t)
+	(replace-match ""))
+      (goto-char (point-min))
+      (while (re-search-forward "0x" nil t)
+	(replace-match "\\x" nil t))
+      (goto-char (point-min))
+      (insert "(" (number-to-string width) " "
+	      (number-to-string height) " \"")
+      (goto-char (point-max))
+      (insert "\")")
+      (goto-char (point-min))
+      (read (current-buffer)))))
+
+(static-if (featurep 'xemacs)
+    (progn
+      (defun mime-image-type-available-p (type)
+	(memq type (image-instantiator-format-list)))
+
+      (defun mime-image-create (file-or-data &optional type data-p &rest props)
+	(when (and data-p (eq type 'xbm))
+	  (with-temp-buffer
+	    (insert file-or-data)
+	    (setq file-or-data
+		  (mime-image-normalize-xbm-buffer (current-buffer)))))
+	(let ((glyph
+	       (make-glyph
+		(if (and type (mime-image-type-available-p type))
+		    (vconcat
+		     (list type (if data-p :data :file) file-or-data)
+		     props)
+		  file-or-data))))
+	  (if (nothing-image-instance-p (glyph-image-instance glyph)) nil
+	    glyph)))
+
+      (defun mime-image-insert (image &optional string area)
+	(let ((extent (make-extent (point)
+				   (progn (and string
+					       (insert string))
+					  (point)))))
+	  (set-extent-property extent 'invisible t)
+	  (set-extent-end-glyph extent image))))
+  (condition-case nil
+      (progn
+	(require 'image)
+	(defalias 'mime-image-type-available-p 'image-type-available-p)
+	(defun mime-image-create
+	  (file-or-data &optional type data-p &rest props)
+	  (if (and data-p (eq type 'xbm))
+	      (with-temp-buffer
+		(insert file-or-data)
+		(setq file-or-data
+		      (mime-image-normalize-xbm-buffer (current-buffer)))
+		(apply #'create-image (nth 2 file-or-data) type data-p
+		       (nconc
+			(list :width (car file-or-data)
+			      :height (nth 1 file-or-data))
+			props)))
+	    (apply #'create-image file-or-data type data-p props)))
+	(defalias 'mime-image-insert 'insert-image))
+    (error
+     (condition-case nil
+	 (progn
+	   (require (if (featurep 'mule) 'bitmap ""))
+	   (defun mime-image-read-xbm-buffer (buffer)
+	     (condition-case nil
+		 (mapconcat #'bitmap-compose
+			    (append (bitmap-decode-xbm
+				     (bitmap-read-xbm-buffer
+				      (current-buffer))) nil) "\n")
+	       (error nil)))
+	   (defun mime-image-insert (image &optional string area)
+	     (insert image)))
+       (error
+	(defalias 'mime-image-read-xbm-buffer
+	  'mime-image-normalize-xbm-buffer)
+	(defun mime-image-insert (image &optional string area)
+	  (save-restriction
+	    (narrow-to-region (point)(point))
+	    (let ((face (gensym "mii")))
+	      (or (facep face) (make-face face))
+	      (set-face-stipple face image)
+	      (let ((row (make-string (/ (car image)  (frame-char-width)) ? ))
+		  (height (/ (nth 1 image)  (frame-char-height)))
+		  (i 0))
+		(while (< i height)
+		  (set-text-properties (point) (progn (insert row)(point))
+				       (list 'face face))
+		  (insert "\n")
+		  (setq i (1+ i)))))))))
+
+     (defun mime-image-type-available-p (type)
+       (eq type 'xbm))
+
+     (defun mime-image-create (file-or-data &optional type data-p &rest props)
+       (when (or (null type) (eq type 'xbm))
+	 (with-temp-buffer
+	   (if data-p
+	       (insert file-or-data)
+	     (insert-file-contents file-or-data))
+	   (mime-image-read-xbm-buffer (current-buffer))))))))
+
+(defvar mime-image-format-alist
+  '((image jpeg		jpeg)
+    (image gif		gif)
+    (image tiff		tiff)
+    (image x-tiff	tiff)
+    (image xbm		xbm)
+    (image x-xbm	xbm)
+    (image x-xpixmap	xpm)
+    (image png		png)))
+
+(dolist (rule mime-image-format-alist)
+  (when (mime-image-type-available-p (nth 2 rule))
+    (ctree-set-calist-strictly
+     'mime-preview-condition
+     (list (cons 'type (car rule))(cons 'subtype (nth 1 rule))
+	   '(body . visible)
+	   (cons 'body-presentation-method #'mime-display-image)
+	   (cons 'image-format (nth 2 rule))))))
+    
 
 ;;; @ content filter for images
 ;;;
@@ -137,36 +189,19 @@
 
 (defun mime-display-image (entity situation)
   (message "Decoding image...")
-  (let ((gl (image-normalize (cdr (assq 'image-format situation))
-			     (mime-entity-content entity))))
-    (cond ((image-invalid-glyph-p gl)
-	   (setq gl nil)
-	   (message "Invalid glyph!")
-	   )
-	  ((eq (aref gl 0) 'xbm)
-	   (let ((xbm-file
-		  (make-temp-name
-		   (expand-file-name "tm" temporary-file-directory))))
-	     (with-temp-buffer
-	       (insert (aref gl 2))
-	       (write-region (point-min)(point-max) xbm-file)
-	       )
-	     (message "Decoding image...")
-	     (bitmap-insert-xbm-file xbm-file)
-	     (delete-file xbm-file)
-	     )
-	   (message "Decoding image... done")
-	   )
-	  (t
-	   (setq gl (make-glyph gl))
-	   (let ((e (make-extent (point) (point))))
-	     (set-extent-end-glyph e gl)
-	     )
-	   (message "Decoding image... done")
-	   ))
-    )
-  (insert "\n")
-  )
+  (condition-case err
+      (let ((format (cdr (assq 'image-format situation)))
+	    image)
+	(setq image
+	      (mime-image-create (mime-entity-content entity)
+				 format 'data))
+	(if (null image)
+	    (message "Invalid glyph!")
+	  (save-excursion
+	    (mime-image-insert image)
+	    (insert "\n")
+	    (message "Decoding image...done"))))
+    (error nil err)))
 
 
 ;;; @ end