X-Git-Url: http://git.hcoop.net/bpt/emacs.git/blobdiff_plain/fa0cff43e861a49d9f992ffccbe4f71e29d71e1a..ba03d0d932888f687ae9c9fb12e20908c6b0620f:/lisp/emacs-lisp/eieio-base.el

diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el
index b573af29ee..69fe762887 100644
--- a/lisp/emacs-lisp/eieio-base.el
+++ b/lisp/emacs-lisp/eieio-base.el
@@ -1,11 +1,11 @@
 ;;; eieio-base.el --- Base classes for EIEIO.
 
-;;; Copyright (C) 2000, 2001, 2002, 2004, 2005, 2007, 2008, 2009, 2010
+;;; Copyright (C) 2000-2002, 2004-2005, 2007-2012
 ;;; Free Software Foundation, Inc.
 
 ;; Author: Eric M. Ludlam  <zappo@gnu.org>
-;; Version: 0.2
 ;; Keywords: OO, lisp
+;; Package: eieio
 
 ;; This file is part of GNU Emacs.
 
@@ -53,7 +53,7 @@ not been set, use values from the parent."
 
 (defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn)
   "If a slot OBJECT in this CLASS is unbound, try to inherit, or throw a signal.
-SLOT-NAME is the offending slot.  FN is the function signalling the error."
+SLOT-NAME is the offending slot.  FN is the function signaling the error."
   (if (slot-boundp object 'parent-instance)
       ;; It may not look like it, but this line recurses back into this
       ;; method if the parent instance's slot is unbound.
@@ -177,7 +177,7 @@ only one object ever exists."
 ;; calculate path names relative to a given instance.  This will
 ;; make the saved object location independent by converting all file
 ;; references to be relative to the directory the object is saved to.
-;; You must call `eieio-peristent-path-relative' on each file name
+;; You must call `eieio-persistent-path-relative' on each file name
 ;; saved in your object.
 (defclass eieio-persistent ()
   ((file :initarg :file
@@ -224,8 +224,16 @@ a file.  Optional argument NAME specifies a default file name."
 			      ))))
   (oref this file))
 
-(defun eieio-persistent-read (filename)
-  "Read a persistent object from FILENAME, and return it."
+(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
+    (message "Unsafe call to `eieio-persistent-read'."))
+  (when (and class (not (class-p class)))
+    (signal 'wrong-type-argument (list 'class-p class)))
   (let ((ret nil)
 	(buffstr nil))
     (unwind-protect
@@ -238,13 +246,171 @@ a file.  Optional argument NAME specifies a default file name."
 	  ;; so that any initialize-instance calls that depend on
 	  ;; the current buffer will work.
 	  (setq ret (read buffstr))
-	  (if (not (child-of-class-p (car ret) 'eieio-persistent))
-	      (error "Corrupt object on disk"))
-	  (setq ret (eval ret))
+	  (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
+			      (and allow-subclass
+				   (child-of-class-p (car ret) class)) ; subclasses
+			      )))
+	    (error "Corrupt object on disk: Invalid saved class"))
+	  (setq ret (eieio-persistent-convert-list-to-object 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.
+
+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 OBJCLASS is an eieio autoload object, then we need to load it.
+    (eieio-class-un-autoload objclass)
+
+    (while slots
+      (let ((name (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
+		     objclass name value))
+
+	(push name createslots)
+	(push value createslots)
+	)
+
+      (setq slots (cdr (cdr slots))))
+
+    (apply 'make-instance objclass objname (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 nil slot))
+	       (type nil)
+	       (classtype nil))
+	   (setq slot-idx (- slot-idx 3))
+	   (setq type (aref (aref (class-v class) class-public-type)
+			    slot-idx))
+
+	   (setq 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)
+
+		  ;; We have a slot with a single object that can be
+		  ;; saved here.  Recurse and evaluate that
+		  ;; sub-object.
+		 ((and classtype (class-p classtype)
+		       (child-of-class-p (car proposed-value) classtype))
+		  (eieio-persistent-convert-list-to-object
+		   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"
+			   slot))
+
+		  ;; 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)))
+		 (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 refered 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 (symbolp type) (string-match "-child$" (symbol-name type))
+	      (class-p (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))))
+
+	((and (symbolp type) (string-match "-list$" (symbol-name type))
+	      (class-p (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))
+
+	((and (consp type) (eq (car type) 'or))
+	 ;; If type is a list, and is an or, it is possibly something
+	 ;; like (or null myclass), so check for that.
+	 (let ((ans nil))
+	   (dolist (subtype (cdr type))
+	     (setq ans (eieio-persistent-slot-type-is-class-p
+			subtype)))
+	   ans))
+
+	(t
+	 ;; No match, not a class.
+	 nil)))
+
 (defmethod object-write ((this eieio-persistent) &optional comment)
   "Write persistent object THIS out to the current stream.
 Optional argument COMMENT is a header line comment."
@@ -328,5 +494,4 @@ a set type."
 
 (provide 'eieio-base)
 
-;; arch-tag: 6260571e-9e8a-41a0-880f-a937b0c2ea8b
 ;;; eieio-base.el ends here