From 858b6ca64ad088362800e3ce4d5c0b34114f9b06 Mon Sep 17 00:00:00 2001 From: Eric Abrahamsen 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