Line data Source code
1 : ;;; image.el --- image API -*- lexical-binding:t -*-
2 :
3 : ;; Copyright (C) 1998-2017 Free Software Foundation, Inc.
4 :
5 : ;; Maintainer: emacs-devel@gnu.org
6 : ;; Keywords: multimedia
7 : ;; Package: emacs
8 :
9 : ;; This file is part of GNU Emacs.
10 :
11 : ;; GNU Emacs is free software: you can redistribute it and/or modify
12 : ;; it under the terms of the GNU General Public License as published by
13 : ;; the Free Software Foundation, either version 3 of the License, or
14 : ;; (at your option) any later version.
15 :
16 : ;; GNU Emacs is distributed in the hope that it will be useful,
17 : ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 : ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 : ;; GNU General Public License for more details.
20 :
21 : ;; You should have received a copy of the GNU General Public License
22 : ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
23 :
24 : ;;; Commentary:
25 :
26 : ;;; Code:
27 :
28 : (defgroup image ()
29 : "Image support."
30 : :group 'multimedia)
31 :
32 : (defalias 'image-refresh 'image-flush)
33 :
34 : (defconst image-type-header-regexps
35 : `(("\\`/[\t\n\r ]*\\*.*XPM.\\*/" . xpm)
36 : ("\\`P[1-6]\\(?:\
37 : \\(?:\\(?:#[^\r\n]*[\r\n]\\)?[[:space:]]\\)+\
38 : \\(?:\\(?:#[^\r\n]*[\r\n]\\)?[0-9]\\)+\
39 : \\)\\{2\\}" . pbm)
40 : ("\\`GIF8[79]a" . gif)
41 : ("\\`\x89PNG\r\n\x1a\n" . png)
42 : ("\\`[\t\n\r ]*#define \\([a-z0-9_]+\\)_width [0-9]+\n\
43 : #define \\1_height [0-9]+\n\\(\
44 : #define \\1_x_hot [0-9]+\n\
45 : #define \\1_y_hot [0-9]+\n\\)?\
46 : static \\(unsigned \\)?char \\1_bits" . xbm)
47 : ("\\`\\(?:MM\0\\*\\|II\\*\0\\)" . tiff)
48 : ("\\`[\t\n\r ]*%!PS" . postscript)
49 : ("\\`\xff\xd8" . jpeg) ; used to be (image-jpeg-p . jpeg)
50 : (,(let* ((incomment-re "\\(?:[^-]\\|-[^-]\\)")
51 : (comment-re (concat "\\(?:!--" incomment-re "*-->[ \t\r\n]*<\\)")))
52 : (concat "\\(?:<\\?xml[ \t\r\n]+[^>]*>\\)?[ \t\r\n]*<"
53 : comment-re "*"
54 : "\\(?:!DOCTYPE[ \t\r\n]+[^>]*>[ \t\r\n]*<[ \t\r\n]*" comment-re "*\\)?"
55 : "[Ss][Vv][Gg]"))
56 : . svg)
57 : )
58 : "Alist of (REGEXP . IMAGE-TYPE) pairs used to auto-detect image types.
59 : When the first bytes of an image file match REGEXP, it is assumed to
60 : be of image type IMAGE-TYPE if IMAGE-TYPE is a symbol. If not a symbol,
61 : IMAGE-TYPE must be a pair (PREDICATE . TYPE). PREDICATE is called
62 : with one argument, a string containing the image data. If PREDICATE returns
63 : a non-nil value, TYPE is the image's type.")
64 :
65 : (defvar image-type-file-name-regexps
66 : '(("\\.png\\'" . png)
67 : ("\\.gif\\'" . gif)
68 : ("\\.jpe?g\\'" . jpeg)
69 : ("\\.bmp\\'" . bmp)
70 : ("\\.xpm\\'" . xpm)
71 : ("\\.pbm\\'" . pbm)
72 : ("\\.xbm\\'" . xbm)
73 : ("\\.ps\\'" . postscript)
74 : ("\\.tiff?\\'" . tiff)
75 : ("\\.svgz?\\'" . svg)
76 : )
77 : "Alist of (REGEXP . IMAGE-TYPE) pairs used to identify image files.
78 : When the name of an image file match REGEXP, it is assumed to
79 : be of image type IMAGE-TYPE.")
80 :
81 : ;; We rely on `auto-mode-alist' to detect xbm and xpm files, instead
82 : ;; of content autodetection. Their contents are just C code, so it is
83 : ;; easy to generate false matches.
84 : (defvar image-type-auto-detectable
85 : '((pbm . t)
86 : (xbm . nil)
87 : (bmp . maybe)
88 : (gif . maybe)
89 : (png . maybe)
90 : (xpm . nil)
91 : (jpeg . maybe)
92 : (tiff . maybe)
93 : (svg . maybe)
94 : (postscript . nil))
95 : "Alist of (IMAGE-TYPE . AUTODETECT) pairs used to auto-detect image files.
96 : \(See `image-type-auto-detected-p').
97 :
98 : AUTODETECT can be
99 : - t always auto-detect.
100 : - nil never auto-detect.
101 : - maybe auto-detect only if the image type is available
102 : (see `image-type-available-p').")
103 :
104 : (defvar image-format-suffixes
105 : '((image/x-rgb "rgb") (image/x-icon "ico"))
106 : "An alist associating image types with file name suffixes.
107 : This is used as a hint by the ImageMagick library when detecting
108 : the type of image data (that does not have an associated file name).
109 : Each element has the form (MIME-CONTENT-TYPE EXTENSION).
110 : If `create-image' is called with a :format attribute whose value
111 : equals a content-type found in this list, the ImageMagick library is
112 : told that the data would have the associated suffix if saved to a file.")
113 :
114 : (defcustom image-load-path
115 : (list (file-name-as-directory (expand-file-name "images" data-directory))
116 : 'data-directory 'load-path)
117 : "List of locations in which to search for image files.
118 : If an element is a string, it defines a directory to search.
119 : If an element is a variable symbol whose value is a string, that
120 : value defines a directory to search.
121 : If an element is a variable symbol whose value is a list, the
122 : value is used as a list of directories to search.
123 :
124 : Subdirectories are not automatically included in the search."
125 : :type '(repeat (choice directory variable))
126 : :initialize #'custom-initialize-delay)
127 :
128 : (defcustom image-scaling-factor 'auto
129 : "When displaying images, apply this scaling factor before displaying.
130 : This is not supported for all image types, and is mostly useful
131 : when you have a high-resolution monitor.
132 : The value is either a floating point number (where numbers higher
133 : than 1 means to increase the size and lower means to shrink the
134 : size), or the symbol `auto', which will compute a scaling factor
135 : based on the font pixel size."
136 : :type '(choice number
137 : (const :tag "Automatically compute" auto))
138 : :version "26.1")
139 :
140 : ;; Map put into text properties on images.
141 : (defvar image-map
142 : (let ((map (make-sparse-keymap)))
143 : (define-key map "-" 'image-decrease-size)
144 : (define-key map "+" 'image-increase-size)
145 : (define-key map "r" 'image-rotate)
146 : (define-key map "o" 'image-save)
147 : map))
148 :
149 : (defun image-load-path-for-library (library image &optional path no-error)
150 : "Return a suitable search path for images used by LIBRARY.
151 :
152 : It searches for IMAGE in `image-load-path' (excluding
153 : \"`data-directory'/images\") and `load-path', followed by a path
154 : suitable for LIBRARY, which includes \"../../etc/images\" and
155 : \"../etc/images\" relative to the library file itself, and then
156 : in \"`data-directory'/images\".
157 :
158 : Then this function returns a list of directories which contains
159 : first the directory in which IMAGE was found, followed by the
160 : value of `load-path'. If PATH is given, it is used instead of
161 : `load-path'.
162 :
163 : If NO-ERROR is non-nil and a suitable path can't be found, don't
164 : signal an error. Instead, return a list of directories as before,
165 : except that nil appears in place of the image directory.
166 :
167 : Here is an example that uses a common idiom to provide
168 : compatibility with versions of Emacs that lack the variable
169 : `image-load-path':
170 :
171 : ;; Shush compiler.
172 : (defvar image-load-path)
173 :
174 : (let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\"))
175 : (image-load-path (cons (car load-path)
176 : (when (boundp \\='image-load-path)
177 : image-load-path))))
178 : (mh-tool-bar-folder-buttons-init))"
179 0 : (unless library (error "No library specified"))
180 0 : (unless image (error "No image specified"))
181 0 : (let (image-directory image-directory-load-path)
182 : ;; Check for images in image-load-path or load-path.
183 0 : (let ((img image)
184 0 : (dir (or
185 : ;; Images in image-load-path.
186 0 : (image-search-load-path image)
187 : ;; Images in load-path.
188 0 : (locate-library image)))
189 : parent)
190 : ;; Since the image might be in a nested directory (for
191 : ;; example, mail/attach.pbm), adjust `image-directory'
192 : ;; accordingly.
193 0 : (when dir
194 0 : (setq dir (file-name-directory dir))
195 0 : (while (setq parent (file-name-directory img))
196 0 : (setq img (directory-file-name parent)
197 0 : dir (expand-file-name "../" dir))))
198 0 : (setq image-directory-load-path dir))
199 :
200 : ;; If `image-directory-load-path' isn't Emacs's image directory,
201 : ;; it's probably a user preference, so use it. Then use a
202 : ;; relative setting if possible; otherwise, use
203 : ;; `image-directory-load-path'.
204 0 : (cond
205 : ;; User-modified image-load-path?
206 0 : ((and image-directory-load-path
207 0 : (not (equal image-directory-load-path
208 0 : (file-name-as-directory
209 0 : (expand-file-name "images" data-directory)))))
210 0 : (setq image-directory image-directory-load-path))
211 : ;; Try relative setting.
212 0 : ((let (library-name d1ei d2ei)
213 : ;; First, find library in the load-path.
214 0 : (setq library-name (locate-library library))
215 0 : (if (not library-name)
216 0 : (error "Cannot find library %s in load-path" library))
217 : ;; And then set image-directory relative to that.
218 0 : (setq
219 : ;; Go down 2 levels.
220 0 : d2ei (file-name-as-directory
221 0 : (expand-file-name
222 0 : (concat (file-name-directory library-name) "../../etc/images")))
223 : ;; Go down 1 level.
224 0 : d1ei (file-name-as-directory
225 0 : (expand-file-name
226 0 : (concat (file-name-directory library-name) "../etc/images"))))
227 0 : (setq image-directory
228 : ;; Set it to nil if image is not found.
229 0 : (cond ((file-exists-p (expand-file-name image d2ei)) d2ei)
230 0 : ((file-exists-p (expand-file-name image d1ei)) d1ei)))))
231 : ;; Use Emacs's image directory.
232 0 : (image-directory-load-path
233 0 : (setq image-directory image-directory-load-path))
234 0 : (no-error
235 0 : (message "Could not find image %s for library %s" image library))
236 : (t
237 0 : (error "Could not find image %s for library %s" image library)))
238 :
239 : ;; Return an augmented `path' or `load-path'.
240 0 : (nconc (list image-directory)
241 0 : (delete image-directory (copy-sequence (or path load-path))))))
242 :
243 :
244 : ;; Used to be in image-type-header-regexps, but now not used anywhere
245 : ;; (since 2009-08-28).
246 : (defun image-jpeg-p (data)
247 : "Value is non-nil if DATA, a string, consists of JFIF image data.
248 : We accept the tag Exif because that is the same format."
249 0 : (setq data (ignore-errors (string-to-unibyte data)))
250 0 : (when (and data (string-match-p "\\`\xff\xd8" data))
251 0 : (catch 'jfif
252 0 : (let ((len (length data)) (i 2))
253 0 : (while (< i len)
254 0 : (when (/= (aref data i) #xff)
255 0 : (throw 'jfif nil))
256 0 : (setq i (1+ i))
257 0 : (when (>= (+ i 2) len)
258 0 : (throw 'jfif nil))
259 0 : (let ((nbytes (+ (lsh (aref data (+ i 1)) 8)
260 0 : (aref data (+ i 2))))
261 0 : (code (aref data i)))
262 0 : (when (and (>= code #xe0) (<= code #xef))
263 : ;; APP0 LEN1 LEN2 "JFIF\0"
264 0 : (throw 'jfif
265 0 : (string-match-p "JFIF\\|Exif"
266 0 : (substring data i (min (+ i nbytes) len)))))
267 0 : (setq i (+ i 1 nbytes))))))))
268 :
269 :
270 : ;;;###autoload
271 : (defun image-type-from-data (data)
272 : "Determine the image type from image data DATA.
273 : Value is a symbol specifying the image type or nil if type cannot
274 : be determined."
275 0 : (let ((types image-type-header-regexps)
276 : type)
277 0 : (while types
278 0 : (let ((regexp (car (car types)))
279 0 : (image-type (cdr (car types))))
280 0 : (if (or (and (symbolp image-type)
281 0 : (string-match-p regexp data))
282 0 : (and (consp image-type)
283 0 : (funcall (car image-type) data)
284 0 : (setq image-type (cdr image-type))))
285 0 : (setq type image-type
286 0 : types nil)
287 0 : (setq types (cdr types)))))
288 0 : type))
289 :
290 :
291 : ;;;###autoload
292 : (defun image-type-from-buffer ()
293 : "Determine the image type from data in the current buffer.
294 : Value is a symbol specifying the image type or nil if type cannot
295 : be determined."
296 0 : (let ((types image-type-header-regexps)
297 : type
298 0 : (opoint (point)))
299 0 : (goto-char (point-min))
300 0 : (while types
301 0 : (let ((regexp (car (car types)))
302 0 : (image-type (cdr (car types)))
303 : data)
304 0 : (if (or (and (symbolp image-type)
305 0 : (looking-at-p regexp))
306 0 : (and (consp image-type)
307 0 : (funcall (car image-type)
308 0 : (or data
309 0 : (setq data
310 0 : (buffer-substring
311 0 : (point-min)
312 0 : (min (point-max)
313 0 : (+ (point-min) 256))))))
314 0 : (setq image-type (cdr image-type))))
315 0 : (setq type image-type
316 0 : types nil)
317 0 : (setq types (cdr types)))))
318 0 : (goto-char opoint)
319 0 : (and type
320 0 : (boundp 'image-types)
321 0 : (memq type image-types)
322 0 : type)))
323 :
324 :
325 : ;;;###autoload
326 : (defun image-type-from-file-header (file)
327 : "Determine the type of image file FILE from its first few bytes.
328 : Value is a symbol specifying the image type, or nil if type cannot
329 : be determined."
330 0 : (unless (or (file-readable-p file)
331 0 : (file-name-absolute-p file))
332 0 : (setq file (image-search-load-path file)))
333 0 : (and file
334 0 : (file-readable-p file)
335 0 : (with-temp-buffer
336 0 : (set-buffer-multibyte nil)
337 0 : (insert-file-contents-literally file nil 0 256)
338 0 : (image-type-from-buffer))))
339 :
340 :
341 : ;;;###autoload
342 : (defun image-type-from-file-name (file)
343 : "Determine the type of image file FILE from its name.
344 : Value is a symbol specifying the image type, or nil if type cannot
345 : be determined."
346 0 : (let (type first (case-fold-search t))
347 0 : (catch 'found
348 0 : (dolist (elem image-type-file-name-regexps first)
349 0 : (when (string-match-p (car elem) file)
350 0 : (if (image-type-available-p (setq type (cdr elem)))
351 0 : (throw 'found type)
352 : ;; If nothing seems to be supported, return first type that matched.
353 0 : (or first (setq first type))))))))
354 :
355 : ;;;###autoload
356 : (defun image-type (source &optional type data-p)
357 : "Determine and return image type.
358 : SOURCE is an image file name or image data.
359 : Optional TYPE is a symbol describing the image type. If TYPE is omitted
360 : or nil, try to determine the image type from its first few bytes
361 : of image data. If that doesn't work, and SOURCE is a file name,
362 : use its file extension as image type.
363 : Optional DATA-P non-nil means SOURCE is a string containing image data."
364 0 : (when (and (not data-p) (not (stringp source)))
365 0 : (error "Invalid image file name `%s'" source))
366 0 : (unless type
367 0 : (setq type (if data-p
368 0 : (image-type-from-data source)
369 0 : (or (image-type-from-file-header source)
370 0 : (image-type-from-file-name source))))
371 0 : (or type (error "Cannot determine image type")))
372 0 : (or (memq type (and (boundp 'image-types) image-types))
373 0 : (error "Invalid image type `%s'" type))
374 0 : type)
375 :
376 :
377 : (if (fboundp 'image-metadata) ; eg not --without-x
378 : (define-obsolete-function-alias 'image-extension-data
379 : 'image-metadata "24.1"))
380 :
381 : (define-obsolete-variable-alias
382 : 'image-library-alist
383 : 'dynamic-library-alist "24.1")
384 :
385 : ;;;###autoload
386 : (defun image-type-available-p (type)
387 : "Return non-nil if image type TYPE is available.
388 : Image types are symbols like `xbm' or `jpeg'."
389 0 : (and (fboundp 'init-image-library)
390 0 : (init-image-library type)))
391 :
392 :
393 : ;;;###autoload
394 : (defun image-type-auto-detected-p ()
395 : "Return t if the current buffer contains an auto-detectable image.
396 : This function is intended to be used from `magic-fallback-mode-alist'.
397 :
398 : The buffer is considered to contain an auto-detectable image if
399 : its beginning matches an image type in `image-type-header-regexps',
400 : and that image type is present in `image-type-auto-detectable' with a
401 : non-nil value. If that value is non-nil, but not t, then the image type
402 : must be available."
403 0 : (let* ((type (image-type-from-buffer))
404 0 : (auto (and type (cdr (assq type image-type-auto-detectable)))))
405 0 : (and auto
406 0 : (or (eq auto t) (image-type-available-p type)))))
407 :
408 :
409 : ;;;###autoload
410 : (defun create-image (file-or-data &optional type data-p &rest props)
411 : "Create an image.
412 : FILE-OR-DATA is an image file name or image data.
413 : Optional TYPE is a symbol describing the image type. If TYPE is omitted
414 : or nil, try to determine the image type from its first few bytes
415 : of image data. If that doesn't work, and FILE-OR-DATA is a file name,
416 : use its file extension as image type.
417 : Optional DATA-P non-nil means FILE-OR-DATA is a string containing image data.
418 : Optional PROPS are additional image attributes to assign to the image,
419 : like, e.g. `:mask MASK'.
420 : Value is the image created, or nil if images of type TYPE are not supported.
421 :
422 : Images should not be larger than specified by `max-image-size'.
423 :
424 : Image file names that are not absolute are searched for in the
425 : \"images\" sub-directory of `data-directory' and
426 : `x-bitmap-file-path' (in that order)."
427 : ;; It is x_find_image_file in image.c that sets the search path.
428 0 : (setq type (image-type file-or-data type data-p))
429 0 : (when (image-type-available-p type)
430 0 : (append (list 'image :type type (if data-p :data :file) file-or-data)
431 0 : (and (not (plist-get props :scale))
432 0 : (list :scale
433 0 : (image-compute-scaling-factor image-scaling-factor)))
434 0 : props)))
435 :
436 : (defun image--set-property (image property value)
437 : "Set PROPERTY in IMAGE to VALUE.
438 : Internal use only."
439 0 : (if (null value)
440 0 : (while (cdr image)
441 : ;; IMAGE starts with the symbol `image', and the rest is a
442 : ;; plist. Decouple plist entries where the key matches
443 : ;; the property.
444 0 : (if (eq (cadr image) property)
445 0 : (setcdr image (cddr image))
446 0 : (setq image (cddr image))))
447 : ;; Just enter the new value.
448 0 : (plist-put (cdr image) property value))
449 0 : value)
450 :
451 : (defun image-property (image property)
452 : "Return the value of PROPERTY in IMAGE.
453 : Properties can be set with
454 :
455 : (setf (image-property IMAGE PROPERTY) VALUE)
456 : If VALUE is nil, PROPERTY is removed from IMAGE."
457 : (declare (gv-setter image--set-property))
458 0 : (plist-get (cdr image) property))
459 :
460 : (defun image-compute-scaling-factor (scaling)
461 0 : (cond
462 0 : ((numberp scaling) scaling)
463 0 : ((eq scaling 'auto)
464 0 : (let ((width (/ (float (window-width nil t)) (window-width))))
465 : ;; If we assume that a typical character is 10 pixels in width,
466 : ;; then we should scale all images according to how wide they
467 : ;; are. But don't scale images down.
468 0 : (if (< width 10)
469 : 1
470 0 : (/ (float width) 10))))
471 : (t
472 0 : (error "Invalid scaling factor %s" scaling))))
473 :
474 : ;;;###autoload
475 : (defun put-image (image pos &optional string area)
476 : "Put image IMAGE in front of POS in the current buffer.
477 : IMAGE must be an image created with `create-image' or `defimage'.
478 : IMAGE is displayed by putting an overlay into the current buffer with a
479 : `before-string' STRING that has a `display' property whose value is the
480 : image. STRING is defaulted if you omit it.
481 : The overlay created will have the `put-image' property set to t.
482 : POS may be an integer or marker.
483 : AREA is where to display the image. AREA nil or omitted means
484 : display it in the text area, a value of `left-margin' means
485 : display it in the left marginal area, a value of `right-margin'
486 : means display it in the right marginal area."
487 0 : (unless string (setq string "x"))
488 0 : (let ((buffer (current-buffer)))
489 0 : (unless (eq (car-safe image) 'image)
490 0 : (error "Not an image: %s" image))
491 0 : (unless (or (null area) (memq area '(left-margin right-margin)))
492 0 : (error "Invalid area %s" area))
493 0 : (setq string (copy-sequence string))
494 0 : (let ((overlay (make-overlay pos pos buffer))
495 0 : (prop (if (null area) image (list (list 'margin area) image))))
496 0 : (put-text-property 0 (length string) 'display prop string)
497 0 : (overlay-put overlay 'put-image t)
498 0 : (overlay-put overlay 'before-string string)
499 0 : (overlay-put overlay 'map image-map)
500 0 : overlay)))
501 :
502 :
503 : ;;;###autoload
504 : (defun insert-image (image &optional string area slice)
505 : "Insert IMAGE into current buffer at point.
506 : IMAGE is displayed by inserting STRING into the current buffer
507 : with a `display' property whose value is the image. STRING
508 : defaults to a single space if you omit it.
509 : AREA is where to display the image. AREA nil or omitted means
510 : display it in the text area, a value of `left-margin' means
511 : display it in the left marginal area, a value of `right-margin'
512 : means display it in the right marginal area.
513 : SLICE specifies slice of IMAGE to insert. SLICE nil or omitted
514 : means insert whole image. SLICE is a list (X Y WIDTH HEIGHT)
515 : specifying the X and Y positions and WIDTH and HEIGHT of image area
516 : to insert. A float value 0.0 - 1.0 means relative to the width or
517 : height of the image; integer values are taken as pixel values."
518 : ;; Use a space as least likely to cause trouble when it's a hidden
519 : ;; character in the buffer.
520 0 : (unless string (setq string " "))
521 0 : (unless (eq (car-safe image) 'image)
522 0 : (error "Not an image: %s" image))
523 0 : (unless (or (null area) (memq area '(left-margin right-margin)))
524 0 : (error "Invalid area %s" area))
525 0 : (if area
526 0 : (setq image (list (list 'margin area) image))
527 : ;; Cons up a new spec equal but not eq to `image' so that
528 : ;; inserting it twice in a row (adjacently) displays two copies of
529 : ;; the image. Don't try to avoid this by looking at the display
530 : ;; properties on either side so that we DTRT more often with
531 : ;; cut-and-paste. (Yanking killed image text next to another copy
532 : ;; of it loses anyway.)
533 0 : (setq image (cons 'image (cdr image))))
534 0 : (let ((start (point)))
535 0 : (insert string)
536 0 : (add-text-properties start (point)
537 0 : `(display ,(if slice
538 0 : (list (cons 'slice slice) image)
539 0 : image)
540 : rear-nonsticky (display)
541 0 : keymap ,image-map))))
542 :
543 :
544 : ;;;###autoload
545 : (defun insert-sliced-image (image &optional string area rows cols)
546 : "Insert IMAGE into current buffer at point.
547 : IMAGE is displayed by inserting STRING into the current buffer
548 : with a `display' property whose value is the image. The default
549 : STRING is a single space.
550 : AREA is where to display the image. AREA nil or omitted means
551 : display it in the text area, a value of `left-margin' means
552 : display it in the left marginal area, a value of `right-margin'
553 : means display it in the right marginal area.
554 : The image is automatically split into ROWS x COLS slices."
555 0 : (unless string (setq string " "))
556 0 : (unless (eq (car-safe image) 'image)
557 0 : (error "Not an image: %s" image))
558 0 : (unless (or (null area) (memq area '(left-margin right-margin)))
559 0 : (error "Invalid area %s" area))
560 0 : (if area
561 0 : (setq image (list (list 'margin area) image))
562 : ;; Cons up a new spec equal but not eq to `image' so that
563 : ;; inserting it twice in a row (adjacently) displays two copies of
564 : ;; the image. Don't try to avoid this by looking at the display
565 : ;; properties on either side so that we DTRT more often with
566 : ;; cut-and-paste. (Yanking killed image text next to another copy
567 : ;; of it loses anyway.)
568 0 : (setq image (cons 'image (cdr image))))
569 0 : (let ((x 0.0) (dx (/ 1.0001 (or cols 1)))
570 0 : (y 0.0) (dy (/ 1.0001 (or rows 1))))
571 0 : (while (< y 1.0)
572 0 : (while (< x 1.0)
573 0 : (let ((start (point)))
574 0 : (insert string)
575 0 : (add-text-properties start (point)
576 0 : `(display ,(list (list 'slice x y dx dy) image)
577 : rear-nonsticky (display)
578 0 : keymap ,image-map))
579 0 : (setq x (+ x dx))))
580 0 : (setq x 0.0
581 0 : y (+ y dy))
582 0 : (insert (propertize "\n" 'line-height t)))))
583 :
584 :
585 :
586 : ;;;###autoload
587 : (defun remove-images (start end &optional buffer)
588 : "Remove images between START and END in BUFFER.
589 : Remove only images that were put in BUFFER with calls to `put-image'.
590 : BUFFER nil or omitted means use the current buffer."
591 0 : (unless buffer
592 0 : (setq buffer (current-buffer)))
593 0 : (let ((overlays (overlays-in start end)))
594 0 : (while overlays
595 0 : (let ((overlay (car overlays)))
596 0 : (when (overlay-get overlay 'put-image)
597 0 : (delete-overlay overlay)))
598 0 : (setq overlays (cdr overlays)))))
599 :
600 : (defun image-search-load-path (file &optional path)
601 0 : (unless path
602 0 : (setq path image-load-path))
603 0 : (let (element found filename)
604 0 : (while (and (not found) (consp path))
605 0 : (setq element (car path))
606 0 : (cond
607 0 : ((stringp element)
608 0 : (setq found
609 0 : (file-readable-p
610 0 : (setq filename (expand-file-name file element)))))
611 0 : ((and (symbolp element) (boundp element))
612 0 : (setq element (symbol-value element))
613 0 : (cond
614 0 : ((stringp element)
615 0 : (setq found
616 0 : (file-readable-p
617 0 : (setq filename (expand-file-name file element)))))
618 0 : ((consp element)
619 0 : (if (setq filename (image-search-load-path file element))
620 0 : (setq found t))))))
621 0 : (setq path (cdr path)))
622 0 : (if found filename)))
623 :
624 : ;;;###autoload
625 : (defun find-image (specs)
626 : "Find an image, choosing one of a list of image specifications.
627 :
628 : SPECS is a list of image specifications.
629 :
630 : Each image specification in SPECS is a property list. The contents of
631 : a specification are image type dependent. All specifications must at
632 : least contain the properties `:type TYPE' and either `:file FILE' or
633 : `:data DATA', where TYPE is a symbol specifying the image type,
634 : e.g. `xbm', FILE is the file to load the image from, and DATA is a
635 : string containing the actual image data. The specification whose TYPE
636 : is supported, and FILE exists, is used to construct the image
637 : specification to be returned. Return nil if no specification is
638 : satisfied.
639 :
640 : The image is looked for in `image-load-path'.
641 :
642 : Image files should not be larger than specified by `max-image-size'."
643 0 : (let (image)
644 0 : (while (and specs (null image))
645 0 : (let* ((spec (car specs))
646 0 : (type (plist-get spec :type))
647 0 : (data (plist-get spec :data))
648 0 : (file (plist-get spec :file))
649 : found)
650 0 : (when (image-type-available-p type)
651 0 : (cond ((stringp file)
652 0 : (if (setq found (image-search-load-path file))
653 0 : (setq image
654 0 : (cons 'image (plist-put (copy-sequence spec)
655 0 : :file found)))))
656 0 : ((not (null data))
657 0 : (setq image (cons 'image spec)))))
658 0 : (setq specs (cdr specs))))
659 0 : image))
660 :
661 :
662 : ;;;###autoload
663 : (defmacro defimage (symbol specs &optional doc)
664 : "Define SYMBOL as an image, and return SYMBOL.
665 :
666 : SPECS is a list of image specifications. DOC is an optional
667 : documentation string.
668 :
669 : Each image specification in SPECS is a property list. The contents of
670 : a specification are image type dependent. All specifications must at
671 : least contain the properties `:type TYPE' and either `:file FILE' or
672 : `:data DATA', where TYPE is a symbol specifying the image type,
673 : e.g. `xbm', FILE is the file to load the image from, and DATA is a
674 : string containing the actual image data. The first image
675 : specification whose TYPE is supported, and FILE exists, is used to
676 : define SYMBOL.
677 :
678 : Example:
679 :
680 : (defimage test-image ((:type xpm :file \"~/test1.xpm\")
681 : (:type xbm :file \"~/test1.xbm\")))"
682 : (declare (doc-string 3))
683 0 : `(defvar ,symbol (find-image ',specs) ,doc))
684 :
685 :
686 : ;;; Animated image API
687 :
688 : (defvar image-default-frame-delay 0.1
689 : "Default interval in seconds between frames of a multi-frame image.
690 : Only used if the image does not specify a value.")
691 :
692 : (defun image-multi-frame-p (image)
693 : "Return non-nil if IMAGE contains more than one frame.
694 : The actual return value is a cons (NIMAGES . DELAY), where NIMAGES is
695 : the number of frames (or sub-images) in the image and DELAY is the delay
696 : in seconds that the image specifies between each frame. DELAY may be nil,
697 : in which case you might want to use `image-default-frame-delay'."
698 0 : (when (fboundp 'image-metadata)
699 0 : (let* ((metadata (image-metadata image))
700 0 : (images (plist-get metadata 'count))
701 0 : (delay (plist-get metadata 'delay)))
702 0 : (when (and images (> images 1))
703 0 : (and delay (or (not (numberp delay)) (< delay 0))
704 0 : (setq delay image-default-frame-delay))
705 0 : (cons images delay)))))
706 :
707 : (defun image-animated-p (image)
708 : "Like `image-multi-frame-p', but returns nil if no delay is specified."
709 0 : (let ((multi (image-multi-frame-p image)))
710 0 : (and (cdr multi) multi)))
711 :
712 : (make-obsolete 'image-animated-p 'image-multi-frame-p "24.4")
713 :
714 : ;; "Destructively"?
715 : (defun image-animate (image &optional index limit)
716 : "Start animating IMAGE.
717 : Animation occurs by destructively altering the IMAGE spec list.
718 :
719 : With optional INDEX, begin animating from that animation frame.
720 : LIMIT specifies how long to animate the image. If omitted or
721 : nil, play the animation until the end. If t, loop forever. If a
722 : number, play until that number of seconds has elapsed."
723 0 : (let ((animation (image-multi-frame-p image))
724 : timer)
725 0 : (when animation
726 0 : (if (setq timer (image-animate-timer image))
727 0 : (cancel-timer timer))
728 0 : (plist-put (cdr image) :animate-buffer (current-buffer))
729 0 : (run-with-timer 0.2 nil #'image-animate-timeout
730 0 : image (or index 0) (car animation)
731 0 : 0 limit (+ (float-time) 0.2)))))
732 :
733 : (defun image-animate-timer (image)
734 : "Return the animation timer for image IMAGE."
735 : ;; See cancel-function-timers
736 0 : (let ((tail timer-list) timer)
737 0 : (while tail
738 0 : (setq timer (car tail)
739 0 : tail (cdr tail))
740 0 : (if (and (eq (timer--function timer) #'image-animate-timeout)
741 0 : (eq (car-safe (timer--args timer)) image))
742 0 : (setq tail nil)
743 0 : (setq timer nil)))
744 0 : timer))
745 :
746 : (defconst image-minimum-frame-delay 0.01
747 : "Minimum interval in seconds between frames of an animated image.")
748 :
749 : (defun image-current-frame (image)
750 : "The current frame number of IMAGE, indexed from 0."
751 0 : (or (plist-get (cdr image) :index) 0))
752 :
753 : (defun image-show-frame (image n &optional nocheck)
754 : "Show frame N of IMAGE.
755 : Frames are indexed from 0. Optional argument NOCHECK non-nil means
756 : do not check N is within the range of frames present in the image."
757 0 : (unless nocheck
758 0 : (if (< n 0) (setq n 0)
759 0 : (setq n (min n (1- (car (image-multi-frame-p image)))))))
760 0 : (plist-put (cdr image) :index n)
761 0 : (force-window-update))
762 :
763 : (defun image-animate-get-speed (image)
764 : "Return the speed factor for animating IMAGE."
765 0 : (or (plist-get (cdr image) :speed) 1))
766 :
767 : (defun image-animate-set-speed (image value &optional multiply)
768 : "Set the speed factor for animating IMAGE to VALUE.
769 : With optional argument MULTIPLY non-nil, treat VALUE as a
770 : multiplication factor for the current value."
771 0 : (plist-put (cdr image) :speed
772 0 : (if multiply
773 0 : (* value (image-animate-get-speed image))
774 0 : value)))
775 :
776 : ;; FIXME? The delay may not be the same for different sub-images,
777 : ;; hence we need to call image-multi-frame-p to return it.
778 : ;; But it also returns count, so why do we bother passing that as an
779 : ;; argument?
780 : (defun image-animate-timeout (image n count time-elapsed limit target-time)
781 : "Display animation frame N of IMAGE.
782 : N=0 refers to the initial animation frame.
783 : COUNT is the total number of frames in the animation.
784 : TIME-ELAPSED is the total time that has elapsed since
785 : `image-animate-start' was called.
786 : LIMIT determines when to stop. If t, loop forever. If nil, stop
787 : after displaying the last animation frame. Otherwise, stop
788 : after LIMIT seconds have elapsed.
789 : The minimum delay between successive frames is `image-minimum-frame-delay'.
790 :
791 : If the image has a non-nil :speed property, it acts as a multiplier
792 : for the animation speed. A negative value means to animate in reverse."
793 0 : (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer))
794 : ;; Delayed more than two seconds more than expected.
795 0 : (or (<= (- (float-time) target-time) 2)
796 0 : (progn
797 0 : (message "Stopping animation; animation possibly too big")
798 0 : nil)))
799 0 : (image-show-frame image n t)
800 0 : (let* ((speed (image-animate-get-speed image))
801 0 : (time (float-time))
802 0 : (animation (image-multi-frame-p image))
803 : ;; Subtract off the time we took to load the image from the
804 : ;; stated delay time.
805 0 : (delay (max (+ (* (or (cdr animation) image-default-frame-delay)
806 0 : (/ 1.0 (abs speed)))
807 0 : time (- (float-time)))
808 0 : image-minimum-frame-delay))
809 : done)
810 0 : (setq n (if (< speed 0)
811 0 : (1- n)
812 0 : (1+ n)))
813 0 : (if limit
814 0 : (cond ((>= n count) (setq n 0))
815 0 : ((< n 0) (setq n (1- count))))
816 0 : (and (or (>= n count) (< n 0)) (setq done t)))
817 0 : (setq time-elapsed (+ delay time-elapsed))
818 0 : (if (numberp limit)
819 0 : (setq done (>= time-elapsed limit)))
820 0 : (unless done
821 0 : (run-with-timer delay nil #'image-animate-timeout
822 0 : image n count time-elapsed limit
823 0 : (+ (float-time) delay))))))
824 :
825 :
826 : (defvar imagemagick-types-inhibit)
827 : (defvar imagemagick-enabled-types)
828 :
829 : (defun imagemagick-filter-types ()
830 : "Return a list of the ImageMagick types to be treated as images, or nil.
831 : This is the result of `imagemagick-types', including only elements
832 : that match `imagemagick-enabled-types' and do not match
833 : `imagemagick-types-inhibit'."
834 0 : (when (fboundp 'imagemagick-types)
835 0 : (cond ((null imagemagick-enabled-types) nil)
836 0 : ((eq imagemagick-types-inhibit t) nil)
837 : (t
838 0 : (delq nil
839 0 : (mapcar
840 : (lambda (type)
841 0 : (unless (memq type imagemagick-types-inhibit)
842 0 : (if (eq imagemagick-enabled-types t) type
843 0 : (catch 'found
844 0 : (dolist (enable imagemagick-enabled-types nil)
845 0 : (if (cond ((symbolp enable) (eq enable type))
846 0 : ((stringp enable)
847 0 : (string-match enable
848 0 : (symbol-name type))))
849 0 : (throw 'found type)))))))
850 0 : (imagemagick-types)))))))
851 :
852 : (defvar imagemagick--file-regexp nil
853 : "File extension regexp for ImageMagick files, if any.
854 : This is the extension installed into `auto-mode-alist' and
855 : `image-type-file-name-regexps' by `imagemagick-register-types'.")
856 :
857 : ;;;###autoload
858 : (defun imagemagick-register-types ()
859 : "Register file types that can be handled by ImageMagick.
860 : This function is called at startup, after loading the init file.
861 : It registers the ImageMagick types returned by `imagemagick-filter-types'.
862 :
863 : Registered image types are added to `auto-mode-alist', so that
864 : Emacs visits them in Image mode. They are also added to
865 : `image-type-file-name-regexps', so that the `image-type' function
866 : recognizes these files as having image type `imagemagick'.
867 :
868 : If Emacs is compiled without ImageMagick support, this does nothing."
869 1 : (when (fboundp 'imagemagick-types)
870 0 : (let* ((types (mapcar (lambda (type) (downcase (symbol-name type)))
871 0 : (imagemagick-filter-types)))
872 0 : (re (if types (concat "\\." (regexp-opt types) "\\'")))
873 0 : (ama-elt (car (member (cons imagemagick--file-regexp 'image-mode)
874 0 : auto-mode-alist)))
875 0 : (itfnr-elt (car (member (cons imagemagick--file-regexp 'imagemagick)
876 0 : image-type-file-name-regexps))))
877 0 : (if (not re)
878 0 : (setq auto-mode-alist (delete ama-elt auto-mode-alist)
879 : image-type-file-name-regexps
880 0 : (delete itfnr-elt image-type-file-name-regexps))
881 0 : (if ama-elt
882 0 : (setcar ama-elt re)
883 0 : (push (cons re 'image-mode) auto-mode-alist))
884 0 : (if itfnr-elt
885 0 : (setcar itfnr-elt re)
886 : ;; Append to `image-type-file-name-regexps', so that we
887 : ;; preferentially use specialized image libraries.
888 0 : (add-to-list 'image-type-file-name-regexps
889 0 : (cons re 'imagemagick) t)))
890 1 : (setq imagemagick--file-regexp re))))
891 :
892 : (defcustom imagemagick-types-inhibit
893 : '(C HTML HTM INFO M TXT PDF)
894 : "List of ImageMagick types that should never be treated as images.
895 : This should be a list of symbols, each of which should be one of
896 : the ImageMagick types listed by `imagemagick-types'. The listed
897 : image types are not registered by `imagemagick-register-types'.
898 :
899 : If the value is t, inhibit the use of ImageMagick for images.
900 :
901 : If you change this without using customize, you must call
902 : `imagemagick-register-types' afterwards.
903 :
904 : If Emacs is compiled without ImageMagick support, this variable
905 : has no effect."
906 : :type '(choice (const :tag "Support all ImageMagick types" nil)
907 : (const :tag "Disable all ImageMagick types" t)
908 : (repeat symbol))
909 : :initialize #'custom-initialize-default
910 : :set (lambda (symbol value)
911 : (set-default symbol value)
912 : (imagemagick-register-types))
913 : :version "24.3")
914 :
915 : (defcustom imagemagick-enabled-types
916 : '(3FR ART ARW AVS BMP BMP2 BMP3 CAL CALS CMYK CMYKA CR2 CRW
917 : CUR CUT DCM DCR DCX DDS DJVU DNG DPX EXR FAX FITS GBR GIF
918 : GIF87 GRB HRZ ICB ICO ICON J2C JNG JP2 JPC JPEG JPG JPX K25
919 : KDC MIFF MNG MRW MSL MSVG MTV NEF ORF OTB PBM PCD PCDS PCL
920 : PCT PCX PDB PEF PGM PICT PIX PJPEG PNG PNG24 PNG32 PNG8 PNM
921 : PPM PSD PTIF PWP RAF RAS RBG RGB RGBA RGBO RLA RLE SCR SCT
922 : SFW SGI SR2 SRF SUN SVG SVGZ TGA TIFF TIFF64 TILE TIM TTF
923 : UYVY VDA VICAR VID VIFF VST WBMP WPG X3F XBM XC XCF XPM XV
924 : XWD YCbCr YCbCrA YUV)
925 : "List of ImageMagick types to treat as images.
926 : Each list element should be a string or symbol, representing one
927 : of the image types returned by `imagemagick-types'. If the
928 : element is a string, it is handled as a regexp that enables all
929 : matching types.
930 :
931 : The value of `imagemagick-enabled-types' may also be t, meaning
932 : to enable all types that ImageMagick supports.
933 :
934 : The variable `imagemagick-types-inhibit' overrides this variable.
935 :
936 : If you change this without using customize, you must call
937 : `imagemagick-register-types' afterwards.
938 :
939 : If Emacs is compiled without ImageMagick support, this variable
940 : has no effect."
941 : :type '(choice (const :tag "Support all ImageMagick types" t)
942 : (const :tag "Disable all ImageMagick types" nil)
943 : (repeat :tag "List of types"
944 : (choice (symbol :tag "type")
945 : (regexp :tag "regexp"))))
946 : :initialize #'custom-initialize-default
947 : :set (lambda (symbol value)
948 : (set-default symbol value)
949 : (imagemagick-register-types))
950 : :version "24.3")
951 :
952 : (imagemagick-register-types)
953 :
954 : (defun image-increase-size (n)
955 : "Increase the image size by a factor of N.
956 : If N is 3, then the image size will be increased by 30%. The
957 : default is 20%."
958 : (interactive "P")
959 0 : (image--change-size (if n
960 0 : (1+ (/ n 10.0))
961 0 : 1.2)))
962 :
963 : (defun image-decrease-size (n)
964 : "Decrease the image size by a factor of N.
965 : If N is 3, then the image size will be decreased by 30%. The
966 : default is 20%."
967 : (interactive "P")
968 0 : (image--change-size (if n
969 0 : (- 1 (/ n 10.0))
970 0 : 0.8)))
971 :
972 : (defun image--get-image ()
973 0 : (let ((image (get-text-property (point) 'display)))
974 0 : (unless (eq (car-safe image) 'image)
975 0 : (error "No image under point"))
976 0 : image))
977 :
978 : (defun image--get-imagemagick-and-warn ()
979 0 : (unless (fboundp 'imagemagick-types)
980 0 : (error "Can't rescale images without ImageMagick support"))
981 0 : (let ((image (image--get-image)))
982 0 : (image-flush image)
983 0 : (plist-put (cdr image) :type 'imagemagick)
984 0 : image))
985 :
986 : (defun image--change-size (factor)
987 0 : (let* ((image (image--get-imagemagick-and-warn))
988 0 : (new-image (image--image-without-parameters image))
989 0 : (scale (image--current-scaling image new-image)))
990 0 : (setcdr image (cdr new-image))
991 0 : (plist-put (cdr image) :scale (* scale factor))))
992 :
993 : (defun image--image-without-parameters (image)
994 0 : (cons (pop image)
995 0 : (let ((new nil))
996 0 : (while image
997 0 : (let ((key (pop image))
998 0 : (val (pop image)))
999 0 : (unless (memq key '(:scale :width :height :max-width :max-height))
1000 0 : (setq new (nconc new (list key val))))))
1001 0 : new)))
1002 :
1003 : (defun image--current-scaling (image new-image)
1004 : ;; The image may be scaled due to many reasons (:scale, :max-width,
1005 : ;; etc), so find out what the current scaling is based on the
1006 : ;; original image size and the displayed size.
1007 0 : (let ((image-width (car (image-size new-image t)))
1008 0 : (display-width (car (image-size image t))))
1009 0 : (/ (float display-width) image-width)))
1010 :
1011 : (defun image-rotate ()
1012 : "Rotate the image under point by 90 degrees clockwise."
1013 : (interactive)
1014 0 : (let ((image (image--get-imagemagick-and-warn)))
1015 0 : (plist-put (cdr image) :rotation
1016 0 : (float (mod (+ (or (plist-get (cdr image) :rotation) 0) 90)
1017 : ;; We don't want to exceed 360 degrees
1018 : ;; rotation, because it's not seen as valid
1019 : ;; in exif data.
1020 0 : 360)))))
1021 :
1022 : (defun image-save ()
1023 : "Save the image under point."
1024 : (interactive)
1025 0 : (let ((image (get-text-property (point) 'display)))
1026 0 : (when (or (not (consp image))
1027 0 : (not (eq (car image) 'image)))
1028 0 : (error "No image under point"))
1029 0 : (with-temp-buffer
1030 0 : (let ((file (plist-get (cdr image) :file)))
1031 0 : (if file
1032 0 : (if (not (file-exists-p file))
1033 0 : (error "File %s no longer exists" file)
1034 0 : (insert-file-contents-literally file))
1035 0 : (insert (plist-get (cdr image) :data))))
1036 0 : (write-region (point-min) (point-max)
1037 0 : (read-file-name "Write image to file: ")))))
1038 :
1039 : (provide 'image)
1040 :
1041 : ;;; image.el ends here
|