master 495aa53: Fix minor bugs in image.c

[Lars Ingebrigtsen]

branch: master
commit 495aa532f1a6486295dc502f22a3300d8f61be16
Author: Pip Cet <pipcet@gmail.com>
Commit: Lars Ingebrigtsen <larsi@gnus.org>

    Fix minor bugs in image.c
    
    * test/src/image-tests.el (image-test-circular-specs): New file.
    * src/image.c (parse_image_spec): Return failure for circular lists.
    (valid_image_p): Don't look at odd-numbered list elements expecting to
    find a property name.
    (image_spec_value): Handle circular lists.
    (equal_lists): Introduce.
    (search_image_cache): Use `equal_lists' (bug#36403).
---
 src/image.c                         |  71 ++++++++++++------
 test/manual/image-circular-tests.el | 144 ++++++++++++++++++++++++++++++++++++
 2 files changed, 191 insertions(+), 24 deletions(-)

diff --git a/src/image.c b/src/image.c
index e236b38..643b3d0 100644
--- a/src/image.c
+++ b/src/image.c
@@ -803,17 +803,23 @@ valid_image_p (Lisp_Object object)
     {
       Lisp_Object tail = XCDR (object);
       FOR_EACH_TAIL_SAFE (tail)
-       if (EQ (XCAR (tail), QCtype))
-         {
-           tail = XCDR (tail);
-           if (CONSP (tail))
-             {
-               struct image_type const *type = lookup_image_type (XCAR (tail));
-               if (type)
-                 return type->valid_p (object);
-             }
-           break;
-         }
+       {
+         if (EQ (XCAR (tail), QCtype))
+           {
+             tail = XCDR (tail);
+             if (CONSP (tail))
+               {
+                 struct image_type const *type =
+                   lookup_image_type (XCAR (tail));
+                 if (type)
+                   return type->valid_p (object);
+               }
+             break;
+           }
+         tail = XCDR (tail);
+         if (! CONSP (tail))
+           return false;
+       }
     }
 
   return false;
@@ -899,7 +905,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword 
*keywords,
     return false;
 
   plist = XCDR (spec);
-  while (CONSP (plist))
+  FOR_EACH_TAIL_SAFE (plist)
     {
       Lisp_Object key, value;
 
@@ -913,7 +919,6 @@ parse_image_spec (Lisp_Object spec, struct image_keyword 
*keywords,
       if (!CONSP (plist))
        return false;
       value = XCAR (plist);
-      plist = XCDR (plist);
 
       /* Find key in KEYWORDS.  Error if not found.  */
       for (i = 0; i < nkeywords; ++i)
@@ -921,7 +926,7 @@ parse_image_spec (Lisp_Object spec, struct image_keyword 
*keywords,
          break;
 
       if (i == nkeywords)
-       continue;
+       goto maybe_done;
 
       /* Record that we recognized the keyword.  If a keyword
         was found more than once, it's an error.  */
@@ -1009,14 +1014,20 @@ parse_image_spec (Lisp_Object spec, struct 
image_keyword *keywords,
       if (EQ (key, QCtype)
          && !(EQ (type, value) || EQ (type, Qnative_image)))
        return false;
-    }
 
-  /* Check that all mandatory fields are present.  */
-  for (i = 0; i < nkeywords; ++i)
-    if (keywords[i].count < keywords[i].mandatory_p)
-      return false;
+    maybe_done:
+      if (EQ (XCDR (plist), Qnil))
+       {
+         /* Check that all mandatory fields are present.  */
+         for (i = 0; i < nkeywords; ++i)
+           if (keywords[i].mandatory_p && keywords[i].count == 0)
+             return false;
+
+         return true;
+       }
+    }
 
-  return NILP (plist);
+  return false;
 }
 
 
@@ -1031,9 +1042,8 @@ image_spec_value (Lisp_Object spec, Lisp_Object key, bool 
*found)
 
   eassert (valid_image_p (spec));
 
-  for (tail = XCDR (spec);
-       CONSP (tail) && CONSP (XCDR (tail));
-       tail = XCDR (XCDR (tail)))
+  tail = XCDR (spec);
+  FOR_EACH_TAIL_SAFE (tail)
     {
       if (EQ (XCAR (tail), key))
        {
@@ -1041,6 +1051,9 @@ image_spec_value (Lisp_Object spec, Lisp_Object key, bool 
*found)
            *found = 1;
          return XCAR (XCDR (tail));
        }
+      tail = XCDR (tail);
+      if (! CONSP (tail))
+       break;
     }
 
   if (found)
@@ -1584,6 +1597,16 @@ make_image_cache (void)
   return c;
 }
 
+/* Compare two lists (one of which must be proper), comparing each
+   element with `eq'.  */
+static bool
+equal_lists (Lisp_Object a, Lisp_Object b)
+{
+  while (CONSP (a) && CONSP (b) && EQ (XCAR (a), XCAR (b)))
+    a = XCDR (a), b = XCDR (b);
+
+  return EQ (a, b);
+}
 
 /* Find an image matching SPEC in the cache, and return it.  If no
    image is found, return NULL.  */
@@ -1610,7 +1633,7 @@ search_image_cache (struct frame *f, Lisp_Object spec, 
EMACS_UINT hash)
 
   for (img = c->buckets[i]; img; img = img->next)
     if (img->hash == hash
-       && !NILP (Fequal (img->spec, spec))
+       && !equal_lists (img->spec, spec)
        && img->frame_foreground == FRAME_FOREGROUND_PIXEL (f)
        && img->frame_background == FRAME_BACKGROUND_PIXEL (f))
       break;
diff --git a/test/manual/image-circular-tests.el 
b/test/manual/image-circular-tests.el
new file mode 100644
index 0000000..33ea3ea
--- /dev/null
+++ b/test/manual/image-circular-tests.el
@@ -0,0 +1,144 @@
+;;; image-tests.el --- Test suite for image-related functions.
+
+;; Copyright (C) 2019 Free Software Foundation, Inc.
+
+;; Author: Pip Cet <pipcet@gmail.com>
+;; Keywords:       internal
+;; Human-Keywords: internal
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;;; Code:
+
+(require 'ert)
+
+(ert-deftest image-test-duplicate-keywords ()
+  "Test that duplicate keywords in an image spec lead to rejection."
+  (should-error (image-size `(image :type xbm :type xbm :width 1 :height 1
+                                    :data ,(bool-vector t))
+                            t)))
+
+(ert-deftest image-test-circular-plist ()
+  "Test that a circular image spec is rejected."
+  (should-error
+   (let ((l `(image :type xbm :width 1 :height 1 :data ,(bool-vector t))))
+     (setcdr (last l) '#1=(:invalid . #1#))
+     (image-size l t))))
+
+(ert-deftest image-test-:type-property-value ()
+  "Test that :type is allowed as a property value in an image spec."
+  (should (equal (image-size `(image :dummy :type :type xbm :width 1 :height 1
+                                        :data ,(bool-vector t))
+                                t)
+                 (cons 1 1))))
+
+(ert-deftest image-test-circular-specs ()
+  "Test that circular image spec property values do not cause infinite 
recursion."
+  (should
+   (let* ((circ1 (cons :dummy nil))
+          (circ2 (cons :dummy nil))
+          (spec1 `(image :type xbm :width 1 :height 1
+                         :data ,(bool-vector 1) :ignored ,circ1))
+          (spec2 `(image :type xbm :width 1 :height 1
+                        :data ,(bool-vector 1) :ignored ,circ2)))
+     (setcdr circ1 circ1)
+     (setcdr circ2 circ2)
+     (and (equal (image-size spec1 t) (cons 1 1))
+          (equal (image-size spec2 t) (cons 1 1))))))
+
+(provide 'image-tests)
+;;; image-tests.el ends here.
+;;; image-tests.el --- tests for image.el -*- lexical-binding: t -*-
+
+;; Copyright (C) 2019-2020 Free Software Foundation, Inc.
+
+;; This file is part of GNU Emacs.
+
+;; GNU Emacs is free software: you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; GNU Emacs is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
+
+;;; Code:
+
+(require 'ert)
+(require 'image)
+(eval-when-compile
+  (require 'cl-lib))
+
+(defconst image-tests--emacs-images-directory
+  (expand-file-name "../etc/images" (getenv "EMACS_TEST_DIRECTORY"))
+  "Directory containing Emacs images.")
+
+(ert-deftest image--set-property ()
+  "Test `image--set-property' behavior."
+  (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 image-type-from-file-header-test ()
+  "Test image-type-from-file-header."
+  (should (eq (if (image-type-available-p 'svg) 'svg)
+             (image-type-from-file-header
+              (expand-file-name "splash.svg"
+                                image-tests--emacs-images-directory)))))
+
+(ert-deftest image-rotate ()
+  "Test `image-rotate'."
+  (cl-letf* ((image (list 'image))
+             ((symbol-function 'image--get-imagemagick-and-warn)
+              (lambda () image)))
+    (let ((current-prefix-arg '(4)))
+      (call-interactively #'image-rotate))
+    (should (equal image '(image :rotation 270.0)))
+    (call-interactively #'image-rotate)
+    (should (equal image '(image :rotation 0.0)))
+    (image-rotate)
+    (should (equal image '(image :rotation 90.0)))
+    (image-rotate 0)
+    (should (equal image '(image :rotation 90.0)))
+    (image-rotate 1)
+    (should (equal image '(image :rotation 91.0)))
+    (image-rotate 1234.5)
+    (should (equal image '(image :rotation 245.5)))
+    (image-rotate -154.5)
+    (should (equal image '(image :rotation 91.0)))))
+
+;;; image-tests.el ends here