branch: externals/compat
commit c3c308125a7a3d19de50bd904c1f42fb7b6e029b
Author: Daniel Mendler <m...@daniel-mendler.de>
Commit: Daniel Mendler <m...@daniel-mendler.de>
compat-tests: Fix and test image-property getter/setter
---
NEWS.org | 1 +
compat-26.el | 31 ++-----------------------------
compat-27.el | 25 +++++++++++++++++++++++++
compat-tests.el | 50 +++++++++++++++++++++++++++++++++++---------------
4 files changed, 63 insertions(+), 44 deletions(-)
diff --git a/NEWS.org b/NEWS.org
index 50281fbb15..9255ee57cb 100644
--- a/NEWS.org
+++ b/NEWS.org
@@ -15,6 +15,7 @@
- Compat takes great care to remove unneeded definitions at compile time. On
recent Emacs 29 the byte compiled files are empty and not loaded, such that
Compat does not any cost to the Emacs process.
+- compat-26: Fix and test ~image-property~ setter.
- compat-28: Fix and test ~with-existing-directory~.
- compat-29: Drop broken functions ~string-pixel-width~ and
~buffer-text-pixel-size~. These functions had poor performance which lead to
a
diff --git a/compat-26.el b/compat-26.el
index a1fae8aa0b..e645371ec0 100644
--- a/compat-26.el
+++ b/compat-26.el
@@ -469,43 +469,16 @@ inode-number and device-number."
;;;; Defined in image.el
-(compat-defun image-property (image property) ;; <UNTESTED>
+(compat-defun image-property (image property) ;; <OK>
"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."
- ;; :feature image
+ :feature image
(plist-get (cdr image) property))
-(unless (eval-when-compile
- (require 'image)
- (get 'image-property 'gv-expander))
- (gv-define-setter image-property (image property value)
- (let ((image* (make-symbol "image"))
- (property* (make-symbol "property"))
- (value* (make-symbol "value")))
- `(let ((,image* ,image)
- (,property* ,property)
- (,value* ,value))
- (if
- (null ,value*)
- (while
- (cdr ,image*)
- (if
- (eq
- (cadr ,image*)
- ,property*)
- (setcdr ,image*
- (cdddr ,image*))
- (setq ,image*
- (cddr ,image*))))
- (setcdr ,image*
- (plist-put
- (cdr ,image*)
- ,property* ,value*)))))))
-
;;;; Defined in rmc.el
(compat-defun read-multiple-choice ;; <UNTESTED>
diff --git a/compat-27.el b/compat-27.el
index 863c93df15..c0b0202aa8 100644
--- a/compat-27.el
+++ b/compat-27.el
@@ -333,6 +333,31 @@ the number of seconds east of Greenwich."
;; TODO define gv-setters for decoded-time-*
+;;;; Defined in image.el
+
+(compat-defun image--set-property (image property value) ;; <OK>
+ "Set PROPERTY in IMAGE to VALUE.
+Internal use only."
+ :explicit t
+ :feature image
+ (if (null value)
+ (while (cdr image)
+ (if (eq (cadr image) property)
+ (setcdr image (cdddr image))
+ (setq image (cddr image))))
+ (setcdr image (plist-put (cdr image) property value)))
+ value)
+
+(if (eval-when-compile (version< emacs-version "26.1"))
+ (with-eval-after-load 'image
+ (gv-define-simple-setter image-property image--set-property))
+ ;; HACK: image--set-property was broken with an off-by-one error on Emacs 26.
+ ;; The bug was fixed in a4ad7bed187493c1c230f223b52c71f5c34f7c89. Therefore
we
+ ;; override the gv expander until Emacs 27.1.
+ (when (eval-when-compile (version< emacs-version "27.1"))
+ (with-eval-after-load 'image
+ (gv-define-simple-setter image-property compat--image--set-property))))
+
;;;; Defined in files.el
(compat-defun file-size-human-readable (file-size &optional flavor space unit)
;; <OK>
diff --git a/compat-tests.el b/compat-tests.el
index 2de21eb18c..c70a0c06a2 100644
--- a/compat-tests.el
+++ b/compat-tests.el
@@ -40,6 +40,7 @@
(require 'compat)
(require 'subr-x)
(require 'time-date)
+(require 'image)
(require 'text-property-search nil t)
(defmacro should-equal (a b)
@@ -59,11 +60,30 @@
(setq list (funcall sym list "first" 1 #'string=))
(should (eq (compat-call plist-get list "first" #'string=) 1))))
+(ert-deftest image-property ()
+ (let ((image (list 'image)))
+ ;; Add properties.
+ (setf (image-property image :scale) 1)
+ (should-equal image '(image :scale 1))
+ (setf (image-property image :width) 8)
+ (should-equal image '(image :scale 1 :width 8))
+ (setf (image-property image :height) 16)
+ (should-equal image '(image :scale 1 :width 8 :height 16))
+ ;; Delete properties.
+ (setf (image-property image :type) nil)
+ (should-equal image '(image :scale 1 :width 8 :height 16))
+ (setf (image-property image :scale) nil)
+ (should-equal image '(image :width 8 :height 16))
+ (setf (image-property image :height) nil)
+ (should-equal image '(image :width 8))
+ (setf (image-property image :width) nil)
+ (should-equal image '(image))))
+
(ert-deftest with-environment-variables ()
(let ((A "COMPAT_TESTS__VAR") (B "/foo/bar"))
(should-not (getenv A))
(with-environment-variables ((A B))
- (should (equal (getenv A) B)))
+ (should-equal (getenv A) B))
(should-not (getenv A))))
(ert-deftest get-display-property ()
@@ -891,13 +911,13 @@
(insert "foo bar zot foobar")
(should (= (replace-string-in-region "foo" "new" (point-min) (point-max))
2))
- (should (equal (buffer-string) "new bar zot newbar")))
+ (should-equal (buffer-string) "new bar zot newbar"))
(with-temp-buffer
(insert "foo bar zot foobar")
(should (= (replace-string-in-region "foo" "new" (point-min) 14)
1))
- (should (equal (buffer-string) "new bar zot foobar")))
+ (should-equal (buffer-string) "new bar zot foobar"))
(with-temp-buffer
(insert "foo bar zot foobar")
@@ -907,7 +927,7 @@
(insert "Foo bar zot foobar")
(should (= (replace-string-in-region "Foo" "new" (point-min))
1))
- (should (equal (buffer-string) "new bar zot foobar")))
+ (should-equal (buffer-string) "new bar zot foobar"))
;; There was a bug in the Emacs 28 implementation
;; Fixed in Emacs d8f392bccd46cdb238ec96964f220ffb9d81cc44
@@ -916,28 +936,28 @@
(insert "foo bar baz")
(should (= (replace-string-in-region "ba" "quux corge grault"
(point-min))
2))
- (should (equal (buffer-string)
- "foo quux corge graultr quux corge graultz")))
+ (should-equal (buffer-string)
+ "foo quux corge graultr quux corge graultz"))
(with-temp-buffer
(insert "foo bar bar")
(should (= (replace-string-in-region " bar" "" (point-min) 8)
1))
- (should (equal (buffer-string)
- "foo bar")))))
+ (should-equal (buffer-string)
+ "foo bar"))))
(ert-deftest replace-regexp-in-region ()
(with-temp-buffer
(insert "foo bar zot foobar")
(should (= (replace-regexp-in-region "fo+" "new" (point-min) (point-max))
2))
- (should (equal (buffer-string) "new bar zot newbar")))
+ (should-equal (buffer-string) "new bar zot newbar"))
(with-temp-buffer
(insert "foo bar zot foobar")
(should (= (replace-regexp-in-region "fo+" "new" (point-min) 14)
1))
- (should (equal (buffer-string) "new bar zot foobar")))
+ (should-equal (buffer-string) "new bar zot foobar"))
(with-temp-buffer
(insert "foo bar zot foobar")
@@ -947,7 +967,7 @@
(insert "Foo bar zot foobar")
(should (= (replace-regexp-in-region "Fo+" "new" (point-min))
1))
- (should (equal (buffer-string) "new bar zot foobar")))
+ (should-equal (buffer-string) "new bar zot foobar"))
;; There was a bug in the Emacs 28 implementation
;; Fixed in Emacs d8f392bccd46cdb238ec96964f220ffb9d81cc44
@@ -956,15 +976,15 @@
(insert "foo bar baz")
(should (= (replace-regexp-in-region "ba." "quux corge grault"
(point-min))
2))
- (should (equal (buffer-string)
- "foo quux corge grault quux corge grault")))
+ (should-equal (buffer-string)
+ "foo quux corge grault quux corge grault"))
(with-temp-buffer
(insert "foo bar bar")
(should (= (replace-regexp-in-region " bar" "" (point-min) 8)
1))
- (should (equal (buffer-string)
- "foo bar")))))
+ (should-equal (buffer-string)
+ "foo bar"))))
(ert-deftest string-split ()
(should-equal '("a" "b" "c") (split-string "a b c"))
