procyberian/emacs
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Remove redundant slot validation in eieio-persistent-read

Browse source 
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.
This commit is contained in:
Eric Abrahamsen 2020-08-27 17:17:19 -07:00
parent 649a52822f
commit 4d741e577f
1 changed files with 60 additions and 145 deletions
Download patch file Download diff file Expand all files Collapse all files

205
lisp/emacs-lisp/eieio-base.el
View file

@ -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)
(while (eq (car-safe proposed-value) 'quote)
(setq proposed-value (car (cdr proposed-value))))
proposed-value)
(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 compar.
((and (eq (car proposed-value) 'list)
(= (length proposed-value) 1))
nil)
;; 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)))))
;; 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))))
;; 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.