X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/2b8f2f464dc55199227c9fe15b2ec70a9469d118..ced7ed5611e2a6e60a5ac7a97e165545843d0fa9:/lisp/image.el

diff --git a/lisp/image.el b/lisp/image.el
index 381f02e886..9d656794aa 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -1,6 +1,8 @@
 ;;; image.el --- image API
 
 ;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
 ;; Keywords: multimedia
 
 ;; This file is part of GNU Emacs.
@@ -31,17 +33,43 @@
 
 
 (defconst image-type-regexps
-  '(("^/\\*.*XPM.\\*/" . xpm)
-    ("^P[1-6]" . pbm)
-    ("^GIF8" . gif)
-    ("JFIF" . jpeg)
-    ("^\211PNG\r\n" . png)
-    ("^#define" . xbm)
-    ("^\\(MM\0\\*\\)\\|\\(II\\*\0\\)" . tiff)
-    ("^%!PS" . postscript))
+  '(("\\`/[\t\n\r ]*\\*.*XPM.\\*/" . xpm)
+    ("\\`P[1-6]" . pbm)
+    ("\\`GIF8" . gif)
+    ("\\`\211PNG\r\n" . png)
+    ("\\`[\t\n\r ]*#define" . xbm)
+    ("\\`\\(MM\0\\*\\|II\\*\0\\)" . tiff)
+    ("\\`[\t\n\r ]*%!PS" . postscript)
+    ("\\`\xff\xd8" . (image-jpeg-p . jpeg)))
   "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
 When the first bytes of an image file match REGEXP, it is assumed to
-be of image type IMAGE-TYPE.")
+be of image type IMAGE-TYPE if IMAGE-TYPE is a symbol.  If not a symbol,
+IMAGE-TYPE must be a pair (PREDICATE . TYPE).  PREDICATE is called
+with one argument, a string containing the image data.  If PREDICATE returns
+a non-nil value, TYPE is the image's type.")
+
+
+(defun image-jpeg-p (data)
+  "Value is non-nil if DATA, a string, consists of JFIF image data.
+We accept the tag Exif because that is the same format."
+  (when (string-match "\\`\xff\xd8" data)
+    (catch 'jfif
+      (let ((len (length data)) (i 2))
+	(while (< i len)
+	  (when (/= (aref data i) #xff)
+	    (throw 'jfif nil))
+	  (setq i (1+ i))
+	  (when (>= (+ i 2) len)
+	    (throw 'jfif nil))
+	  (let ((nbytes (+ (lsh (aref data (+ i 1)) 8)
+			   (aref data (+ i 2))))
+		(code (aref data i)))
+	    (when (and (>= code #xe0) (<= code #xef))
+	      ;; APP0 LEN1 LEN2 "JFIF\0"
+	      (throw 'jfif
+		     (string-match "JFIF\\|Exif"
+				   (substring data i (min (+ i nbytes) len)))))
+	    (setq i (+ i 1 nbytes))))))))
 
 
 ;;;###autoload
@@ -54,7 +82,11 @@ be determined."
     (while (and types (null type))
       (let ((regexp (car (car types)))
 	    (image-type (cdr (car types))))
-	(when (string-match regexp data)
+	(when (or (and (symbolp image-type)
+		       (string-match regexp data))
+		  (and (consp image-type)
+		       (funcall (car image-type) data)
+		       (setq image-type (cdr image-type))))
 	  (setq type image-type))
 	(setq types (cdr types))))
     type))
@@ -69,6 +101,7 @@ be determined."
     (setq file (expand-file-name file data-directory)))
   (setq file (expand-file-name file))
   (let ((header (with-temp-buffer
+		  (set-buffer-multibyte nil)
 		  (insert-file-contents-literally file nil 0 256)
 		  (buffer-string))))
     (image-type-from-data header)))
@@ -143,7 +176,7 @@ means display it in the right marginal area."
 
 
 ;;;###autoload
-(defun insert-image (image &optional string area)
+(defun insert-image (image &optional string area slice)
   "Insert IMAGE into current buffer at point.
 IMAGE is displayed by inserting STRING into the current buffer
 with a `display' property whose value is the image.  STRING is
@@ -151,7 +184,12 @@ defaulted if you omit it.
 AREA is where to display the image.  AREA nil or omitted means
 display it in the text area, a value of `left-margin' means
 display it in the left marginal area, a value of `right-margin'
-means display it in the right marginal area."
+means display it in the right marginal area.
+SLICE specifies slice of IMAGE to insert.  SLICE nil or omitted
+means insert whole image.  SLICE is a list (X Y WIDTH HEIGHT)
+specifying the X and Y positions and WIDTH and HEIGHT of image area
+to insert.  A float value 0.0 - 1.0 means relative to the width or
+height of the image; integer values are taken as pixel values."
   ;; Use a space as least likely to cause trouble when it's a hidden
   ;; character in the buffer.
   (unless string (setq string " "))
@@ -171,11 +209,40 @@ means display it in the right marginal area."
   (let ((start (point)))
     (insert string)
     (add-text-properties start (point)
-			 (list 'display image
-			       ;; `image' has the right properties to
-			       ;; mark an intangible field.
-			       'intangible image
-			       'rear-nonsticky (list 'display)))))
+			 `(display ,(if slice
+					(list (cons 'slice slice) image)
+				      image) rear-nonsticky (display)))))
+
+
+(defun insert-sliced-image (image &optional string area rows cols)
+  (unless string (setq string " "))
+  (unless (eq (car-safe image) 'image)
+    (error "Not an image: %s" image))
+  (unless (or (null area) (memq area '(left-margin right-margin)))
+    (error "Invalid area %s" area))
+  (if area
+      (setq image (list (list 'margin area) image))
+    ;; Cons up a new spec equal but not eq to `image' so that
+    ;; inserting it twice in a row (adjacently) displays two copies of
+    ;; the image.  Don't try to avoid this by looking at the display
+    ;; properties on either side so that we DTRT more often with
+    ;; cut-and-paste.  (Yanking killed image text next to another copy
+    ;; of it loses anyway.)
+    (setq image (cons 'image (cdr image))))
+  (let ((x 0.0) (dx (/ 1.0001 (or cols 1)))
+	 (y 0.0) (dy (/ 1.0001 (or rows 1))))
+    (while (< y 1.0)
+      (while (< x 1.0)
+	(let ((start (point)))
+	  (insert string)
+	  (add-text-properties start (point)
+			       `(display ,(list (list 'slice x y dx dy) image)
+					 rear-nonsticky (display)))
+	  (setq x (+ x dx))))
+      (setq x 0.0
+	    y (+ y dy))
+      (insert "\n"))))
+
 
 
 ;;;###autoload
@@ -264,4 +331,5 @@ Example:
 
 (provide 'image)
 
+;;; arch-tag: 8e76a07b-eb48-4f3e-a7a0-1a7ba9f096b3
 ;;; image.el ends here