;;; image.el --- image API
-;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
+;; Copyright (C) 1998, 99, 2000, 01, 04 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
;; Keywords: multimedia
;; This file is part of GNU Emacs.
;;; Code:
+
+(defgroup image ()
+ "Image support."
+ :group 'multimedia)
+
+
(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" . ghostscript))
+ '(("\\`/[\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.")
+
+;;;###autoload
+(defvar image-library-alist nil
+ "Alist of image types vs external libraries needed to display them.
+
+Each element is a list (IMAGE-TYPE LIBRARY...), where the car is a symbol
+representing a supported image type, and the rest are strings giving
+alternate filenames for the corresponding external libraries.
+
+Emacs tries to load the libraries in the order they appear on the
+list; if none is loaded, the running session of Emacs won't
+support the image type. Types 'pbm and 'xbm don't need to be
+listed; they're always supported.")
+;;;###autoload (put 'image-library-alist 'risky-local-variable t)
+
+(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
(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))
(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)))
(defun image-type-available-p (type)
"Value is non-nil if image type TYPE is available.
Image types are symbols like `xbm' or `jpeg'."
- (not (null (memq type image-types))))
-
+ (and (fboundp 'init-image-library)
+ (init-image-library type image-library-alist)))
;;;###autoload
(defun create-image (file-or-data &optional type data-p &rest props)
Optional TYPE is a symbol describing the image type. If TYPE is omitted
or nil, try to determine the image type from its first few bytes
of image data. If that doesn't work, and FILE-OR-DATA is a file name,
-use its file extension.as image type.
+use its file extension as image type.
Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data.
Optional PROPS are additional image attributes to assign to the image,
-like, e.g. `:heuristic-mask t'.
+like, e.g. `:mask MASK'.
Value is the image created, or nil if images of type TYPE are not supported."
(when (and (not data-p) (not (stringp file-or-data)))
(error "Invalid image file name `%s'" file-or-data))
;;;###autoload
-(defun put-image (image pos string &optional area)
+(defun put-image (image pos &optional string area)
"Put image IMAGE in front of POS in the current buffer.
IMAGE must be an image created with `create-image' or `defimage'.
IMAGE is displayed by putting an overlay into the current buffer with a
`before-string' STRING that has a `display' property whose value is the
-image.
+image. STRING is defaulted if you omit it.
POS may be an integer or marker.
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."
+ (unless string (setq string "x"))
(let ((buffer (current-buffer)))
- (unless (eq (car image) 'image)
+ (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))
;;;###autoload
-(defun insert-image (image string &optional 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.
+with a `display' property whose value is the image. STRING is
+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."
- (unless (eq (car image) 'image)
+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 " "))
+ (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))
- (when area
- (setq image (list (list 'margin area) image)))
+ (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 ((start (point)))
(insert string)
- ;; Copy `image' so that inserting it twice in a row (adjacently)
- ;; displays two copies of the image.
(add-text-properties start (point)
- (list 'display (copy-sequence image)
- 'intangible (list t) ; something unique
- '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)
+ "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
+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.
+The image is automatically split into ROW x COLS slices."
+ (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 (propertize "\n" 'line-height 0)))))
+
;;;###autoload
(defun find-image (specs)
"Find an image, choosing one of a list of image specifications.
-SPECS is a list of image specifications. DOC is an optional
-documentation string.
+SPECS is a list of image specifications.
Each image specification in SPECS is a property list. The contents of
a specification are image type dependent. All specifications must at
least contain the properties `:type TYPE' and either `:file FILE' or
`:data DATA', where TYPE is a symbol specifying the image type,
e.g. `xbm', FILE is the file to load the image from, and DATA is a
-string containing the actual image data. The first image
-specification whose TYPE is supported, and FILE exists, is used to
-define SYMBOL."
+string containing the actual image data. The specification whose TYPE
+is supported, and FILE exists, is used to construct the image
+specification to be returned. Return nil if no specification is
+satisfied.
+
+The image is looked for first on `load-path' and then in `data-directory'."
(let (image)
(while (and specs (null image))
(let* ((spec (car specs))
(setq found try-file)))
(setq path (cdr path)))
(unless found
- (setq found (expand-file-name file data-directory)))
- (setq image (cons 'image (plist-put spec :file found)))))
+ (let ((try-file (expand-file-name file data-directory)))
+ (if (file-readable-p try-file)
+ (setq found try-file))))
+ (if found
+ (setq image
+ (cons 'image (plist-put (copy-sequence spec)
+ :file found))))))
((not (null data))
(setq image (cons 'image spec)))))
(setq specs (cdr specs))))
(provide 'image)
+;;; arch-tag: 8e76a07b-eb48-4f3e-a7a0-1a7ba9f096b3
;;; image.el ends here