-;;; eieio-base.el --- Base classes for EIEIO.
+;;; eieio-base.el --- Base classes for EIEIO. -*- lexical-binding:t -*-
-;;; Copyright (C) 2000-2002, 2004-2005, 2007-2011
-;;; Free Software Foundation, Inc.
+;;; Copyright (C) 2000-2002, 2004-2005, 2007-2014 Free Software
+;;; Foundation, Inc.
;; Author: Eric M. Ludlam <zappo@gnu.org>
-;; Version: 0.2
;; Keywords: OO, lisp
;; Package: eieio
;;; Code:
(require 'eieio)
+(eval-when-compile (require 'cl-lib))
;;; eieio-instance-inheritor
;;
not been set, use values from the parent."
:abstract t)
-(defmethod slot-unbound ((object eieio-instance-inheritor) class slot-name fn)
+(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.
"Clone OBJ, initializing `:parent' to OBJ.
All slots are unbound, except those initialized with PARAMS."
(let ((nobj (make-vector (length obj) eieio-unbound))
- (nm (aref obj object-name))
+ (nm (eieio--object-name obj))
(passname (and params (stringp (car params))))
(num 1))
(aset nobj 0 'object)
- (aset nobj object-class (aref obj object-class))
+ (setf (eieio--object-class nobj) (eieio--object-class obj))
;; The following was copied from the default clone.
(if (not passname)
(save-match-data
(if (string-match "-\\([0-9]+\\)" nm)
(setq num (1+ (string-to-number (match-string 1 nm)))
nm (substring nm 0 (match-beginning 0))))
- (aset nobj object-name (concat nm "-" (int-to-string num))))
- (aset nobj object-name (car params)))
+ (setf (eieio--object-name nobj) (concat nm "-" (int-to-string num))))
+ (setf (eieio--object-name nobj) (car params)))
;; Now initialize from params.
(if params (shared-initialize nobj (if passname (cdr params) params)))
(oset nobj parent-instance obj)
:abstract t)
(defmethod initialize-instance :AFTER ((this eieio-instance-tracker)
- &rest slots)
+ &rest _slots)
"Make sure THIS is in our master list of this class.
Optional argument SLOTS are the initialization arguments."
;; Theoretically, this is never called twice for a given instance.
A singleton is a class which will only ever have one instance."
:abstract t)
-(defmethod constructor :STATIC ((class eieio-singleton) name &rest slots)
+(defmethod constructor :STATIC ((class eieio-singleton) _name &rest _slots)
"Constructor for singleton CLASS.
NAME and SLOTS initialize the new object.
This constructor guarantees that no matter how many you request,
;; 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
))))
(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 class (eieio--check-type class-p class))
(let ((ret nil)
(buffstr nil))
(unwind-protect
;; 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 (eieio--class-public-type (class-v class))
+ 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."
OPERATION is the type of access, such as `oref' or `oset'.
NEW-VALUE is the value that was being set into SLOT if OPERATION were
a set type."
- (if (or (eq slot-name 'object-name)
- (eq slot-name :object-name))
+ (if (memq slot-name '(object-name :object-name))
(cond ((eq operation 'oset)
(if (not (stringp new-value))
(signal 'invalid-slot-type
(list obj slot-name 'string new-value)))
- (object-set-name-string obj new-value))
- (t (object-name-string obj)))
+ (eieio-object-set-name-string obj new-value))
+ (t (eieio-object-name-string obj)))
(call-next-method)))
(provide 'eieio-base)