-;;; image.el --- image API
+;;; image.el --- image API -*- lexical-binding:t -*-
-;; Copyright (C) 1998-2013 Free Software Foundation, Inc.
+;; Copyright (C) 1998-2016 Free Software Foundation, Inc.
-;; Maintainer: FSF
+;; Maintainer: emacs-devel@gnu.org
;; Keywords: multimedia
;; Package: emacs
;;; Code:
-
(defgroup image ()
"Image support."
:group 'multimedia)
(defconst image-type-header-regexps
`(("\\`/[\t\n\r ]*\\*.*XPM.\\*/" . xpm)
- ("\\`P[1-6][[:space:]]+\\(?:#.*[[:space:]]+\\)*[0-9]+[[:space:]]+[0-9]+" . pbm)
+ ("\\`P[1-6]\\(?:\
+\\(?:\\(?:#[^\r\n]*[\r\n]\\)?[[:space:]]\\)+\
+\\(?:\\(?:#[^\r\n]*[\r\n]\\)?[0-9]\\)+\
+\\)\\{2\\}" . pbm)
("\\`GIF8[79]a" . gif)
("\\`\x89PNG\r\n\x1a\n" . png)
("\\`[\t\n\r ]*#define \\([a-z0-9_]+\\)_width [0-9]+\n\
(defvar image-format-suffixes
'((image/x-icon "ico"))
- "Alist of MIME Content-Type headers to file name suffixes.
+ "An alist associating image types with file name suffixes.
This is used as a hint by the ImageMagick library when detecting
-image types. If `create-image' is called with a :format
-matching found in this alist, the ImageMagick library will be
-told that the data would have this suffix if saved to a file.")
+the type of image data (that does not have an associated file name).
+Each element has the form (MIME-CONTENT-TYPE EXTENSION).
+If `create-image' is called with a :format attribute whose value
+equals a content-type found in this list, the ImageMagick library is
+told that the data would have the associated suffix if saved to a file.")
(defcustom image-load-path
(list (file-name-as-directory (expand-file-name "images" data-directory))
If an element is a variable symbol whose value is a string, that
value defines a directory to search.
If an element is a variable symbol whose value is a list, the
-value is used as a list of directories to search."
- :type '(repeat (choice directory variable))
- :initialize 'custom-initialize-delay)
+value is used as a list of directories to search.
+Subdirectories are not automatically included in the search."
+ :type '(repeat (choice directory variable))
+ :initialize #'custom-initialize-delay)
+
+(defcustom image-scaling-factor 'auto
+ "When displaying images, apply this scaling factor before displaying.
+This is not supported for all image types, and is mostly useful
+when you have a high-resolution monitor.
+The value is either a floating point number (where numbers higher
+than 1 means to increase the size and lower means to shrink the
+size), or the symbol `auto', which will compute a scaling factor
+based on the font pixel size."
+ :type '(choice number
+ (const :tag "Automatically compute" auto))
+ :version "25.2")
+
+;; Map put into text properties on images.
+(defvar image-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "-" 'image-decrease-size)
+ (define-key map "+" 'image-increase-size)
+ (define-key map "r" 'image-rotate)
+ (define-key map "o" 'image-save)
+ map))
(defun image-load-path-for-library (library image &optional path no-error)
"Return a suitable search path for images used by LIBRARY.
(let* ((load-path (image-load-path-for-library \"mh-e\" \"mh-logo.xpm\"))
(image-load-path (cons (car load-path)
- (when (boundp 'image-load-path)
+ (when (boundp \\='image-load-path)
image-load-path))))
(mh-tool-bar-folder-buttons-init))"
(unless library (error "No library specified"))
(setq types (cdr types)))))
(goto-char opoint)
(and type
+ (boundp 'image-types)
(memq type image-types)
type)))
(if (fboundp 'image-metadata) ; eg not --without-x
(define-obsolete-function-alias 'image-extension-data
- 'image-metadata' "24.1"))
+ 'image-metadata "24.1"))
(define-obsolete-variable-alias
'image-library-alist
(setq type (image-type file-or-data type data-p))
(when (image-type-available-p type)
(append (list 'image :type type (if data-p :data :file) file-or-data)
+ (and (not (plist-get props :scale))
+ (list :scale
+ (image-compute-scaling-factor image-scaling-factor)))
props)))
+(defun image--set-property (image property value)
+ "Set PROPERTY in IMAGE to VALUE.
+Internal use only."
+ (if (null value)
+ (while (cdr image)
+ ;; IMAGE starts with the symbol `image', and the rest is a
+ ;; plist. Decouple plist entries where the key matches
+ ;; the property.
+ (if (eq (cadr image) property)
+ (setcdr image (cddr image))
+ (setq image (cddr image))))
+ ;; Just enter the new value.
+ (plist-put (cdr image) property value))
+ value)
+
+(defun image-property (image property)
+ "Return the value of PROPERTY in IMAGE.
+Properties can be set with
+
+ (setf (image-property IMAGE PROPERTY) VALUE)
+If VALUE is nil, PROPERTY is removed from IMAGE."
+ (declare (gv-setter image--set-property))
+ (plist-get (cdr image) property))
+
+(defun image-compute-scaling-factor (scaling)
+ (cond
+ ((numberp scaling) scaling)
+ ((eq scaling 'auto)
+ (let ((width (/ (float (window-width nil t)) (window-width))))
+ ;; If we assume that a typical character is 10 pixels in width,
+ ;; then we should scale all images according to how wide they
+ ;; are. But don't scale images down.
+ (if (< width 10)
+ 1
+ (/ (float width) 10))))
+ (t
+ (error "Invalid scaling factor %s" scaling))))
;;;###autoload
(defun put-image (image pos &optional string area)
(put-text-property 0 (length string) 'display prop string)
(overlay-put overlay 'put-image t)
(overlay-put overlay 'before-string string)
+ (overlay-put overlay 'map image-map)
overlay)))
(add-text-properties start (point)
`(display ,(if slice
(list (cons 'slice slice) image)
- image) rear-nonsticky (display)))))
+ image)
+ rear-nonsticky (display)
+ keymap ,image-map))))
;;;###autoload
(insert string)
(add-text-properties start (point)
`(display ,(list (list 'slice x y dx dy) image)
- rear-nonsticky (display)))
+ rear-nonsticky (display)
+ keymap ,image-map))
(setq x (+ x dx))))
(setq x 0.0
y (+ y dy))
;;;###autoload
(defmacro defimage (symbol specs &optional doc)
- "Define SYMBOL as an image.
+ "Define SYMBOL as an image, and return SYMBOL.
SPECS is a list of image specifications. DOC is an optional
documentation string.
the number of frames (or sub-images) in the image and DELAY is the delay
in seconds that the image specifies between each frame. DELAY may be nil,
in which case you might want to use `image-default-frame-delay'."
- (let* ((metadata (image-metadata image))
- (images (plist-get metadata 'count))
- (delay (plist-get metadata 'delay)))
- (when (and images (> images 1))
- (if (or (not (numberp delay)) (< delay 0))
- (setq delay image-default-frame-delay))
- (cons images delay))))
+ (when (fboundp 'image-metadata)
+ (let* ((metadata (image-metadata image))
+ (images (plist-get metadata 'count))
+ (delay (plist-get metadata 'delay)))
+ (when (and images (> images 1))
+ (and delay (or (not (numberp delay)) (< delay 0))
+ (setq delay image-default-frame-delay))
+ (cons images delay)))))
(defun image-animated-p (image)
"Like `image-multi-frame-p', but returns nil if no delay is specified."
(when animation
(if (setq timer (image-animate-timer image))
(cancel-timer timer))
- (run-with-timer 0.2 nil 'image-animate-timeout
+ (plist-put (cdr image) :animate-buffer (current-buffer))
+ (run-with-timer 0.2 nil #'image-animate-timeout
image (or index 0) (car animation)
- 0 limit))))
+ 0 limit (+ (float-time) 0.2)))))
(defun image-animate-timer (image)
"Return the animation timer for image IMAGE."
(while tail
(setq timer (car tail)
tail (cdr tail))
- (if (and (eq (timer--function timer) 'image-animate-timeout)
+ (if (and (eq (timer--function timer) #'image-animate-timeout)
(eq (car-safe (timer--args timer)) image))
(setq tail nil)
(setq timer nil)))
;; hence we need to call image-multi-frame-p to return it.
;; But it also returns count, so why do we bother passing that as an
;; argument?
-(defun image-animate-timeout (image n count time-elapsed limit)
+(defun image-animate-timeout (image n count time-elapsed limit target-time)
"Display animation frame N of IMAGE.
N=0 refers to the initial animation frame.
COUNT is the total number of frames in the animation.
If the image has a non-nil :speed property, it acts as a multiplier
for the animation speed. A negative value means to animate in reverse."
- (image-show-frame image n t)
- (let* ((speed (image-animate-get-speed image))
- (time (float-time))
- (animation (image-multi-frame-p image))
- ;; Subtract off the time we took to load the image from the
- ;; stated delay time.
- (delay (max (+ (* (or (cdr animation) image-default-frame-delay)
- (/ 1 (abs speed)))
- time (- (float-time)))
- image-minimum-frame-delay))
- done)
- (setq n (if (< speed 0)
- (1- n)
- (1+ n)))
- (if limit
- (cond ((>= n count) (setq n 0))
- ((< n 0) (setq n (1- count))))
- (and (or (>= n count) (< n 0)) (setq done t)))
- (setq time-elapsed (+ delay time-elapsed))
- (if (numberp limit)
- (setq done (>= time-elapsed limit)))
- (unless done
- (run-with-timer delay nil 'image-animate-timeout
- image n count time-elapsed limit))))
+ (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer))
+ ;; Delayed more than two seconds more than expected.
+ (when (> (- (float-time) target-time) 2)
+ (message "Stopping animation; animation possibly too big")
+ nil))
+ (image-show-frame image n t)
+ (let* ((speed (image-animate-get-speed image))
+ (time (float-time))
+ (animation (image-multi-frame-p image))
+ ;; Subtract off the time we took to load the image from the
+ ;; stated delay time.
+ (delay (max (+ (* (or (cdr animation) image-default-frame-delay)
+ (/ 1.0 (abs speed)))
+ time (- (float-time)))
+ image-minimum-frame-delay))
+ done)
+ (setq n (if (< speed 0)
+ (1- n)
+ (1+ n)))
+ (if limit
+ (cond ((>= n count) (setq n 0))
+ ((< n 0) (setq n (1- count))))
+ (and (or (>= n count) (< n 0)) (setq done t)))
+ (setq time-elapsed (+ delay time-elapsed))
+ (if (numberp limit)
+ (setq done (>= time-elapsed limit)))
+ (unless done
+ (run-with-timer delay nil #'image-animate-timeout
+ image n count time-elapsed limit
+ (+ (float-time) delay))))))
\f
(defvar imagemagick-types-inhibit)
:type '(choice (const :tag "Support all ImageMagick types" nil)
(const :tag "Disable all ImageMagick types" t)
(repeat symbol))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
(imagemagick-register-types))
- :version "24.3"
- :group 'image)
+ :version "24.3")
(defcustom imagemagick-enabled-types
'(3FR ART ARW AVS BMP BMP2 BMP3 CAL CALS CMYK CMYKA CR2 CRW
(repeat :tag "List of types"
(choice (symbol :tag "type")
(regexp :tag "regexp"))))
- :initialize 'custom-initialize-default
+ :initialize #'custom-initialize-default
:set (lambda (symbol value)
(set-default symbol value)
(imagemagick-register-types))
- :version "24.3"
- :group 'image)
+ :version "24.3")
(imagemagick-register-types)
+(defun image-increase-size (n)
+ "Increase the image size by a factor of N.
+If N is 3, then the image size will be increased by 30%. The
+default is 20%."
+ (interactive "P")
+ (image--change-size (if n
+ (1+ (/ n 10))
+ 1.2)))
+
+(defun image-decrease-size (n)
+ "Decrease the image size by a factor of N.
+If N is 3, then the image size will be decreased by 30%. The
+default is 20%."
+ (interactive "P")
+ (image--change-size (if n
+ (- 1 (/ n 10))
+ 0.8)))
+
+(defun image--get-image ()
+ (let ((image (get-text-property (point) 'display)))
+ (unless (eq (car-safe image) 'image)
+ (error "No image under point"))
+ image))
+
+(defun image--get-imagemagick-and-warn ()
+ (unless (fboundp 'imagemagick-types)
+ (error "Can't rescale images without ImageMagick support"))
+ (let ((image (image--get-image)))
+ (image-flush image)
+ (plist-put (cdr image) :type 'imagemagick)
+ image))
+
+(defun image--change-size (factor)
+ (let* ((image (image--get-imagemagick-and-warn))
+ (new-image (image--image-without-parameters image))
+ (scale (image--current-scaling image new-image)))
+ (setcdr image (cdr new-image))
+ (plist-put (cdr image) :scale (* scale factor))))
+
+(defun image--image-without-parameters (image)
+ (cons (pop image)
+ (let ((new nil))
+ (while image
+ (let ((key (pop image))
+ (val (pop image)))
+ (unless (memq key '(:scale :width :height :max-width :max-height))
+ (setq new (nconc new (list key val))))))
+ new)))
+
+(defun image--current-scaling (image new-image)
+ ;; The image may be scaled due to many reasons (:scale, :max-width,
+ ;; etc), so find out what the current scaling is based on the
+ ;; original image size and the displayed size.
+ (let ((image-width (car (image-size new-image t)))
+ (display-width (car (image-size image t))))
+ (/ (float display-width) image-width)))
+
+(defun image-rotate ()
+ "Rotate the image under point by 90 degrees clockwise."
+ (interactive)
+ (let ((image (image--get-imagemagick-and-warn)))
+ (plist-put (cdr image) :rotation
+ (float (+ (or (plist-get (cdr image) :rotation) 0) 90)))))
+
+(defun image-save ()
+ "Save the image under point."
+ (interactive)
+ (let ((image (get-text-property (point) 'display)))
+ (when (or (not (consp image))
+ (not (eq (car image) 'image)))
+ (error "No image under point"))
+ (with-temp-buffer
+ (let ((file (plist-get (cdr image) :file)))
+ (if file
+ (if (not (file-exists-p file))
+ (error "File %s no longer exists" file)
+ (insert-file-contents-literally file))
+ (insert (plist-get (cdr image) :data))))
+ (write-region (point-min) (point-max)
+ (read-file-name "Write image to file: ")))))
+
(provide 'image)
;;; image.el ends here