[COMMIT eieio] Validate persistent objects read from disk, eieio-base.el

APPROVE COMMIT NOTE: This patch has been committed # HG changeset patch # User Aidan Kehoe <kehoea(a)parhasard.net&gt; # 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&gt; * 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. 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&gt; + + * 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&gt; * 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." - (save-excursion - (let ((ret nil)) - (set-buffer (get-buffer-create " *tmp eieio read*")) - (unwind-protect - (progn - (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*")) - ret))) +(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 +being pedantic." + (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*"))) + (unwind-protect + (progn + (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)) + (current-buffer)))) + (when (not (child-of-class-p (car ret) 'eieio-persistent)) + (error + "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))))) + (error + "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)) + 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. + +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) + (class + (progn + (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)) + 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 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." + (cond + ;; 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. + (t + (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) + slot)) + (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’ (C. Moore)