[elephant-cvs] CVS elephant/src/elephant - elephant-cvs@common-lisp.net - mailman3.common-lisp.net

19 Feb 2006


      Update of /project/elephant/cvsroot/elephant/src/elephant
In directory common-lisp:/tmp/cvs-serv7130/src/elephant
Added Files:
    backend.lisp cache.lisp classes.lisp classindex-utils.lisp 
    classindex.lisp cmu-mop-patches.lisp collections.lisp 
    controller.lisp elephant.lisp metaclasses.lisp migrate.lisp 
    openmcl-mop-patches.lisp serializer.lisp transactions.lisp 
    variables.lisp 
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp	2006/02/19 04:53:01	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; backend.lisp -- Namespace support for backends
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; blee@common-lisp.net
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; ablumberg@common-lisp.net blee@common-lisp.net
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package :cl-user)
(defpackage :elephant-backend
  (:documentation "Backends should use this to get access to internal symbols
   of elephant that importers of elephant shouldn't see.  Backends should also
   import elephant to get use-api generic function symbols, classes and globals")
  (:import-from #:elephant
    	;; Variables
    	#:*cachesize*
    	#:*dbconnection-spec* ;; shouldn't need this
    	#:connection-is-indeed-open
    	;; Persistent objects
    	#:oid #:get-con
    	#:next-oid 
    	#:persistent-slot-writer
    	#:persistent-slot-reader
    	#:persistent-slot-boundp
    	#:persistent-slot-makunbound
    	;; Controllers
    	#:open-controller
    	#:close-controller
    	#:controller-spec
    	#:controller-root
    	#:controller-class-root
    	#:root
    	#:class-root
    	#:flush-instance-cache
    	;; Collection generic functions
    	#:build-indexed-btree #:build-btree
    	#:deserialize #:serialize #:existsp
    	;; Cursor accessors
    	#:cursor-btree
    	#:cursor-oid
    	#:cursor-initialized-p
    	;; Misc
    	#:slot-definition-name
    	#:register-backend-con-init
    	#:lookup-backend-con-init
    	;; Transactions
    	#:execute-transaction
    	#:controller-start-transaction
    	#:controller-commit-transaction
    	#:controller-abort-transaction
    	)
  (:export 
    	;; Variables
    	#:*cachesize*
    	#:*dbconnection-spec* ;; shouldn't need this
    	#:connection-is-indeed-open
    	;; Persistent objects
    	#:oid #:get-con 
    	#:next-oid 
    	#:persistent-slot-writer
    	#:persistent-slot-reader
    	#:persistent-slot-boundp
    	#:persistent-slot-makunbound
    	;; Controllers
    	#:open-controller
    	#:close-controller
    	#:controller-spec
    	#:controller-root
    	#:controller-class-root
    	#:root
    	#:class-root
    	#:flush-instance-cache
    	;; Collection generic functions
    	#:build-indexed-btree #:build-btree
    	#:deserialize #:serialize #:existsp
    	;; Cursor accessors
    	#:cursor-btree
    	#:cursor-oid
    	#:cursor-initialized-p
    	;; Misc
    	#:slot-definition-name
    	#:register-backend-con-init
    	#:lookup-backend-con-init
    	;; Transactions
    	#:execute-transaction
    	#:controller-start-transaction
    	#:controller-commit-transaction
    	#:controller-abort-transaction
    	))
    	--- /project/elephant/cvsroot/elephant/src/elephant/cache.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/cache.lisp	2006/02/19 04:53:01	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; migrate.lisp -- Migrate between repositories
;;; 
;;; Initial version 8/26/2004 by Ben Lee
;;; blee@common-lisp.net
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; ablumberg@common-lisp.net blee@common-lisp.net
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package "ELEPHANT")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Portable value-weak hash-tables for the cache: when the
;;; values are collected, the entries (keys) should be
;;; flushed from the table too
(defun make-cache-table (&rest args)
  "Make a values-weak hash table: when a value has been
collected, so are the keys."
  #+(or cmu sbcl scl)
  (apply #'make-hash-table args)
  #+allegro
  (apply #'make-hash-table :values :weak args)
  #+lispworks
  (apply #'make-hash-table :weak-kind :value args)
  #+openmcl
  (apply #'make-hash-table :weak :value args)
  #-(or cmu sbcl scl allegro lispworks)
  (apply #'make-hash-table args)
  )
#+openmcl
(defclass cleanup-wrapper ()
  ((cleanup :accessor cleanup :initarg :cleanup)
   (value :accessor value :initarg :value)))
#+openmcl
(defmethod ccl:terminate ((c cleanup-wrapper))
  (funcall (cleanup c)))
(defun get-cache (key cache)
  "Get a value from a cache-table."
  #+(or cmu sbcl)
  (let ((val (gethash key cache)))
    (if val (values (weak-pointer-value val) t)
    (values nil nil)))
  #+openmcl 
  (let ((wrap (gethash key cache)))
    (if wrap (values (value wrap) t)
    (values nil nil)))
  #+(or allegro lispworks)
  (gethash key cache)
  )
(defun make-finalizer (key cache)
  #+(or cmu sbcl)
  (lambda () (remhash key cache))
  #+(or allegro openmcl)
  (lambda (obj) (declare (ignore obj)) (remhash key cache))
  )
(defun setf-cache (key cache value)
  "Set a value in a cache-table."
  #+(or cmu sbcl)
  (let ((w (make-weak-pointer value)))
    (finalize value (make-finalizer key cache))
    (setf (gethash key cache) w)
    value)
  #+openmcl
  (let ((w (make-instance 'cleanup-wrapper :value value
    		  :cleanup (make-finalizer key cache))))
    (ccl:terminate-when-unreachable w)
    (setf (gethash key cache) w)
    value)
  #+allegro
  (progn
    (excl:schedule-finalization value (make-finalizer key cache))
    (setf (gethash key cache) value))
  #+lispworks
  (setf (gethash key cache) value)
  )
(defsetf get-cache setf-cache)
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp	2006/02/19 04:53:01	1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; classes.lisp -- persistent objects via metaobjects
;;; 
;;; Initial version 8/26/2004 by Andrew Blumberg
;;; ablumberg@common-lisp.net
;;; 
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; ablumberg@common-lisp.net blee@common-lisp.net
;;;
;;; Elephant users are granted the rights to distribute and use this software
;;; as governed by the terms of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;
(in-package "ELEPHANT")
(defmethod initialize-instance :before  ((instance persistent)
    				 &rest initargs
    				 &key from-oid
    				 (sc *store-controller*))
  "Sets the OID and home controller"
  (declare (ignore initargs))
  (if (null sc)
      (error "Initialize instance for type persistent requires valid store controller argument :sc"))
  (if from-oid
      (setf (oid instance) from-oid)
      (setf (oid instance) (next-oid sc)))
  (setf (:dbcn-spc-pst instance) (controller-spec sc))
  (cache-instance sc instance))
(defclass persistent-object (persistent) ()
  (:metaclass persistent-metaclass)
  (:documentation 
   "Superclass of all user-defined persistent classes.  This is
    automatically inherited if you use the persistent-metaclass
    metaclass."))
(defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses)
  "Ensures we inherit from persistent-object."
  (let* ((persistent-metaclass (find-class 'persistent-metaclass))
     (persistent-object (find-class 'persistent-object))
     (not-already-persistent (loop for superclass in direct-superclasses
    			       never (eq (class-of superclass) persistent-metaclass))))
    (if (and (not (eq class persistent-object)) not-already-persistent)
    (apply #'call-next-method class slot-names
           :direct-superclasses (cons persistent-object
    				  direct-superclasses) args)
    (call-next-method))))
#+allegro
(defun make-persistent-reader (name slot-definition class class-name)
  (eval `(defmethod ,name ((instance ,class-name))
      (slot-value-using-class ,class instance ,slot-definition))))
#+allegro
(defun make-persistent-writer (name slot-definition class class-name)
  (let ((name (if (and (consp name)
    	       (eq (car name) 'setf))
    	  name
    	  `(setf ,name))))
    (eval `(defmethod ,name ((instance ,class-name) value)
         (setf (slot-value-using-class ,class instance ,slot-definition)
    	   value)))))
#+allegro
(defmethod initialize-accessors ((slot-definition persistent-slot-definition) class)
  (let ((readers (slot-definition-readers slot-definition))
    (writers (slot-definition-writers slot-definition))
    (class-name (class-name class)))
    (loop for reader in readers
      do (make-persistent-reader reader slot-definition class class-name))
    (loop for writer in writers
      do (make-persistent-writer writer slot-definition class class-name))))
#+allegro
(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
  (declare (ignore initargs))
  (prog1
      (call-next-method)
    (when (class-finalized-p instance)
      (update-persistent-slots instance (persistent-slot-names instance))
      (update-indexed-record instance (indexed-slot-names-from-defs instance))
      (set-db-synch instance :class)
      (loop with persistent-slots = (persistent-slots instance)
        for slot-def in (class-direct-slots instance)
        when (member (slot-definition-name slot-def) persistent-slots)
        do (initialize-accessors slot-def instance))
      (make-instances-obsolete instance))))
#+(or cmu sbcl openmcl)
(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys)
  (declare (ignore initargs))
  (prog1
      (call-next-method)
    (when (class-finalized-p instance)
      (update-persistent-slots instance (persistent-slot-names instance))
      (update-indexed-record instance (indexed-slot-names-from-defs instance))
      (set-db-synch instance :class)
      (make-instances-obsolete instance))))
;; #+allegro
(defmethod finalize-inheritance :around ((instance persistent-metaclass))
  (prog1
      (call-next-method)
    (when (not (slot-boundp instance '%persistent-slots))
    (setf (%persistent-slots instance) 
          (cons (persistent-slot-names instance) nil)))
    (when (not (slot-boundp instance '%indexed-slots))
      (update-indexed-record instance (indexed-slot-names-from-defs instance)))))
;; #+(or cmu sbcl)
;; (defmethod finalize-inheritance :around ((instance persistent-metaclass))
;;   (prog1
;;       (call-next-method)
;;     (if (not (slot-boundp instance '%persistent-slots))
;; 	(setf (%persistent-slots instance) 
;; 	      (cons (persistent-slot-names instance) nil)))))
(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys)
  "Initializes the persistent slots via initargs or forms.
This seems to be necessary because it is typical for
implementations to optimize setting the slots via initforms
and initargs in such a way that slot-value-using-class et al
aren't used.  We also handle writing any indices after the 
class is fully initialized.  Calls the next method for the transient 
slots."
  (let* ((class (class-of instance))
     (oid (oid instance))
     (persistent-slot-names (persistent-slot-names class)))
    (flet ((persistent-slot-p (item) 
         (member item persistent-slot-names :test #'eq)))
      (let ((transient-slot-inits 
         (if (eq slot-names t)	; t means all slots
    	 (transient-slot-names class)
    	 (remove-if #'persistent-slot-p slot-names)))
        (persistent-slot-inits
         (if (eq slot-names t) persistent-slot-names
    	 (remove-if-not #'persistent-slot-p slot-names))))
    (inhibit-indexing oid)
    (unwind-protect 
    ;; initialize the persistent slots
    (flet ((initialize-from-initarg (slot-def)
    	 (loop for initarg in initargs
    	    with slot-initargs = (slot-definition-initargs slot-def)
    	    when (member initarg slot-initargs :test #'eq)
    	    do 
    	    (setf (slot-value-using-class class instance slot-def) 
    		  (getf initargs initarg))
    	    (return t))))
      (loop for slot-def in (class-slots class)
         unless (initialize-from-initarg slot-def)
         when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq)
         unless (slot-boundp-using-class class instance slot-def)
         do
         (let ((initfun (slot-definition-initfunction slot-def)))
           (when initfun
    	 (setf (slot-value-using-class class instance slot-def)
    	       (funcall initfun)))))
;; 	  (format t "transient-slot-inits ~A~%" transient-slot-inits)
;; 	  (format t "indices boundp ~A~%" (slot-boundp instance 'indices))
;; 	  (format t "indices-caches boundp ~A~%" (slot-boundp instance 'indices-cache))
      ;; let the implementation initialize the transient slots
      (apply #'call-next-method instance transient-slot-inits initargs))
      (uninhibit-indexing oid))
      ;; Inhibit indexing altogether if the object already was defined (ie being created 
          ;;   from an oid) as it should be indexed already.  This hack avoids a deadlock 
          ;;   situation where we write the class or index page that we are currently reading 
          ;;   via a cursor without going through the cursor abstraction. There has to be a 
          ;;   better way to do this.
      (when (and (indexed class) (not from-oid))
        (let ((class-index (find-class-index (class-of instance))))
          (when class-index
    	(with-transaction ()
    	  (setf (get-value oid class-index) instance)))))
      ))))
(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys)
  ;; NOTE: probably should delete discarded slots, but we'll worry about that later
  (declare (ignore property-list discarded-slots added-slots))
  (prog1
      (call-next-method)
    (let* ((class (class-of instance))
       (new-persistent-slots (set-difference (persistent-slots class)
    					 (old-persistent-slots class))))
      ;; Update new persistent slots, the others we get for free (same oid!)
      ;; Isn't this done by the default call-next-method?
      (apply #'shared-initialize instance new-persistent-slots initargs))
    )
  )
(defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key)
  (let* ((old-class (class-of previous))
     (new-class (class-of current))
     (new-persistent-slots (set-difference
    			(persistent-slots new-class)
    			(persistent-slots old-class)))
     (raw-retained-persistent-slots (intersection (persistent-slots new-class)
    					      (persistent-slots old-class)))
[75 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp	2006/02/19 04:53:01	1.1
[218 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp	2006/02/19 04:53:01	1.1
[791 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/cmu-mop-patches.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/cmu-mop-patches.lisp	2006/02/19 04:53:01	1.1
[902 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp	2006/02/19 04:53:01	1.1
[1277 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp	2006/02/19 04:53:01	1.1
[1541 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp	2006/02/19 04:53:01	1.1
[1795 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp	2006/02/19 04:53:01	1.1
[2171 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp	2006/02/19 04:53:01	1.1
[2269 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/openmcl-mop-patches.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/openmcl-mop-patches.lisp	2006/02/19 04:53:01	1.1
[2349 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp	2006/02/19 04:53:01	1.1
[2888 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp	2006/02/19 04:53:01	1.1
[2990 lines skipped]
--- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp	2006/02/19 04:53:01	NONE
+++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp	2006/02/19 04:53:01	1.1
[3087 lines skipped]