[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."
  (unless string (setq string "x"))
  (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))
  (when area
    (setq image (list (list 'margin area) 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)))))


;;;###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."
cedbd8d0	125	(unless string (setq string "x"))
1571b5ff	126	(let ((buffer (current-buffer)))
cedbd8d0	127	(unless (eq (car-safe image) 'image)
1571b5ff GM	128	(error "Not an image: %s" image))
	129	(unless (or (null area) (memq area '(left-margin right-margin)))
	130	(error "Invalid area %s" area))
46655c94	131	(setq string (copy-sequence string))
1571b5ff	132	(let ((overlay (make-overlay pos pos buffer))
46655c94 GM	133	(prop (if (null area) image (list (list 'margin area) image))))
46655c94 GM	134	(put-text-property 0 (length string) 'display prop string)
1571b5ff GM	135	(overlay-put overlay 'put-image t)
1571b5ff GM	136	(overlay-put overlay 'before-string string))))
7840ced1 GM	137
	138
	139	;;;###autoload
cedbd8d0	140	(defun insert-image (image &optional string area)
7840ced1	141	"Insert IMAGE into current buffer at point.
46655c94	142	IMAGE is displayed by inserting STRING into the current buffer
cedbd8d0 DL	143	with a `display' property whose value is the image. STRING is
cedbd8d0 DL	144	defaulted if you omit it.
7840ced1 GM	145	AREA is where to display the image. AREA nil or omitted means
	146	display it in the text area, a value of `left-margin' means
	147	display it in the left marginal area, a value of `right-margin'
46655c94	148	means display it in the right marginal area."
cedbd8d0 DL	149	(unless string (setq string "x"))
cedbd8d0 DL	150	(unless (eq (car-safe image) 'image)
7840ced1 GM	151	(error "Not an image: %s" image))
	152	(unless (or (null area) (memq area '(left-margin right-margin)))
	153	(error "Invalid area %s" area))
46655c94 GM	154	(when area
	155	(setq image (list (list 'margin area) image)))
	156	(let ((start (point)))
	157	(insert string)
10e2102e DL	158	;; Copy `image' so that inserting it twice in a row (adjacently)
10e2102e DL	159	;; displays two copies of the image.
46655c94	160	(add-text-properties start (point)
10e2102e DL	161	(list 'display (copy-sequence image)
10e2102e DL	162	'intangible (list t) ; something unique
46655c94	163	'rear-nonsticky (list 'display)))))
10e2102e	164
7840ced1 GM	165
	166	;;;###autoload
	167	(defun remove-images (start end &optional buffer)
	168	"Remove images between START and END in BUFFER.
	169	Remove only images that were put in BUFFER with calls to `put-image'.
	170	BUFFER nil or omitted means use the current buffer."
	171	(unless buffer
	172	(setq buffer (current-buffer)))
	173	(let ((overlays (overlays-in start end)))
	174	(while overlays
	175	(let ((overlay (car overlays)))
	176	(when (overlay-get overlay 'put-image)
0c898dd9 DL	177	(delete-overlay overlay)))
0c898dd9 DL	178	(setq overlays (cdr overlays)))))
7840ced1 GM	179
	180
	181	;;;###autoload
349c034d GM	182	(defun find-image (specs)
349c034d GM	183	"Find an image, choosing one of a list of image specifications.
7840ced1	184
cedbd8d0	185	SPECS is a list of image specifications.
7840ced1 GM	186
	187	Each image specification in SPECS is a property list. The contents of
	188	a specification are image type dependent. All specifications must at
bc283707 WP	189	least contain the properties `:type TYPE' and either `:file FILE' or
	190	`:data DATA', where TYPE is a symbol specifying the image type,
	191	e.g. `xbm', FILE is the file to load the image from, and DATA is a
cedbd8d0 DL	192	string containing the actual image data. The specification whose TYPE
	193	is supported, and FILE exists, is used to construct the image
	194	specification to be returned. Return nil if no specification is
	195	satisfied.
	196
	197	The image is looked for first on `load-path' and then in `data-directory'."
7840ced1 GM	198	(let (image)
	199	(while (and specs (null image))
	200	(let* ((spec (car specs))
	201	(type (plist-get spec :type))
162dec01	202	(data (plist-get spec :data))
7f228379 GM	203	(file (plist-get spec :file))
7f228379 GM	204	found)
162dec01 GM	205	(when (image-type-available-p type)
162dec01 GM	206	(cond ((stringp file)
7f228379 GM	207	(let ((path load-path))
	208	(while (and (not found) path)
	209	(let ((try-file (expand-file-name file (car path))))
	210	(when (file-readable-p try-file)
	211	(setq found try-file)))
	212	(setq path (cdr path)))
	213	(unless found
cedbd8d0 DL	214	(let ((try-file (expand-file-name file data-directory)))
	215	(if (file-readable-p try-file)
	216	(setq found try-file))))
	217	(if found
	218	(setq image
	219	(cons 'image (plist-put spec :file found))))))
f64ae86c	220	((not (null data))
162dec01 GM	221	(setq image (cons 'image spec)))))
162dec01 GM	222	(setq specs (cdr specs))))
349c034d GM	223	image))
	224
	225
	226	;;;###autoload
	227	(defmacro defimage (symbol specs &optional doc)
	228	"Define SYMBOL as an image.
	229
	230	SPECS is a list of image specifications. DOC is an optional
	231	documentation string.
	232
	233	Each image specification in SPECS is a property list. The contents of
	234	a specification are image type dependent. All specifications must at
	235	least contain the properties `:type TYPE' and either `:file FILE' or
	236	`:data DATA', where TYPE is a symbol specifying the image type,
	237	e.g. `xbm', FILE is the file to load the image from, and DATA is a
	238	string containing the actual image data. The first image
	239	specification whose TYPE is supported, and FILE exists, is used to
	240	define SYMBOL.
	241
	242	Example:
	243
	244	(defimage test-image ((:type xpm :file \"~/test1.xpm\")
	245	(:type xbm :file \"~/test1.xbm\")))"
	246	`(defvar ,symbol (find-image ',specs) ,doc))
7840ced1 GM	247
	248
	249	(provide 'image)
	250
e43367a0	251	;;; image.el ends here