[bpt/emacs.git] / lisp / image.el

;;; image.el --- image API

;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
;; Keywords: multimedia

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Commentary:

;;; Code:

(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))
  "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.")


;;;###autoload
(defun image-type-from-data (data)
  "Determine the image type from image data DATA.
Value is a symbol specifying the image type or nil if type cannot
be determined."
  (let ((types image-type-regexps)
	type)
    (while (and types (null type))
      (let ((regexp (car (car types)))
	    (image-type (cdr (car types))))
	(when (string-match regexp data)
	  (setq type image-type))
	(setq types (cdr types))))
    type))


;;;###autoload
(defun image-type-from-file-header (file)
  "Determine the type of image file FILE from its first few bytes.
Value is a symbol specifying the image type, or nil if type cannot
be determined."
  (unless (file-name-directory file)
    (setq file (expand-file-name file data-directory)))
  (setq file (expand-file-name file))
  (let ((header (with-temp-buffer
		  (insert-file-contents-literally file nil 0 256)
		  (buffer-string))))
    (image-type-from-data header)))


;;;###autoload
(defun image-type-available-p (type)
  "Value is non-nil if image type TYPE is available.
Image types are symbols like `xbm' or `jpeg'."
  (and (boundp 'image-types) (not (null (memq type image-types)))))


;;;###autoload
(defun create-image (file-or-data &optional type data-p &rest props)
  "Create an image.
FILE-OR-DATA is an image file name or image data.
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.
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'.
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))
  (cond ((null data-p)
	 ;; FILE-OR-DATA is a file name.
	 (unless (or type
		     (setq type (image-type-from-file-header file-or-data)))
	   (let ((extension (file-name-extension file-or-data)))
	     (unless extension
	       (error "Cannot determine image type"))
	     (setq type (intern extension)))))
	(t
	 ;; FILE-OR-DATA contains image data.
	 (unless type
	   (setq type (image-type-from-data file-or-data)))))
  (unless type
    (error "Cannot determine image type"))
  (unless (symbolp type)
    (error "Invalid image type `%s'" type))
  (when (image-type-available-p type)
    (append (list 'image :type type (if data-p :data :file) file-or-data)
	    props)))


;;;###autoload
(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.  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."
  ;; Use a space as least likely to cause trouble when it's a hidden
  ;; character in the buffer.
  (unless string (setq string " "))
  (let ((buffer (current-buffer)))
    (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))
    (setq string (copy-sequence string))
    (let ((overlay (make-overlay pos pos buffer))
	  (prop (if (null area) image (list (list 'margin area) image))))
      (put-text-property 0 (length string) 'display prop string)
      (overlay-put overlay 'put-image t)
      (overlay-put overlay 'before-string string))))


;;;###autoload
(defun insert-image (image &optional string area)
  "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."
  (unless string (setq string "x"))
  (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 ((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)))))


;;;###autoload
(defun remove-images (start end &optional buffer)
  "Remove images between START and END in BUFFER.
Remove only images that were put in BUFFER with calls to `put-image'.
BUFFER nil or omitted means use the current buffer."
  (unless buffer
    (setq buffer (current-buffer)))
  (let ((overlays (overlays-in start end)))
    (while overlays
      (let ((overlay (car overlays)))
	(when (overlay-get overlay 'put-image)
	  (delete-overlay overlay)))
      (setq overlays (cdr overlays)))))


;;;###autoload
(defun find-image (specs)
  "Find an image, choosing one of a list of image specifications.

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 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))
	     (type (plist-get spec :type))
	     (data (plist-get spec :data))
	     (file (plist-get spec :file))
	     found)
	(when (image-type-available-p type)
	  (cond ((stringp file)
		 (let ((path load-path))
		   (while (and (not found) path)
		     (let ((try-file (expand-file-name file (car path))))
		       (when (file-readable-p try-file)
			 (setq found try-file)))
		     (setq path (cdr path)))
		   (unless 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 spec :file found))))))
		((not (null data))
		 (setq image (cons 'image spec)))))
	(setq specs (cdr specs))))
    image))


;;;###autoload
(defmacro defimage (symbol specs &optional doc)
  "Define SYMBOL as an image.

SPECS is a list of image specifications.  DOC is an optional
documentation string.

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.

Example:

   (defimage test-image ((:type xpm :file \"~/test1.xpm\")
                         (:type xbm :file \"~/test1.xbm\")))"
  `(defvar ,symbol (find-image ',specs) ,doc))


(provide 'image)

;;; image.el ends here
Commit	Line	Data
7840ced1 GM	1	;;; image.el --- image API
7840ced1 GM	2
7f228379	3	;; Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
04799cf5	4	;; Keywords: multimedia
7840ced1 GM	5
	6	;; This file is part of GNU Emacs.
	7
	8	;; GNU Emacs is free software; you can redistribute it and/or modify
	9	;; it under the terms of the GNU General Public License as published by
	10	;; the Free Software Foundation; either version 2, or (at your option)
	11	;; any later version.
	12
	13	;; GNU Emacs is distributed in the hope that it will be useful,
	14	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	;; GNU General Public License for more details.
	17
	18	;; You should have received a copy of the GNU General Public License
	19	;; along with GNU Emacs; see the file COPYING. If not, write to the
	20	;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	21	;; Boston, MA 02111-1307, USA.
	22
	23	;;; Commentary:
	24
	25	;;; Code:
	26
	27	(defconst image-type-regexps
	28	'(("^/\\.XPM.\\*/" . xpm)
	29	("^P[1-6]" . pbm)
	30	("^GIF8" . gif)
	31	("JFIF" . jpeg)
	32	("^\211PNG\r\n" . png)
	33	("^#define" . xbm)
	34	("^\\(MM\0\\\\)\\\|\\(II\\\0\\)" . tiff)
	35	("^%!PS" . ghostscript))
	36	"Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
	37	When the first bytes of an image file match REGEXP, it is assumed to
	38	be of image type IMAGE-TYPE.")
	39
	40
	41	;;;###autoload
162dec01 GM	42	(defun image-type-from-data (data)
	43	"Determine the image type from image data DATA.
	44	Value is a symbol specifying the image type or nil if type cannot
7840ced1	45	be determined."
162dec01	46	(let ((types image-type-regexps)
7840ced1 GM	47	type)
	48	(while (and types (null type))
	49	(let ((regexp (car (car types)))
	50	(image-type (cdr (car types))))
162dec01	51	(when (string-match regexp data)
7840ced1 GM	52	(setq type image-type))
	53	(setq types (cdr types))))
	54	type))
	55
	56
162dec01 GM	57	;;;###autoload
	58	(defun image-type-from-file-header (file)
	59	"Determine the type of image file FILE from its first few bytes.
	60	Value is a symbol specifying the image type, or nil if type cannot
	61	be determined."
	62	(unless (file-name-directory file)
	63	(setq file (expand-file-name file data-directory)))
	64	(setq file (expand-file-name file))
	65	(let ((header (with-temp-buffer
	66	(insert-file-contents-literally file nil 0 256)
	67	(buffer-string))))
	68	(image-type-from-data header)))
	69
	70
7840ced1 GM	71	;;;###autoload
	72	(defun image-type-available-p (type)
	73	"Value is non-nil if image type TYPE is available.
	74	Image types are symbols like `xbm' or `jpeg'."
24978190	75	(and (boundp 'image-types) (not (null (memq type image-types)))))
7840ced1 GM	76
	77
	78	;;;###autoload
162dec01 GM	79	(defun create-image (file-or-data &optional type data-p &rest props)
	80	"Create an image.
	81	FILE-OR-DATA is an image file name or image data.
7840ced1	82	Optional TYPE is a symbol describing the image type. If TYPE is omitted
162dec01 GM	83	or nil, try to determine the image type from its first few bytes
	84	of image data. If that doesn't work, and FILE-OR-DATA is a file name,
	85	use its file extension.as image type.
	86	Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data.
7840ced1 GM	87	Optional PROPS are additional image attributes to assign to the image,
	88	like, e.g. `:heuristic-mask t'.
	89	Value is the image created, or nil if images of type TYPE are not supported."
f64ae86c GM	90	(when (and (not data-p) (not (stringp file-or-data)))
f64ae86c GM	91	(error "Invalid image file name `%s'" file-or-data))
162dec01 GM	92	(cond ((null data-p)
	93	;; FILE-OR-DATA is a file name.
	94	(unless (or type
	95	(setq type (image-type-from-file-header file-or-data)))
	96	(let ((extension (file-name-extension file-or-data)))
	97	(unless extension
	98	(error "Cannot determine image type"))
	99	(setq type (intern extension)))))
	100	(t
	101	;; FILE-OR-DATA contains image data.
	102	(unless type
	103	(setq type (image-type-from-data file-or-data)))))
	104	(unless type
	105	(error "Cannot determine image type"))
7840ced1	106	(unless (symbolp type)
162dec01	107	(error "Invalid image type `%s'" type))
7840ced1	108	(when (image-type-available-p type)
162dec01 GM	109	(append (list 'image :type type (if data-p :data :file) file-or-data)
162dec01 GM	110	props)))
7840ced1 GM	111
	112
	113	;;;###autoload
cedbd8d0	114	(defun put-image (image pos &optional string area)
1571b5ff	115	"Put image IMAGE in front of POS in the current buffer.
7840ced1	116	IMAGE must be an image created with `create-image' or `defimage'.
46655c94 GM	117	IMAGE is displayed by putting an overlay into the current buffer with a
46655c94 GM	118	`before-string' STRING that has a `display' property whose value is the
cedbd8d0	119	image. STRING is defaulted if you omit it.
7840ced1	120	POS may be an integer or marker.
7840ced1 GM	121	AREA is where to display the image. AREA nil or omitted means
	122	display it in the text area, a value of `left-margin' means
	123	display it in the left marginal area, a value of `right-margin'
46655c94	124	means display it in the right marginal area."
f290ca08 DL	125	;; Use a space as least likely to cause trouble when it's a hidden
	126	;; character in the buffer.
	127	(unless string (setq string " "))
1571b5ff	128	(let ((buffer (current-buffer)))
cedbd8d0	129	(unless (eq (car-safe image) 'image)
1571b5ff GM	130	(error "Not an image: %s" image))
	131	(unless (or (null area) (memq area '(left-margin right-margin)))
	132	(error "Invalid area %s" area))
46655c94	133	(setq string (copy-sequence string))
1571b5ff	134	(let ((overlay (make-overlay pos pos buffer))
46655c94 GM	135	(prop (if (null area) image (list (list 'margin area) image))))
46655c94 GM	136	(put-text-property 0 (length string) 'display prop string)
1571b5ff GM	137	(overlay-put overlay 'put-image t)
1571b5ff GM	138	(overlay-put overlay 'before-string string))))
7840ced1 GM	139
	140
	141	;;;###autoload
cedbd8d0	142	(defun insert-image (image &optional string area)
7840ced1	143	"Insert IMAGE into current buffer at point.
46655c94	144	IMAGE is displayed by inserting STRING into the current buffer
cedbd8d0 DL	145	with a `display' property whose value is the image. STRING is
cedbd8d0 DL	146	defaulted if you omit it.
7840ced1 GM	147	AREA is where to display the image. AREA nil or omitted means
	148	display it in the text area, a value of `left-margin' means
	149	display it in the left marginal area, a value of `right-margin'
46655c94	150	means display it in the right marginal area."
cedbd8d0 DL	151	(unless string (setq string "x"))
cedbd8d0 DL	152	(unless (eq (car-safe image) 'image)
7840ced1 GM	153	(error "Not an image: %s" image))
	154	(unless (or (null area) (memq area '(left-margin right-margin)))
	155	(error "Invalid area %s" area))
0dc91c57 DL	156	(if area
	157	(setq image (list (list 'margin area) image))
	158	;; Cons up a new spec equal but not eq to `image' so that
	159	;; inserting it twice in a row (adjacently) displays two copies of
	160	;; the image. Don't try to avoid this by looking at the display
	161	;; properties on either side so that we DTRT more often with
	162	;; cut-and-paste. (Yanking killed image text next to another copy
	163	;; of it loses anyway.)
	164	(setq image (cons 'image (cdr image))))
46655c94 GM	165	(let ((start (point)))
	166	(insert string)
	167	(add-text-properties start (point)
0dc91c57 DL	168	(list 'display image
	169	;; `image' has the right properties to
	170	;; mark an intangible field.
	171	'intangible image
46655c94	172	'rear-nonsticky (list 'display)))))
10e2102e	173
7840ced1 GM	174
	175	;;;###autoload
	176	(defun remove-images (start end &optional buffer)
	177	"Remove images between START and END in BUFFER.
	178	Remove only images that were put in BUFFER with calls to `put-image'.
	179	BUFFER nil or omitted means use the current buffer."
	180	(unless buffer
	181	(setq buffer (current-buffer)))
	182	(let ((overlays (overlays-in start end)))
	183	(while overlays
	184	(let ((overlay (car overlays)))
	185	(when (overlay-get overlay 'put-image)
0c898dd9 DL	186	(delete-overlay overlay)))
0c898dd9 DL	187	(setq overlays (cdr overlays)))))
7840ced1 GM	188
	189
	190	;;;###autoload
349c034d GM	191	(defun find-image (specs)
349c034d GM	192	"Find an image, choosing one of a list of image specifications.
7840ced1	193
cedbd8d0	194	SPECS is a list of image specifications.
7840ced1 GM	195
	196	Each image specification in SPECS is a property list. The contents of
	197	a specification are image type dependent. All specifications must at
bc283707 WP	198	least contain the properties `:type TYPE' and either `:file FILE' or
	199	`:data DATA', where TYPE is a symbol specifying the image type,
	200	e.g. `xbm', FILE is the file to load the image from, and DATA is a
cedbd8d0 DL	201	string containing the actual image data. The specification whose TYPE
	202	is supported, and FILE exists, is used to construct the image
	203	specification to be returned. Return nil if no specification is
	204	satisfied.
	205
	206	The image is looked for first on `load-path' and then in `data-directory'."
7840ced1 GM	207	(let (image)
	208	(while (and specs (null image))
	209	(let* ((spec (car specs))
	210	(type (plist-get spec :type))
162dec01	211	(data (plist-get spec :data))
7f228379 GM	212	(file (plist-get spec :file))
7f228379 GM	213	found)
162dec01 GM	214	(when (image-type-available-p type)
162dec01 GM	215	(cond ((stringp file)
7f228379 GM	216	(let ((path load-path))
	217	(while (and (not found) path)
	218	(let ((try-file (expand-file-name file (car path))))
	219	(when (file-readable-p try-file)
	220	(setq found try-file)))
	221	(setq path (cdr path)))
	222	(unless found
cedbd8d0 DL	223	(let ((try-file (expand-file-name file data-directory)))
	224	(if (file-readable-p try-file)
	225	(setq found try-file))))
	226	(if found
	227	(setq image
	228	(cons 'image (plist-put spec :file found))))))
f64ae86c	229	((not (null data))
162dec01 GM	230	(setq image (cons 'image spec)))))
162dec01 GM	231	(setq specs (cdr specs))))
349c034d GM	232	image))
	233
	234
	235	;;;###autoload
	236	(defmacro defimage (symbol specs &optional doc)
	237	"Define SYMBOL as an image.
	238
	239	SPECS is a list of image specifications. DOC is an optional
	240	documentation string.
	241
	242	Each image specification in SPECS is a property list. The contents of
	243	a specification are image type dependent. All specifications must at
	244	least contain the properties `:type TYPE' and either `:file FILE' or
	245	`:data DATA', where TYPE is a symbol specifying the image type,
	246	e.g. `xbm', FILE is the file to load the image from, and DATA is a
	247	string containing the actual image data. The first image
	248	specification whose TYPE is supported, and FILE exists, is used to
	249	define SYMBOL.
	250
	251	Example:
	252
	253	(defimage test-image ((:type xpm :file \"~/test1.xpm\")
	254	(:type xbm :file \"~/test1.xbm\")))"
	255	`(defvar ,symbol (find-image ',specs) ,doc))
7840ced1 GM	256
	257
	258	(provide 'image)
	259
e43367a0	260	;;; image.el ends here