lisp/image.el

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