NOTE: This patch has been committed
# HG changeset patch
# User Aidan Kehoe <kehoea(a)parhasard.net>
# Date 1528634755 -3600
# Sun Jun 10 13:45:55 2018 +0100
# Node ID e15a6d55c51380350e6b85feebf86b024810c4be
# Parent 23e987c5279fb8565e1e3be069b7802d16952735
Validate persistent objects read from disk, eieio-base.el
2018-06-10 Aidan Kehoe <kehoea(a)parhasard.net>
* eieio-base.el (eieio-persistent-read): Sync this with GNU Emacs.
* eieio-base.el (eieio-persistent-convert-list-to-object): New,
implementation taken from EDE.
* eieio-base.el (eieio-persistent-validate/fix-slot-value): New,
implementation taken from EDE.
With persistent objects, no longer call #'eval on forms read
from disk, do some validation before initialising their slots.
diff -r 23e987c5279f -r e15a6d55c513 ChangeLog
--- a/ChangeLog Thu May 15 21:01:40 2014 +0200
+++ b/ChangeLog Sun Jun 10 13:45:55 2018 +0100
＠＠ -1,3 +1,14 ＠＠
+2018-06-10 Aidan Kehoe <kehoea(a)parhasard.net>
+ * eieio-base.el:
+ * eieio-base.el (eieio-persistent-read): Sync this with GNU Emacs.
+ * eieio-base.el (eieio-persistent-convert-list-to-object): New,
+ implementation taken from EDE.
+ * eieio-base.el (eieio-persistent-validate/fix-slot-value): New,
+ implementation taken from EDE.
+ With persistent objects, no longer call #'eval on forms read
+ from disk, do some validation before initialising their slots.
2014-05-15 Norbert Koch <viteno(a)xemacs.org>
* Makefile (VERSION): XEmacs package 1.09 released.
diff -r 23e987c5279f -r e15a6d55c513 eieio-base.el
--- a/eieio-base.el Thu May 15 21:01:40 2014 +0200
+++ b/eieio-base.el Sun Jun 10 13:45:55 2018 +0100
＠＠ -202,22 +202,113 ＠＠
(oref this file))
-(defun eieio-persistent-read (filename)
- "Read a persistent object from FILENAME."
- (let ((ret nil))
- (set-buffer (get-buffer-create " *tmp eieio read*"))
- (insert-file-contents filename nil nil nil t)
- (goto-char (point-min))
- (setq ret (read (current-buffer)))
- (if (not (child-of-class-p (car ret) 'eieio-persistent))
- (error "Corrupt object on disk"))
- (setq ret (eval ret))
- (oset ret file filename))
- (kill-buffer " *tmp eieio read*"))
+(defun eieio-persistent-read (filename &optional class allow-subclass)
+ "Read a persistent object from FILENAME, and return it.
+Signal an error if the object in FILENAME is not a constructor
+for CLASS. Optional ALLOW-SUBCLASS says that it is ok for
+`eieio-persistent-read' to load in subclasses of class instead of
+ (unless class
+ (warn "`eieio-persistent-read' called without specifying a class"))
+ (when class (check-type class class))
+ (let ((ret nil)
+ (buffer (get-buffer-create " *tmp eieio read*")))
+ (setq ret
+ ;; Do the read in the buffer the read was initialized from
+ ;; so that any initialize-instance calls that depend on
+ ;; the current buffer will work.
+ (read (with-current-buffer buffer
+ (insert-file-contents filename nil nil nil t)
+ (goto-char (point-min))
+ (when (not (child-of-class-p (car ret) 'eieio-persistent))
+ "Invalid object: %s is not a subclass of `eieio-persistent'"
+ (car ret)))
+ (when (and class
+ (not (or (eq (car ret) class) ; same class
+ (and allow-subclass ; subclass
+ (child-of-class-p (car ret) class)))))
+ "Invalid object: %s is not an object of class %s nor a subclass"
+ (car ret) class))
+ (setq ret (eieio-persistent-convert-list-to-object ret))
+ (oset ret file filename))
+ (kill-buffer buffer))
+(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
+Note: This function recurses when a slot of :type of some object is
+identified, and needing more object creation."
+ (let* ((objclass (nth 0 inputlist))
+ ;; (objname (nth 1 inputlist))
+ (slots (nthcdr 2 inputlist))
+ (createslots nil)
+ (if (and (fboundp objclass)
+ (eq 'autoload (car-safe (symbol-function objclass))))
+ ;; Execute the autoload as a side-effect of this
+ ;; call, so the class info is available.
+ (function-min-args 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)
+ (push initarg createslots)
+ (push value createslots))
+ (setq slots (cdr (cdr slots))))
+ (apply #'make-instance class (nreverse createslots))))
+(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."
+ ;; XEmacs; we have no syntax for fat strings, this has no value.
+ ;((stringp proposed-value)
+ ;(substring-no-properties proposed-value))
+ ;; Non-cons is fine (well, it may not be, but we can trust
+ ;; #'make-instance to error if necessary).
+ ((atom proposed-value) proposed-value)
+ ;; Quoted constant is also fine.
+ ((eq (car proposed-value) 'quote)
+ (cadr proposed-value))
+ ((eq (car proposed-value) 'list)
+ (mapcar #'eieio-persistent-convert-list-to-object (cdr proposed-value)))
+ ;; XEmacs; GNU checks the :type slot of the class for the proposed
+ ;; value and then refuses to instantiate if the form doesn't match
+ ;; this type, or if there's no type information specified. This is
+ ;; useless, though, since #'make-instance will error if the type doesn't
+ ;; match anyway, if type information is specified. The vector literal
+ ;; syntax also means that random objects can be instantiated (but not
+ ;; converted into slots, if the type info is specified for
+ ;; #'make-instance), both under XEmacs and GNU Emacs, which is only
+ ;; an issue if we have done something stupid in another class.
+ (let* ((c (eieio-field-name-index class nil slot))
+ (eieio-skip-typecheck nil))
+ (if (not c)
+ (signal 'invalid-slot-name (list class slot))
+ (if (not (class-p (car proposed-value)))
+ (signal 'invalid-slot-type (list (car proposed-value)
+ (eieio-persistent-convert-list-to-object proposed-value)))))))
(defmethod object-write ((this eieio-persistent) &optional comment)
"Write persistent object THIS out to the current stream.
‘As I sat looking up at the Guinness ad, I could never figure out /
How your man stayed up on the surfboard after forty pints of stout’
Show replies by date