From: Eric Abrahamsen Date: Fri, 28 Aug 2020 00:17:19 +0000 (-0700) Subject: Remove redundant slot validation in eieio-persistent-read X-Git-Tag: emacs-28.0.90~6344 X-Git-Url: http://git.eshelyaron.com/gitweb/?a=commitdiff_plain;h=4d741e577fbab8adf444c6c1930525bb7e8fc08d;p=emacs.git Remove redundant slot validation in eieio-persistent-read Actual object creation (in `make-instance') will later run all slot values through cl-typep, which does a better job of validation. This validation is redundant, and slows the read process down. * lisp/emacs-lisp/eieio-base.el (eieio-persistent-fix-value): Rename from `eieio-persistent-validate/fix-slot-value', as we no longer validate, and we don't care about the slot definition. (eieio-persistent-slot-type-is-class-p): Delete function. (eieio-persistent-convert-list-to-object): Still call `eieio--full-class-object', to trigger an autoload if necessary, but discard the return value. --- diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 2cb1f614ce3..f09d1997eee 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -266,105 +266,75 @@ 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--full-class-object objclass)))) - + (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)) + ;; If OBJCLASS is an eieio autoload object, then we need to + ;; load it (we don't need the return value). + (eieio--full-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)) + ;; Strip out quotes, list functions, and update object + ;; constructors as needed. + (setq value (eieio-persistent-fix-value value)) (push initarg createslots) - (push value createslots) - ) + (push value createslots)) (setq slots (cdr (cdr slots)))) - (apply #'make-instance objclass (nreverse createslots)) + (apply #'make-instance objclass (nreverse createslots)))) - ;;(eval inputlist) - )) +(defun eieio-persistent-fix-value (proposed-value) + "Fix PROPOSED-VALUE. +Remove leading quotes from lists, and the symbol `list' from the +head of lists. Explicitly construct any objects found, and strip +any text properties from string values. -(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." +This function will descend into the contents of lists, hash +tables, and vectors." (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 "Invalid object: slot member %s does not match class %s" - (car PV) (car classtype)))) - - ;; 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)) - (if (listp classtype) classtype (list classtype)))) - (eieio-persistent-convert-list-to-object - proposed-value)) - (t - proposed-value)))) + (cond ((eq (car proposed-value) 'quote) + (while (eq (car-safe proposed-value) 'quote) + (setq proposed-value (car (cdr proposed-value)))) + proposed-value) + + ;; An empty list sometimes shows up as (list), which is dumb, but + ;; we need to support it for backward compar. + ((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))))) + + ;; 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. + ((class-p (car proposed-value)) + (eieio-persistent-convert-list-to-object + proposed-value)) + (t + proposed-value))) ;; For hash-tables and vectors, the top-level `read' will not ;; "look inside" member values, so we need to do that ;; explicitly. Because `eieio-override-prin1' is recursive in @@ -377,8 +347,7 @@ Second, any text properties will be stripped from strings." (if (class-p (car-safe value)) (eieio-persistent-convert-list-to-object value) - (eieio-persistent-validate/fix-slot-value - class slot value)))) + (eieio-persistent-fix-value value)))) proposed-value) proposed-value) @@ -389,70 +358,16 @@ Second, any text properties will be stripped from strings." (if (class-p (car-safe val)) (eieio-persistent-convert-list-to-object val) - (eieio-persistent-validate/fix-slot-value - class slot val))))) + (eieio-persistent-fix-value val))))) 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))) + ((stringp proposed-value) + ;; Else, check for strings, remove properties. + (substring-no-properties proposed-value)) (t - ;; No match, not a class. - nil))) + ;; Else, just return whatever the constant was. + proposed-value))) (cl-defmethod object-write ((this eieio-persistent) &optional comment) "Write persistent object THIS out to the current stream.