lisp/image.el

   1 ;;; image.el --- image API  -*- lexical-binding:t -*-
   2
   3 ;; Copyright (C) 1998-2016 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-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 "25.2")
 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   (unless library (error "No library specified"))
 180   (unless image   (error "No image specified"))
 181   (let (image-directory image-directory-load-path)
 182     ;; Check for images in image-load-path or load-path.
 183     (let ((img image)
 184           (dir (or
 185                 ;; Images in image-load-path.
 186                 (image-search-load-path image)
 187                 ;; Images in load-path.
 188                 (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       (when dir
 194         (setq dir (file-name-directory dir))
 195         (while (setq parent (file-name-directory img))
 196           (setq img (directory-file-name parent)
 197                 dir (expand-file-name "../" dir))))
 198       (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     (cond
 205      ;; User-modified image-load-path?
 206      ((and image-directory-load-path
 207            (not (equal image-directory-load-path
 208                        (file-name-as-directory
 209                         (expand-file-name "images" data-directory)))))
 210       (setq image-directory image-directory-load-path))
 211      ;; Try relative setting.
 212      ((let (library-name d1ei d2ei)
 213         ;; First, find library in the load-path.
 214         (setq library-name (locate-library library))
 215         (if (not library-name)
 216             (error "Cannot find library %s in load-path" library))
 217         ;; And then set image-directory relative to that.
 218         (setq
 219          ;; Go down 2 levels.
 220          d2ei (file-name-as-directory
 221                (expand-file-name
 222                 (concat (file-name-directory library-name) "../../etc/images")))
 223          ;; Go down 1 level.
 224          d1ei (file-name-as-directory
 225                (expand-file-name
 226                 (concat (file-name-directory library-name) "../etc/images"))))
 227         (setq image-directory
 228               ;; Set it to nil if image is not found.
 229               (cond ((file-exists-p (expand-file-name image d2ei)) d2ei)
 230                     ((file-exists-p (expand-file-name image d1ei)) d1ei)))))
 231      ;; Use Emacs's image directory.
 232      (image-directory-load-path
 233       (setq image-directory image-directory-load-path))
 234      (no-error
 235       (message "Could not find image %s for library %s" image library))
 236      (t
 237       (error "Could not find image %s for library %s" image library)))
 238
 239     ;; Return an augmented `path' or `load-path'.
 240     (nconc (list image-directory)
 241            (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   (setq data (ignore-errors (string-to-unibyte data)))
 250   (when (and data (string-match-p "\\`\xff\xd8" data))
 251     (catch 'jfif
 252       (let ((len (length data)) (i 2))
 253         (while (< i len)
 254           (when (/= (aref data i) #xff)
 255             (throw 'jfif nil))
 256           (setq i (1+ i))
 257           (when (>= (+ i 2) len)
 258             (throw 'jfif nil))
 259           (let ((nbytes (+ (lsh (aref data (+ i 1)) 8)
 260                            (aref data (+ i 2))))
 261                 (code (aref data i)))
 262             (when (and (>= code #xe0) (<= code #xef))
 263               ;; APP0 LEN1 LEN2 "JFIF\0"
 264               (throw 'jfif
 265                      (string-match-p "JFIF\\|Exif"
 266                                      (substring data i (min (+ i nbytes) len)))))
 267             (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   (let ((types image-type-header-regexps)
 276         type)
 277     (while types
 278       (let ((regexp (car (car types)))
 279             (image-type (cdr (car types))))
 280         (if (or (and (symbolp image-type)
 281                      (string-match-p regexp data))
 282                 (and (consp image-type)
 283                      (funcall (car image-type) data)
 284                      (setq image-type (cdr image-type))))
 285             (setq type image-type
 286                   types nil)
 287           (setq types (cdr types)))))
 288     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   (let ((types image-type-header-regexps)
 297         type
 298         (opoint (point)))
 299     (goto-char (point-min))
 300     (while types
 301       (let ((regexp (car (car types)))
 302             (image-type (cdr (car types)))
 303             data)
 304         (if (or (and (symbolp image-type)
 305                      (looking-at-p regexp))
 306                 (and (consp image-type)
 307                      (funcall (car image-type)
 308                               (or data
 309                                   (setq data
 310                                         (buffer-substring
 311                                          (point-min)
 312                                          (min (point-max)
 313                                               (+ (point-min) 256))))))
 314                      (setq image-type (cdr image-type))))
 315             (setq type image-type
 316                   types nil)
 317           (setq types (cdr types)))))
 318     (goto-char opoint)
 319     (and type
 320          (boundp 'image-types)
 321          (memq type image-types)
 322          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   (unless (or (file-readable-p file)
 331               (file-name-absolute-p file))
 332     (setq file (image-search-load-path file)))
 333   (and file
 334        (file-readable-p file)
 335        (with-temp-buffer
 336          (set-buffer-multibyte nil)
 337          (insert-file-contents-literally file nil 0 256)
 338          (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   (let (type first)
 347     (catch 'found
 348       (dolist (elem image-type-file-name-regexps first)
 349         (when (string-match-p (car elem) file)
 350           (if (image-type-available-p (setq type (cdr elem)))
 351               (throw 'found type)
 352             ;; If nothing seems to be supported, return first type that matched.
 353             (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   (when (and (not data-p) (not (stringp source)))
 365     (error "Invalid image file name `%s'" source))
 366   (unless type
 367     (setq type (if data-p
 368                    (image-type-from-data source)
 369                  (or (image-type-from-file-header source)
 370                      (image-type-from-file-name source))))
 371     (or type (error "Cannot determine image type")))
 372   (or (memq type (and (boundp 'image-types) image-types))
 373       (error "Invalid image type `%s'" type))
 374   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   (and (fboundp 'init-image-library)
 390        (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   (let* ((type (image-type-from-buffer))
 404          (auto (and type (cdr (assq type image-type-auto-detectable)))))
 405     (and auto
 406          (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   (setq type (image-type file-or-data type data-p))
 429   (when (image-type-available-p type)
 430     (append (list 'image :type type (if data-p :data :file) file-or-data)
 431             (and (not (plist-get props :scale))
 432                  (list :scale
 433                        (image-compute-scaling-factor image-scaling-factor)))
 434             props)))
 435
 436 (defun image--set-property (image property value)
 437   "Set PROPERTY in IMAGE to VALUE.
 438 Internal use only."
 439   (if (null value)
 440       (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         (if (eq (cadr image) property)
 445             (setcdr image (cddr image))
 446           (setq image (cddr image))))
 447     ;; Just enter the new value.
 448     (plist-put (cdr image) property value))
 449   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   (plist-get (cdr image) property))
 459
 460 (defun image-compute-scaling-factor (scaling)
 461   (cond
 462    ((numberp scaling) scaling)
 463    ((eq scaling 'auto)
 464     (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       (if (< width 10)
 469           1
 470         (/ (float width) 10))))
 471    (t
 472     (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   (unless string (setq string "x"))
 488   (let ((buffer (current-buffer)))
 489     (unless (eq (car-safe image) 'image)
 490       (error "Not an image: %s" image))
 491     (unless (or (null area) (memq area '(left-margin right-margin)))
 492       (error "Invalid area %s" area))
 493     (setq string (copy-sequence string))
 494     (let ((overlay (make-overlay pos pos buffer))
 495           (prop (if (null area) image (list (list 'margin area) image))))
 496       (put-text-property 0 (length string) 'display prop string)
 497       (overlay-put overlay 'put-image t)
 498       (overlay-put overlay 'before-string string)
 499       (overlay-put overlay 'map image-map)
 500       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   (unless string (setq string " "))
 521   (unless (eq (car-safe image) 'image)
 522     (error "Not an image: %s" image))
 523   (unless (or (null area) (memq area '(left-margin right-margin)))
 524     (error "Invalid area %s" area))
 525   (if area
 526       (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     (setq image (cons 'image (cdr image))))
 534   (let ((start (point)))
 535     (insert string)
 536     (add-text-properties start (point)
 537                          `(display ,(if slice
 538                                         (list (cons 'slice slice) image)
 539                                       image)
 540                                    rear-nonsticky (display)
 541                                    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   (unless string (setq string " "))
 556   (unless (eq (car-safe image) 'image)
 557     (error "Not an image: %s" image))
 558   (unless (or (null area) (memq area '(left-margin right-margin)))
 559     (error "Invalid area %s" area))
 560   (if area
 561       (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     (setq image (cons 'image (cdr image))))
 569   (let ((x 0.0) (dx (/ 1.0001 (or cols 1)))
 570          (y 0.0) (dy (/ 1.0001 (or rows 1))))
 571     (while (< y 1.0)
 572       (while (< x 1.0)
 573         (let ((start (point)))
 574           (insert string)
 575           (add-text-properties start (point)
 576                                `(display ,(list (list 'slice x y dx dy) image)
 577                                          rear-nonsticky (display)
 578                                          keymap ,image-map))
 579           (setq x (+ x dx))))
 580       (setq x 0.0
 581             y (+ y dy))
 582       (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   (unless buffer
 592     (setq buffer (current-buffer)))
 593   (let ((overlays (overlays-in start end)))
 594     (while overlays
 595       (let ((overlay (car overlays)))
 596         (when (overlay-get overlay 'put-image)
 597           (delete-overlay overlay)))
 598       (setq overlays (cdr overlays)))))
 599
 600 (defun image-search-load-path (file &optional path)
 601   (unless path
 602     (setq path image-load-path))
 603   (let (element found filename)
 604     (while (and (not found) (consp path))
 605       (setq element (car path))
 606       (cond
 607        ((stringp element)
 608         (setq found
 609               (file-readable-p
 610                (setq filename (expand-file-name file element)))))
 611        ((and (symbolp element) (boundp element))
 612         (setq element (symbol-value element))
 613         (cond
 614          ((stringp element)
 615           (setq found
 616                 (file-readable-p
 617                  (setq filename (expand-file-name file element)))))
 618          ((consp element)
 619           (if (setq filename (image-search-load-path file element))
 620               (setq found t))))))
 621       (setq path (cdr path)))
 622     (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   (let (image)
 644     (while (and specs (null image))
 645       (let* ((spec (car specs))
 646              (type (plist-get spec :type))
 647              (data (plist-get spec :data))
 648              (file (plist-get spec :file))
 649              found)
 650         (when (image-type-available-p type)
 651           (cond ((stringp file)
 652                  (if (setq found (image-search-load-path file))
 653                      (setq image
 654                            (cons 'image (plist-put (copy-sequence spec)
 655                                                    :file found)))))
 656                 ((not (null data))
 657                  (setq image (cons 'image spec)))))
 658         (setq specs (cdr specs))))
 659     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   `(defvar ,symbol (find-image ',specs) ,doc))
 684
 685 \f
 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   (when (fboundp 'image-metadata)
 699     (let* ((metadata (image-metadata image))
 700            (images (plist-get metadata 'count))
 701            (delay (plist-get metadata 'delay)))
 702       (when (and images (> images 1))
 703         (and delay (or (not (numberp delay)) (< delay 0))
 704              (setq delay image-default-frame-delay))
 705         (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   (let ((multi (image-multi-frame-p image)))
 710     (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   (let ((animation (image-multi-frame-p image))
 724         timer)
 725     (when animation
 726       (if (setq timer (image-animate-timer image))
 727           (cancel-timer timer))
 728       (plist-put (cdr image) :animate-buffer (current-buffer))
 729       (run-with-timer 0.2 nil #'image-animate-timeout
 730                       image (or index 0) (car animation)
 731                       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   (let ((tail timer-list) timer)
 737     (while tail
 738       (setq timer (car tail)
 739             tail (cdr tail))
 740       (if (and (eq (timer--function timer) #'image-animate-timeout)
 741                (eq (car-safe (timer--args timer)) image))
 742           (setq tail nil)
 743         (setq timer nil)))
 744     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   (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   (unless nocheck
 758     (if (< n 0) (setq n 0)
 759       (setq n (min n (1- (car (image-multi-frame-p image)))))))
 760   (plist-put (cdr image) :index n)
 761   (force-window-update))
 762
 763 (defun image-animate-get-speed (image)
 764   "Return the speed factor for animating IMAGE."
 765   (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   (plist-put (cdr image) :speed
 772              (if multiply
 773                  (* value (image-animate-get-speed image))
 774                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   (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer))
 794              ;; Delayed more than two seconds more than expected.
 795              (when (> (- (float-time) target-time) 2)
 796                (message "Stopping animation; animation possibly too big")
 797                nil))
 798     (image-show-frame image n t)
 799     (let* ((speed (image-animate-get-speed image))
 800            (time (float-time))
 801            (animation (image-multi-frame-p image))
 802            ;; Subtract off the time we took to load the image from the
 803            ;; stated delay time.
 804            (delay (max (+ (* (or (cdr animation) image-default-frame-delay)
 805                              (/ 1.0 (abs speed)))
 806                           time (- (float-time)))
 807                        image-minimum-frame-delay))
 808            done)
 809       (setq n (if (< speed 0)
 810                   (1- n)
 811                 (1+ n)))
 812       (if limit
 813           (cond ((>= n count) (setq n 0))
 814                 ((< n 0) (setq n (1- count))))
 815         (and (or (>= n count) (< n 0)) (setq done t)))
 816       (setq time-elapsed (+ delay time-elapsed))
 817       (if (numberp limit)
 818           (setq done (>= time-elapsed limit)))
 819       (unless done
 820         (run-with-timer delay nil #'image-animate-timeout
 821                         image n count time-elapsed limit
 822                         (+ (float-time) delay))))))
 823
 824 \f
 825 (defvar imagemagick-types-inhibit)
 826 (defvar imagemagick-enabled-types)
 827
 828 (defun imagemagick-filter-types ()
 829   "Return a list of the ImageMagick types to be treated as images, or nil.
 830 This is the result of `imagemagick-types', including only elements
 831 that match `imagemagick-enabled-types' and do not match
 832 `imagemagick-types-inhibit'."
 833   (when (fboundp 'imagemagick-types)
 834     (cond ((null imagemagick-enabled-types) nil)
 835           ((eq imagemagick-types-inhibit t) nil)
 836           (t
 837            (delq nil
 838                  (mapcar
 839                   (lambda (type)
 840                     (unless (memq type imagemagick-types-inhibit)
 841                       (if (eq imagemagick-enabled-types t) type
 842                         (catch 'found
 843                           (dolist (enable imagemagick-enabled-types nil)
 844                             (if (cond ((symbolp enable) (eq enable type))
 845                                       ((stringp enable)
 846                                        (string-match enable
 847                                                      (symbol-name type))))
 848                                 (throw 'found type)))))))
 849                   (imagemagick-types)))))))
 850
 851 (defvar imagemagick--file-regexp nil
 852   "File extension regexp for ImageMagick files, if any.
 853 This is the extension installed into `auto-mode-alist' and
 854 `image-type-file-name-regexps' by `imagemagick-register-types'.")
 855
 856 ;;;###autoload
 857 (defun imagemagick-register-types ()
 858   "Register file types that can be handled by ImageMagick.
 859 This function is called at startup, after loading the init file.
 860 It registers the ImageMagick types returned by `imagemagick-filter-types'.
 861
 862 Registered image types are added to `auto-mode-alist', so that
 863 Emacs visits them in Image mode.  They are also added to
 864 `image-type-file-name-regexps', so that the `image-type' function
 865 recognizes these files as having image type `imagemagick'.
 866
 867 If Emacs is compiled without ImageMagick support, this does nothing."
 868   (when (fboundp 'imagemagick-types)
 869     (let* ((types (mapcar (lambda (type) (downcase (symbol-name type)))
 870                           (imagemagick-filter-types)))
 871            (re (if types (concat "\\." (regexp-opt types) "\\'")))
 872            (ama-elt (car (member (cons imagemagick--file-regexp 'image-mode)
 873                                  auto-mode-alist)))
 874            (itfnr-elt (car (member (cons imagemagick--file-regexp 'imagemagick)
 875                                    image-type-file-name-regexps))))
 876       (if (not re)
 877           (setq auto-mode-alist (delete ama-elt auto-mode-alist)
 878                 image-type-file-name-regexps
 879                 (delete itfnr-elt image-type-file-name-regexps))
 880         (if ama-elt
 881             (setcar ama-elt re)
 882           (push (cons re 'image-mode) auto-mode-alist))
 883         (if itfnr-elt
 884             (setcar itfnr-elt re)
 885           ;; Append to `image-type-file-name-regexps', so that we
 886           ;; preferentially use specialized image libraries.
 887           (add-to-list 'image-type-file-name-regexps
 888                        (cons re 'imagemagick) t)))
 889       (setq imagemagick--file-regexp re))))
 890
 891 (defcustom imagemagick-types-inhibit
 892   '(C HTML HTM INFO M TXT PDF)
 893   "List of ImageMagick types that should never be treated as images.
 894 This should be a list of symbols, each of which should be one of
 895 the ImageMagick types listed by `imagemagick-types'.  The listed
 896 image types are not registered by `imagemagick-register-types'.
 897
 898 If the value is t, inhibit the use of ImageMagick for images.
 899
 900 If you change this without using customize, you must call
 901 `imagemagick-register-types' afterwards.
 902
 903 If Emacs is compiled without ImageMagick support, this variable
 904 has no effect."
 905   :type '(choice (const :tag "Support all ImageMagick types" nil)
 906                  (const :tag "Disable all ImageMagick types" t)
 907                  (repeat symbol))
 908   :initialize #'custom-initialize-default
 909   :set (lambda (symbol value)
 910          (set-default symbol value)
 911          (imagemagick-register-types))
 912   :version "24.3")
 913
 914 (defcustom imagemagick-enabled-types
 915   '(3FR ART ARW AVS BMP BMP2 BMP3 CAL CALS CMYK CMYKA CR2 CRW
 916     CUR CUT DCM DCR DCX DDS DJVU DNG DPX EXR FAX FITS GBR GIF
 917     GIF87 GRB HRZ ICB ICO ICON J2C JNG JP2 JPC JPEG JPG JPX K25
 918     KDC MIFF MNG MRW MSL MSVG MTV NEF ORF OTB PBM PCD PCDS PCL
 919     PCT PCX PDB PEF PGM PICT PIX PJPEG PNG PNG24 PNG32 PNG8 PNM
 920     PPM PSD PTIF PWP RAF RAS RBG RGB RGBA RGBO RLA RLE SCR SCT
 921     SFW SGI SR2 SRF SUN SVG SVGZ TGA TIFF TIFF64 TILE TIM TTF
 922     UYVY VDA VICAR VID VIFF VST WBMP WPG X3F XBM XC XCF XPM XV
 923     XWD YCbCr YCbCrA YUV)
 924   "List of ImageMagick types to treat as images.
 925 Each list element should be a string or symbol, representing one
 926 of the image types returned by `imagemagick-types'.  If the
 927 element is a string, it is handled as a regexp that enables all
 928 matching types.
 929
 930 The value of `imagemagick-enabled-types' may also be t, meaning
 931 to enable all types that ImageMagick supports.
 932
 933 The variable `imagemagick-types-inhibit' overrides this variable.
 934
 935 If you change this without using customize, you must call
 936 `imagemagick-register-types' afterwards.
 937
 938 If Emacs is compiled without ImageMagick support, this variable
 939 has no effect."
 940   :type '(choice (const :tag "Support all ImageMagick types" t)
 941                  (const :tag "Disable all ImageMagick types" nil)
 942                  (repeat :tag "List of types"
 943                          (choice (symbol :tag "type")
 944                                  (regexp :tag "regexp"))))
 945   :initialize #'custom-initialize-default
 946   :set (lambda (symbol value)
 947          (set-default symbol value)
 948          (imagemagick-register-types))
 949   :version "24.3")
 950
 951 (imagemagick-register-types)
 952
 953 (defun image-increase-size (n)
 954   "Increase the image size by a factor of N.
 955 If N is 3, then the image size will be increased by 30%.  The
 956 default is 20%."
 957   (interactive "P")
 958   (image--change-size (if n
 959                           (1+ (/ n 10))
 960                         1.2)))
 961
 962 (defun image-decrease-size (n)
 963   "Decrease the image size by a factor of N.
 964 If N is 3, then the image size will be decreased by 30%.  The
 965 default is 20%."
 966   (interactive "P")
 967   (image--change-size (if n
 968                           (- 1 (/ n 10))
 969                         0.8)))
 970
 971 (defun image--get-image ()
 972   (let ((image (get-text-property (point) 'display)))
 973     (unless (eq (car-safe image) 'image)
 974       (error "No image under point"))
 975     image))
 976
 977 (defun image--get-imagemagick-and-warn ()
 978   (unless (fboundp 'imagemagick-types)
 979     (error "Can't rescale images without ImageMagick support"))
 980   (let ((image (image--get-image)))
 981     (image-flush image)
 982     (plist-put (cdr image) :type 'imagemagick)
 983     image))
 984
 985 (defun image--change-size (factor)
 986   (let* ((image (image--get-imagemagick-and-warn))
 987          (new-image (image--image-without-parameters image))
 988          (scale (image--current-scaling image new-image)))
 989     (setcdr image (cdr new-image))
 990     (plist-put (cdr image) :scale (* scale factor))))
 991
 992 (defun image--image-without-parameters (image)
 993   (cons (pop image)
 994         (let ((new nil))
 995           (while image
 996             (let ((key (pop image))
 997                   (val (pop image)))
 998               (unless (memq key '(:scale :width :height :max-width :max-height))
 999               (setq new (nconc new (list key val))))))
1000           new)))
1001
1002 (defun image--current-scaling (image new-image)
1003   ;; The image may be scaled due to many reasons (:scale, :max-width,
1004   ;; etc), so find out what the current scaling is based on the
1005   ;; original image size and the displayed size.
1006   (let ((image-width (car (image-size new-image t)))
1007         (display-width (car (image-size image t))))
1008     (/ (float display-width) image-width)))
1009
1010 (defun image-rotate ()
1011   "Rotate the image under point by 90 degrees clockwise."
1012   (interactive)
1013   (let ((image (image--get-imagemagick-and-warn)))
1014     (plist-put (cdr image) :rotation
1015                (float (+ (or (plist-get (cdr image) :rotation) 0) 90)))))
1016
1017 (defun image-save ()
1018   "Save the image under point."
1019   (interactive)
1020   (let ((image (get-text-property (point) 'display)))
1021     (when (or (not (consp image))
1022               (not (eq (car image) 'image)))
1023       (error "No image under point"))
1024     (with-temp-buffer
1025       (let ((file (plist-get (cdr image) :file)))
1026         (if file
1027             (if (not (file-exists-p file))
1028                 (error "File %s no longer exists" file)
1029               (insert-file-contents-literally file))
1030           (insert (plist-get (cdr image) :data))))
1031       (write-region (point-min) (point-max)
1032                     (read-file-name "Write image to file: ")))))
1033
1034 (provide 'image)
1035
1036 ;;; image.el ends here