summaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
authorEli Zaretskii <eliz@gnu.org>2023-04-08 12:43:34 +0300
committerEli Zaretskii <eliz@gnu.org>2023-04-08 12:43:34 +0300
commit6a2863ca0167a1b4a431dfae3640c97a846d4826 (patch)
tree531e857f36640640381ab17b56994e6fac86895e /lisp
parent5be79fd05a51a42d591833019775cb743aa5055f (diff)
downloademacs-6a2863ca0167a1b4a431dfae3640c97a846d4826.tar.gz
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.
Diffstat (limited to 'lisp')
-rw-r--r--lisp/image.el21
-rw-r--r--lisp/image/image-crop.el59
2 files changed, 64 insertions, 16 deletions
diff --git a/lisp/image.el b/lisp/image.el
index 3f878bd4de0..818679a4d7b 100644
--- a/lisp/image.el
+++ b/lisp/image.el
@@ -188,6 +188,19 @@ or \"ffmpeg\") is installed."
"C-<wheel-up>" #'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)
"Return a suitable search path for images used by LIBRARY.
@@ -665,7 +678,9 @@ is non-nil, this is inhibited."
image)
rear-nonsticky t
inhibit-isearch ,inhibit-isearch
- keymap ,image-map))))
+ keymap ,(if slice
+ image-slice-map
+ image-map)))))
;;;###autoload
@@ -701,8 +716,8 @@ The image is automatically split into ROWS x COLS slices."
(insert string)
(add-text-properties start (point)
`(display ,(list (list 'slice x y dx dy) image)
- rear-nonsticky (display)
- keymap ,image-map))
+ rear-nonsticky (display keymap)
+ keymap ,image-slice-map))
(setq x (+ x dx))))
(setq x 0.0
y (+ y dy))
diff --git a/lisp/image/image-crop.el b/lisp/image/image-crop.el
index be6e22bc606..9ef848c5bc8 100644
--- a/lisp/image/image-crop.el
+++ b/lisp/image/image-crop.el
@@ -35,6 +35,7 @@
(declare-function image-property "image.el" (image property))
(declare-function image-size "image.c" (spec &optional pixels frame))
(declare-function imagep "image.c" (spec))
+(declare-function image--get-image "image.el" (&optional position))
(defgroup image-crop ()
"Image cropping."
@@ -113,18 +114,36 @@ and the cropped image data.")
(defun image-cut (&optional color)
"Cut a rectangle from the image under point, filling it with COLOR.
COLOR defaults to the value of `image-cut-color'.
-Interactively, with prefix argument, prompt for COLOR to use."
- (interactive (list (and current-prefix-arg (read-color "Use color: "))))
+Interactively, with prefix argument, prompt for COLOR to use.
+
+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 cut.
+
+While moving/resizing the cutting 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 cutting the image, you can save it by `M-x image-save' or
+\\<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.
-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.
+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 cropping the image, the following key bindings are available:
+While moving/resizing the cropping area, the following key bindings
+are available:
`q': Exit without changing anything.
`RET': Crop/cut the image.
@@ -132,15 +151,29 @@ While cropping the image, the following key bindings are available:
rectangle shape.
`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
-\\<image-map>\\[image-save] when point is over the image."
+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)
(unless (image-type-available-p 'svg)
- (error "SVG support is needed to crop images"))
- (unless (executable-find (car image-crop-crop-command))
- (error "Couldn't find %s command to crop the image"
- (car image-crop-crop-command)))
- (let ((image (get-text-property (point) 'display)))
+ (error "SVG support is needed to crop and cut images"))
+ (let* ((crop-cmd (car image-crop-crop-command))
+ (found (executable-find crop-cmd)))
+ (unless found
+ (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)
(user-error "No image under point"))
(when (overlays-at (point))