Fix handling of sliced images

* lisp/image.el (image-slice-map): New keymap, without some
bindings that make no sense with sliced images.
(insert-image, insert-sliced-image): Use it.
(insert-sliced-image): Make the 'keymap' property rear-nonsticky,
to prevent calling image commands when point is to the right of
the slice.  (Bug#62679)

* lisp/image/image-crop.el (image-cut, image-crop): Doc fixes.
(image-crop): Don't try using stock MS-Widows convert.exe
program.  Use 'image--get-image' to support sliced images.
This commit is contained in:
Eli Zaretskii 2023-04-08 12:43:34 +03:00
parent 5be79fd05a
commit 6a2863ca01
2 changed files with 67 additions and 19 deletions

View file

@ -188,6 +188,19 @@ or \"ffmpeg\") is installed."
"C-<wheel-up>" #'image-mouse-increase-size "C-<wheel-up>" #'image-mouse-increase-size
"C-<mouse-4>" #'image-mouse-increase-size) "C-<mouse-4>" #'image-mouse-increase-size)
(defvar-keymap image-slice-map
:doc "Map put into text properties on sliced images."
"i" (define-keymap
"-" #'image-decrease-size
"+" #'image-increase-size
"o" #'image-save
"c" #'image-crop
"x" #'image-cut)
"C-<wheel-down>" #'image-mouse-decrease-size
"C-<mouse-5>" #'image-mouse-decrease-size
"C-<wheel-up>" #'image-mouse-increase-size
"C-<mouse-4>" #'image-mouse-increase-size)
(defun image-load-path-for-library (library image &optional path no-error) (defun image-load-path-for-library (library image &optional path no-error)
"Return a suitable search path for images used by LIBRARY. "Return a suitable search path for images used by LIBRARY.
@ -665,7 +678,9 @@ is non-nil, this is inhibited."
image) image)
rear-nonsticky t rear-nonsticky t
inhibit-isearch ,inhibit-isearch inhibit-isearch ,inhibit-isearch
keymap ,image-map)))) keymap ,(if slice
image-slice-map
image-map)))))
;;;###autoload ;;;###autoload
@ -701,8 +716,8 @@ The image is automatically split into ROWS x COLS slices."
(insert string) (insert string)
(add-text-properties start (point) (add-text-properties start (point)
`(display ,(list (list 'slice x y dx dy) image) `(display ,(list (list 'slice x y dx dy) image)
rear-nonsticky (display) rear-nonsticky (display keymap)
keymap ,image-map)) keymap ,image-slice-map))
(setq x (+ x dx)))) (setq x (+ x dx))))
(setq x 0.0 (setq x 0.0
y (+ y dy)) y (+ y dy))

View file

@ -35,6 +35,7 @@
(declare-function image-property "image.el" (image property)) (declare-function image-property "image.el" (image property))
(declare-function image-size "image.c" (spec &optional pixels frame)) (declare-function image-size "image.c" (spec &optional pixels frame))
(declare-function imagep "image.c" (spec)) (declare-function imagep "image.c" (spec))
(declare-function image--get-image "image.el" (&optional position))
(defgroup image-crop () (defgroup image-crop ()
"Image cropping." "Image cropping."
@ -113,18 +114,14 @@ and the cropped image data.")
(defun image-cut (&optional color) (defun image-cut (&optional color)
"Cut a rectangle from the image under point, filling it with COLOR. "Cut a rectangle from the image under point, filling it with COLOR.
COLOR defaults to the value of `image-cut-color'. COLOR defaults to the value of `image-cut-color'.
Interactively, with prefix argument, prompt for COLOR to use." Interactively, with prefix argument, prompt for COLOR to use.
(interactive (list (and current-prefix-arg (read-color "Use color: "))))
(image-crop (if (zerop (length color)) image-cut-color color)))
;;;###autoload This command presents the image with a rectangular area superimposed
(defun image-crop (&optional cut) on it, and allows moving and resizing the area to define which
"Crop the image under point. part of it to cut.
If CUT is non-nil, remove a rectangle from the image instead of
cropping the image. In that case CUT should be the name of a
color to fill the rectangle.
While cropping the image, the following key bindings are available: While moving/resizing the cutting area, the following key bindings
are available:
`q': Exit without changing anything. `q': Exit without changing anything.
`RET': Crop/cut the image. `RET': Crop/cut the image.
@ -132,15 +129,51 @@ While cropping the image, the following key bindings are available:
rectangle shape. rectangle shape.
`s': Same as `m', but make the rectangle into a square first. `s': Same as `m', but make the rectangle into a square first.
After cropping an image, you can save it by `M-x image-save' or After cutting the image, you can save it by `M-x image-save' or
\\<image-map>\\[image-save] when point is over the image." \\<image-map>\\[image-save] when point is over the image."
(interactive (list (and current-prefix-arg
(read-color "Color to use for filling: "))))
(image-crop (if (zerop (length color)) image-cut-color color)))
;;;###autoload
(defun image-crop (&optional cut)
"Crop the image under point.
This command presents the image with a rectangular area superimposed
on it, and allows moving and resizing the area to define which
part of it to crop.
While moving/resizing the cropping area, the following key bindings
are available:
`q': Exit without changing anything.
`RET': Crop/cut the image.
`m': Make mouse movements move the rectangle instead of altering the
rectangle shape.
`s': Same as `m', but make the rectangle into a square first.
After cropping the image, you can save it by `M-x image-save' or
\\<image-map>\\[image-save] when point is over the image.
When called from Lisp, if CUT is non-nil, remove a rectangle from
the image instead of cropping the image. In that case, CUT should
be the name of a color to fill the rectangle."
(interactive) (interactive)
(unless (image-type-available-p 'svg) (unless (image-type-available-p 'svg)
(error "SVG support is needed to crop images")) (error "SVG support is needed to crop and cut images"))
(unless (executable-find (car image-crop-crop-command)) (let* ((crop-cmd (car image-crop-crop-command))
(error "Couldn't find %s command to crop the image" (found (executable-find crop-cmd)))
(car image-crop-crop-command))) (unless found
(let ((image (get-text-property (point) 'display))) (error "Couldn't find `%s' command to crop/cut the image" crop-cmd))
(if (and (memq system-type '(windows-nt ms-dos))
;; MS-Windows has an incompatible convert.exe, used to
;; convert filesystems...
(string-equal crop-cmd "convert")
(= 0 (string-search "Invalid drive specification."
(shell-command-to-string
(format "%s %s" crop-cmd null-device)))))
(error "The program `%s' is not an image conversion program"
found)))
(let ((image (image--get-image)))
(unless (imagep image) (unless (imagep image)
(user-error "No image under point")) (user-error "No image under point"))
(when (overlays-at (point)) (when (overlays-at (point))