[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Sun Feb 19 04:53:01 UTC 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 at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at 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 at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at 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 at common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg at common-lisp.net> <blee at 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]
More information about the Elephant-cvs
mailing list