bug#29541: 27.0.50; Use generic function when restoring eieio-persistent, remove validation

[Eric Abrahamsen <eric@ericabrahamsen.net>]

[-- Attachment #1: Type: text/plain, Size: 1501 bytes --]


The attached patch is a proposal that would replace the function
`eieio-persistent-convert-list-to-object' with a generic method
`eieio-persistent-make-instance'. It also removes all slot validation in
the read process.

Considerations:

1. `object-write' is already a method. That means the writing process
can be overridden and customized, but the reading process can't, which
removes most of the benefit of being able to override the write. This
would allow "matching" methods for writing and reading.

2. This version checks *all* slot values, including all elements inside
lists, cons-cells, etc. The safety consideration is mostly removing text
properties (specifically the display property), and this version checks
exhaustively.

3. I removed slot validation because it complicates the restoration
process, and because all the validation will be done again, and done
better, by `cl-typep' in the `initialize-instance' process. There's not
much reason to have a "pre-check", as errors are raised in both cases.

4. This version goes slightly faster than the old one (admittedly,
probably just because it omits type-checking).

Persistence format isn't changed, so this should be backwards
compatible.

I suppose the removal of validation might not be welcome, but at least I
hope the function->generic change is acceptable.



In GNU Emacs 27.0.50 (build 13, x86_64-pc-linux-gnu, GTK+ Version 3.22.26)
 of 2017-11-30 built on slip
Repository revision: 3f3d98ee5851840228786390ee7dbf851d144eb8

[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: 0001-Replace-eieio-persistent-convert-list-to-object-with.patch --]
[-- Type: text/x-diff, Size: 13559 bytes --]

From 858b6ca64ad088362800e3ce4d5c0b34114f9b06 Mon Sep 17 00:00:00 2001
From: Eric Abrahamsen <eric@ericabrahamsen.net>
Date: Sat, 2 Dec 2017 15:21:51 -0800
Subject: [PATCH] Replace eieio-persistent-convert-list-to-object with method

* lisp/emacs-lisp/eieio-base.el (eieio-persistent-make-instance): New
  generic function that replaces
  eieio-persistent-convert-list-to-object.
  eieio-persistent-validate/fix-slot-value has been renamed to
  eieio-persistent-fix-value, and
  eieio-persistent-slot-type-is-class-p has been removed, as this
  process no longer does any validation, instead allowing that to
  happen at initialize-instance time.
* test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
 (eieio-test-string-restoration): New test making sure string
 properties are stripped.
---
 lisp/emacs-lisp/eieio-base.el                      | 235 ++++++---------------
 .../emacs-lisp/eieio-tests/eieio-test-persist.el   |  58 +++++
 2 files changed, 123 insertions(+), 170 deletions(-)

diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index 58dcd09d7e..e1a00f82a3 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -236,185 +236,80 @@ eieio-persistent-read
 	  (when (not (child-of-class-p (car ret) 'eieio-persistent))
 	    (error "Corrupt object on disk: Unknown saved object"))
 	  (when (and class
-		     (not (or (eq (car ret) class ) ; same class
+		     (not (or (eq (car ret) class)
 			      (and allow-subclass
-				   (child-of-class-p (car ret) class)) ; subclasses
-			      )))
+				   (child-of-class-p (car ret) class)))))
 	    (error "Corrupt object on disk: Invalid saved class"))
-	  (setq ret (eieio-persistent-convert-list-to-object ret))
+	  (setq ret (eieio-persistent-make-instance (car ret) (cdr ret)))
 	  (oset ret file filename))
       (kill-buffer " *tmp eieio read*"))
     ret))
 
-(defun eieio-persistent-convert-list-to-object (inputlist)
-  "Convert the INPUTLIST, representing object creation to an object.
-While it is possible to just `eval' the INPUTLIST, this code instead
-validates the existing list, and explicitly creates objects instead of
-calling eval.  This avoids the possibility of accidentally running
-malicious code.
+(cl-defmethod eieio-persistent-make-instance
+  ((cls (subclass eieio-default-superclass))
+   slot-list)
+  "Use values in SLOT-LIST to create an object of class CLS.
+ While it is possible to just `eval' the SLOT-LIST, this code
+instead validates the existing list, and explicitly creates
+objects instead of calling eval.  This avoids the possibility of
+accidentally running malicious code.
 
 Note: This function recurses when a slot of :type of some object is
 identified, and needing more object creation."
-  (let* ((objclass (nth 0 inputlist))
-         ;; Earlier versions of `object-write' added a string name for
-         ;; the object, now obsolete.
-         (slots (nthcdr
-                 (if (stringp (nth 1 inputlist)) 2 1)
-                 inputlist))
-	 (createslots nil)
-	 (class
-	  (progn
-	    ;; If OBJCLASS is an eieio autoload object, then we need to
-	    ;; load it.
-	    (eieio-class-un-autoload objclass)
-	    (eieio--class-object objclass))))
-
-    (while slots
-      (let ((initarg (car slots))
-	    (value (car (cdr slots))))
-
-	;; Make sure that the value proposed for SLOT is valid.
-	;; In addition, strip out quotes, list functions, and update
-	;; object constructors as needed.
-	(setq value (eieio-persistent-validate/fix-slot-value
-		     class (eieio--initarg-to-attribute class initarg) value))
-
-	(push initarg createslots)
-	(push value createslots)
-	)
-
-      (setq slots (cdr (cdr slots))))
-
-    (apply #'make-instance objclass (nreverse createslots))
-
-    ;;(eval inputlist)
-    ))
-
-(defun eieio-persistent-validate/fix-slot-value (class slot proposed-value)
-  "Validate that in CLASS, the SLOT with PROPOSED-VALUE is good, then fix.
-A limited number of functions, such as quote, list, and valid object
-constructor functions are considered valid.
-Second, any text properties will be stripped from strings."
-  (cond ((consp proposed-value)
-	 ;; Lists with something in them need special treatment.
-	 (let* ((slot-idx (- (eieio--slot-name-index class slot)
-                             (eval-when-compile eieio--object-num-slots)))
-                (type (cl--slot-descriptor-type (aref (eieio--class-slots class)
-                                                      slot-idx)))
-                (classtype (eieio-persistent-slot-type-is-class-p type)))
-
-	   (cond ((eq (car proposed-value) 'quote)
-		  (car (cdr proposed-value)))
-
-		 ;; An empty list sometimes shows up as (list), which is dumb, but
-		 ;; we need to support it for backward compat.
-		 ((and (eq (car proposed-value) 'list)
-		       (= (length proposed-value) 1))
-		  nil)
-
-		 ;; List of object constructors.
-		 ((and (eq (car proposed-value) 'list)
-		       ;; 2nd item is a list.
-		       (consp (car (cdr proposed-value)))
-		       ;; 1st elt of 2nd item is a class name.
-		       (class-p (car (car (cdr proposed-value))))
-		       )
-
-		  ;; Check the value against the input class type.
-		  ;; If something goes wrong, issue a smart warning
-		  ;; about how a :type is needed for this to work.
-		  (unless (and
-			   ;; Do we have a type?
-			   (consp classtype) (class-p (car classtype)))
-		    (error "In save file, list of object constructors found, but no :type specified for slot %S of type %S"
-			   slot classtype))
-
-		  ;; We have a predicate, but it doesn't satisfy the predicate?
-		  (dolist (PV (cdr proposed-value))
-		    (unless (child-of-class-p (car PV) (car classtype))
-		      (error "Corrupt object on disk")))
-
-		  ;; We have a list of objects here.  Lets load them
-		  ;; in.
-		  (let ((objlist nil))
-		    (dolist (subobj (cdr proposed-value))
-		      (push (eieio-persistent-convert-list-to-object subobj)
-			    objlist))
-		    ;; return the list of objects ... reversed.
-		    (nreverse objlist)))
-		 ;; We have a slot with a single object that can be
-		 ;; saved here.  Recurse and evaluate that
-		 ;; sub-object.
-		 ((and classtype
-                       (seq-some
-                        (lambda (elt)
-                          (child-of-class-p (car proposed-value) elt))
-                        classtype))
-		  (eieio-persistent-convert-list-to-object
-		   proposed-value))
-		 (t
-		  proposed-value))))
-
-	 ((stringp proposed-value)
-	  ;; Else, check for strings, remove properties.
-	  (substring-no-properties proposed-value))
-
-	 (t
-	  ;; Else, just return whatever the constant was.
-	  proposed-value))
-  )
-
-(defun eieio-persistent-slot-type-is-class-p (type)
-  "Return the class referred to in TYPE.
-If no class is referenced there, then return nil."
-  (cond ((class-p type)
-	 ;; If the type is a class, then return it.
-	 type)
-	((and (eq 'list-of (car-safe type)) (class-p (cadr type)))
-	 ;; If it is the type of a list of a class, then return that class and
-	 ;; the type.
-	 (cons (cadr type) type))
-
-        ((and (symbolp type) (get type 'cl-deftype-handler))
-         ;; Macro-expand the type according to cl-deftype definitions.
-         (eieio-persistent-slot-type-is-class-p
-          (funcall (get type 'cl-deftype-handler))))
-
-        ;; FIXME: foo-child should not be a valid type!
-	((and (symbolp type) (string-match "-child\\'" (symbol-name type))
-	      (class-p (intern-soft (substring (symbol-name type) 0
-					       (match-beginning 0)))))
-         (unless eieio-backward-compatibility
-           (error "Use of bogus %S type instead of %S"
-                  type (intern-soft (substring (symbol-name type) 0
-					       (match-beginning 0)))))
-	 ;; If it is the predicate ending with -child, then return
-	 ;; that class.  Unfortunately, in EIEIO, typep of just the
-	 ;; class is the same as if we used -child, so no further work needed.
-	 (intern-soft (substring (symbol-name type) 0
-				 (match-beginning 0))))
-        ;; FIXME: foo-list should not be a valid type!
-	((and (symbolp type) (string-match "-list\\'" (symbol-name type))
-	      (class-p (intern-soft (substring (symbol-name type) 0
-					       (match-beginning 0)))))
-         (unless eieio-backward-compatibility
-           (error "Use of bogus %S type instead of (list-of %S)"
-                  type (intern-soft (substring (symbol-name type) 0
-					       (match-beginning 0)))))
-	 ;; If it is the predicate ending with -list, then return
-	 ;; that class and the predicate to use.
-	 (cons (intern-soft (substring (symbol-name type) 0
-				       (match-beginning 0)))
-	       type))
-
-	((eq (car-safe type) 'or)
-	 ;; If type is a list, and is an `or', return all valid class
-	 ;; types within the `or' statement.
-	 (seq-filter #'eieio-persistent-slot-type-is-class-p (cdr type)))
-
-	(t
-	 ;; No match, not a class.
-	 nil)))
+  (let (createslots)
+    ;; If CLS is an eieio autoload object, then we need to
+    ;; load it.
+    (eieio-class-un-autoload cls)
+
+    ;; Earlier versions of `object-write' added a string name for the
+    ;; object, now obsolete.
+    (when (stringp (car slot-list))
+      (setq slot-list (cdr slot-list)))
+
+    (while slot-list
+      (let ((initarg (car slot-list))
+	    (value (cadr slot-list)))
+
+        ;; Strip out quotes, list functions, and update object
+        ;; constructors as needed.
+        (setq value (eieio-persistent-fix-value value))
+
+        (push initarg createslots)
+        (push value createslots))
+
+      (setq slot-list (cddr slot-list)))
+    ;; Or call `initialize-instance' directly?
+    (apply #'make-instance cls (nreverse createslots))))
+
+(defun eieio-persistent-fix-value (value)
+  "Handle VALUE as the proposed value of an object slot.
+A limited number of functions, such as quote, list, and valid
+object constructor functions are handled specially.  Second, any
+text properties will be stripped from strings."
+  (let (result)
+    (when (consp value)
+      ;; Lists might be quoted, remove that and splice up.
+      (when (eq (car value) 'quote)
+        (setq value (cadr value)))
+      ;; Remove the symbol 'list.
+      (when (eq (car value) 'list)
+        (setq value (cdr value)))
+      ;; Value could have been (list).
+      (when (consp value)
+        (if (class-p (car value))
+            (setq result
+                  (eieio-persistent-make-instance (car value) (cdr value))
+                  value nil)
+          (while (consp value)
+            (push (eieio-persistent-fix-value (car value)) result)
+            (setq value (cdr value))))))
+    (if (eieio-object-p result)
+        result
+      ;; FIXME: Is this inefficient?
+      (nconc (nreverse result)
+             (if (stringp value)
+                 (substring-no-properties value)
+               value)))))
 
 (cl-defmethod object-write ((this eieio-persistent) &optional comment)
   "Write persistent object THIS out to the current stream.
diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
index 738711c9c8..b0cb17ab01 100644
--- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
+++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el
@@ -238,4 +238,62 @@ persistent-with-objs-list-slot
     (persist-test-save-and-compare persist-wols)
     (delete-file (oref persist-wols file))))
 
+;;; Test restoration of objects, lists, and strings.
+
+(defclass persistent-with-strings ()
+  ((slot1
+    :initarg :slot1
+    :type string)
+   (slot2
+    :initarg :slot2
+    :type (list-of string))))
+
+(defclass persistent-with-various-strings (eieio-persistent)
+  ((slot1
+    :initarg :slot1
+    :type cons)
+   (slot2
+    :initarg :slot2
+    :type persistent-with-strings)))
+
+(ert-deftest eieio-test-string-restoration ()
+  "Make sure strings are de-propertized upon restore."
+  (let* ((with-strings
+          (make-instance 'persistent-with-strings
+                         :slot1
+                         (propertize "a string"
+                                     'face 'grep-match-face)
+                         :slot2
+                         (list
+                          (propertize "more"
+                                      'face 'dired-mark-face)
+                          (propertize "strings"
+                                      'display "bad"))))
+         (persist
+          (make-instance 'persistent-with-various-strings
+                         :slot1
+                         (cons 3 (propertize "fruit"
+                                             'display "vegetable"))
+                         :slot2 with-strings
+                         :file (concat default-directory "test-ps6.pt")))
+         restored)
+    (unwind-protect
+        (progn
+          (eieio-persistent-save persist)
+          (setq restored
+                (eieio-persistent-read
+                 (oref persist file)
+                 'persistent-with-various-strings))
+          (should-not
+           (or
+            (text-properties-at
+             0 (cdr (oref restored slot1)))
+            (text-properties-at
+             0 (oref (oref restored slot2) slot1))
+            (text-properties-at
+             0 (car (oref (oref restored slot2) slot2)))
+            (text-properties-at
+             0 (nth 1 (oref (oref restored slot2) slot2))))))
+      (delete-file (oref persist file)))))
+
 ;;; eieio-test-persist.el ends here
-- 
2.15.1