elephant-cvs
Threads by month
- ----- 2025 -----
- July
- June
- May
- April
- March
- February
- January
- ----- 2024 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2023 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2022 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2021 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2020 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2019 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2018 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2017 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2016 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2015 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2014 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2013 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2012 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2011 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2010 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2009 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2008 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2007 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2006 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2005 -----
- December
- November
- October
- September
- August
- July
- June
- May
- April
- March
- February
- January
- ----- 2004 -----
- December
- November
- October
- September
- August
February 2006
- 2 participants
- 108 discussions
Update of /project/elephant/cvsroot/elephant/src/db-clsql
In directory common-lisp:/tmp/cvs-serv9084/src/db-clsql
Modified Files:
sql-controller.lisp
Log Message:
Minor changes for sql-backend
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 04:53:00 1.1
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 05:13:02 1.2
@@ -19,7 +19,7 @@
(in-package "ELEPHANT")
(defpackage elephant-clsql
- (:use :common-lisp :elephant :uffi))
+ (:use :common-lisp :elephant :elephant-memutil :uffi :elephant-backend :cl-base64))
(in-package "ELEPHANT-CLSQL")
@@ -57,18 +57,17 @@
'with-transaction-sql
)
-(defun sql-store-spec-p (path)
- (listp path))
+(defun sql-store-spec-p (spec)
+ (and (listp spec)
+ (eq (first spec) :clsql)))
(defun sql-test-and-construct (spec)
(if (sql-store-spec-p spec)
(open-store-sql spec)
- nil)
- )
+ nil))
-(eval-when ( :load-toplevel)
- (register-strategy 'sql-test-and-construct)
- )
+(eval-when (:load-toplevel)
+ (register-backend-con-init :clsql 'sql-test-and-construct))
(defmacro with-open-store-sql ((spec) &body body)
"Executes the body with an open controller,
@@ -326,8 +325,8 @@
(recover-fatal nil)
(thread t))
(the sql-store-controller
- (let* ((dbtype (car (:dbcn-spc sc)))
- (con (clsql:connect (cdr (:dbcn-spc sc))
+ (let* ((dbtype (car (second (:dbcn-spc sc))))
+ (con (clsql:connect (cdr (second (:dbcn-spc sc)))
;; WARNING: This line of code forces us to use postgresql.
;; If this were parametrized upwards we could concievably try
;; other backends.
1
0
Update of /project/elephant/cvsroot/elephant/tests
In directory common-lisp:/tmp/cvs-serv7130/tests
Modified Files:
elephant-tests.lisp mop-tests.lisp testcollections.lisp
testindexing.lisp testmigration.lisp testserializer.lisp
testsleepycat.lisp
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/17 22:45:21 1.13
+++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 04:53:02 1.14
@@ -60,86 +60,102 @@
;; Putting this in to make the test work; I have no idea what it means...
(deftype array-or-pointer-char () '(or array t))
-
-(defvar *testdb-path*
- (namestring
- (merge-pathnames
- #p"tests/testdb/"
- (asdf:component-pathname (asdf:find-system 'elephant-tests)))))
-
-(defvar *testdb-path2*
- (namestring
- (merge-pathnames
- #p"tests/testdb2/"
- (asdf:component-pathname (asdf:find-system 'elephant-tests)))))
-
-(defvar *sleepycatdb-path*
- (namestring
- (merge-pathnames
- #p"tests/testsleepycat/"
- (asdf:component-pathname (asdf:find-system 'elephant-tests)))))
-
-(defvar *testpg-path*
-'(:postgresql "localhost.localdomain" "test" "postgres" ""))
-
-(defvar *testsqlite3-path*
-;; This is of the form '(filename &optional init-function),
-;; and using :memory: as a file name will get you an completely in-memory system...
-;; '(":memory:")
- '(:sqlite3 "sqlite3-test.db")
-)
-
-(defvar *test-path-primary*
- *testdb-path*
-)
-
-(defvar *test-path-secondary*
- *testdb-path2*
-)
-
-(defun do-all-tests()
- (progn
- (do-all-tests-spec *testdb-path*)
- (do-all-tests-spec *testsqlite3-path*)
- ))
-
-(defun do-test-spec (testname &optional (spec *testdb-path*))
- "For easy interactive running of tests while debugging"
- (when spec
+(defvar *testbdb-spec*
+ `(:bdb
+ ,(namestring
+ (merge-pathnames
+ #p"tests/testdb/"
+ (asdf:component-pathname (asdf:find-system 'elephant-tests)))))
+ "The primary test spec for testing sleepycat")
+
+(defvar *testbdb-spec2*
+ `(:bdb
+ ,(namestring
+ (merge-pathnames
+ #p"tests/testdb2/"
+ (asdf:component-pathname (asdf:find-system 'elephant-tests)))))
+ "A second bdb test directory for bdb-to-bdb tests")
+
+(defvar *testpg-spec*
+ '(:clsql (:postgresql "localhost.localdomain" "test" "postgres" "")))
+
+(defvar *testsqlite3-spec*
+ '(:clsql (:sqlite3 "sqlite3-test.db"))
+ "This is of the form '(filename &optional init-function),")
+
+(defvar *testsqlite3-memory-spec*
+ '(:clsql (:sqlite3 :memory))
+ "Using :memory: as a file name will get you an completely in-memory system")
+
+
+;;
+;; GUIDE TO TESTING
+;;
+;; 1) Set *default-spec* to the above spec of your choice
+;; 2) Call (do-backend-tests) to test the standard API
+;; 3) To test migration: (do-migration *default-spec* <second-spec>) inserting a second
+;; spec, typically a bdb spec or create another instance of a sql db depending on
+;; your configuration
+;; 4) A backend is green if it passes do-backend-tests and can succesfully be
+;; used as spec1 or spec2 argument in the migration test
+;;
+
+(defvar *default-spec* nil
+ "Set this at the REPL to have the following interfaces default to a given spec
+ mostly here to save typing...")
+
+(defun do-backend-tests (&optional (spec *default-spec*))
+ "Will test a specific backend based on the spec. Note,
+ if you run a :bdb backend test it will load sleepycat
+ specific tests which should silently succeed if you
+ test another backend"
+ (when (and (consp spec) (symbolp (car spec)))
(with-open-store (spec)
+ (cond ((eq (car spec) :bdb)
+ (asdf:operate 'asdf:load-op :elephant-tests-bdb)))
(let ((*auto-commit* nil))
- (do-test testname)))))
-
-(defun do-all-tests-spec(spec)
+ (do-tests)))))
+
+(defun do-test-spec (testname &optional (spec *default-spec*))
+ "For easy interactive running of single tests while debugging"
(when spec
(with-open-store (spec)
(let ((*auto-commit* nil))
- (declare (special *auto-commit*)
- (dynamic-extent *auto-commit*))
- (do-tests)))))
+ (do-test testname)))))
-(defun do-indexing-tests ()
- (declare (special *old-store*))
- (setq *old-store* *store-controller*)
- (unwind-protect
- (progn
- (let ((*auto-commit* nil))
- (declare (special *auto-commit*)
- (dynamic-extent *auto-commit*))
- (open-store *testdb-path*)
- (print (do-test 'indexing-basic))
- (print (do-test 'indexing-inherit))
- (print (do-test 'indexing-range))
- (print (do-test 'indexing-reconnect-db))
- (print (do-test 'indexing-change-class))
- (print (do-test 'indexing-redef-class))
- (print (do-test 'indexing-explicit-changes))
- (print (do-test 'indexing-timing))
- (close-store)))
- (setq *store-controller* *old-store*)))
+(defun do-migration-tests (spec1 spec2)
+ "Interface to do explicit migration tests between backends"
+ (let ((*test-spec-primary* spec1)
+ (*test-spec-secondary* spec2))
+ (declare (special *test-spec-primary* *test-spec-secondary*))
+ (print (do-test 'remove-element))
+ (print (do-test 'migrate1))
+ (print (do-test 'migrate2))
+ (print (do-test 'migrate3))
+ (print (do-test 'migrate4))
+ (print (do-test 'migrate5))))
+
+
+
+;;
+;; Various test groups
+;;
+
+(defun do-indexing-tests (&optional (spec *default-spec*))
+ "Just test indexing"
+ (with-open-store (spec)
+ (print (do-test 'indexing-basic))
+ (print (do-test 'indexing-inherit))
+ (print (do-test 'indexing-range))
+ (print (do-test 'indexing-reconnect-db))
+ (print (do-test 'indexing-change-class))
+ (print (do-test 'indexing-redef-class))
+ (print (do-test 'indexing-explicit-changes))
+ (print (do-test 'indexing-timing))))
(defun do-crazy-pg-tests()
- (open-store *testpg-path*)
+ "Specific problematic pg tests"
+ (open-store *testpg-spec*)
(do-test 'indexed-btree-make)
(do-test 'add-indices)
(do-test 'test-indices)
@@ -148,24 +164,23 @@
(close-store)
)
-(defun do-migrate-test-spec(spud)
- (with-open-store(spud)
- (let ((*auto-commit* nil))
- (assert (equal (do-test 'remove-element) 'remove-element))
- (assert (equal (do-test 'migrate1) 'migrate1))
- (assert (equal (do-test 'migrate2) 'migrate2))
- (assert (equal (do-test 'migrate3) 'migrate3))
- (assert (equal (do-test 'migrate4) 'migrate4))
- (assert (equal (do-test 'migrate5) 'migrate5))
- t
- )
- ))
-
(defun find-slot-def (class-name slot-name)
(find-if #'(lambda (slot-def)
(eq (slot-definition-name slot-def) slot-name))
(class-slots (find-class class-name))))
+
+(defvar *sleepycatdb-spec*
+ `(:bdb . ,(namestring
+ (merge-pathnames
+ #p"tests/testsleepycat/"
+ (asdf:component-pathname (asdf:find-system 'elephant-tests))))))
+
+
+;;
+;; UTILITIES
+;;
+
(defmacro finishes (&body body)
`(handler-case
(progn ,@body)
--- /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2006/02/05 23:13:08 1.10
+++ /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2006/02/19 04:53:02 1.11
@@ -221,16 +221,19 @@
(slot2 foo))))
1 2)
-(deftest change-class2
- (with-transaction (:store-controller *store-controller*)
- (let ((foo (build-btree *store-controller*)))
- (change-class foo (find-class
- (if (typep *store-controller* 'bdb-store-controller)
- 'bdb-indexed-btree
- 'sql-indexed-btree)
- ))
- (is-not-null (indices foo))))
- t)
+;;
+;; ISE NOTE: This violates single backend testing, I've removed it for now
+;;
+;; (deftest change-class2
+;; (with-transaction (:store-controller *store-controller*)
+;; (let ((foo (make-btree *store-controller*)))
+;; (change-class foo (find-class
+;; (if (typep *store-controller* 'bdb-store-controller)
+;; 'bdb-indexed-btree
+;; 'sql-indexed-btree)
+;; ))
+;; (is-not-null (indices foo))))
+;; t)
(deftest change-class3
(progn
--- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/07 23:23:51 1.11
+++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/19 04:53:02 1.12
@@ -22,8 +22,7 @@
(let ((x (gensym)))
(add-to-root "x" x)
;; Clear instances
- (setf (elephant::instance-cache *store-controller*)
- (elephant::make-cache-table :test #'eql))
+ (flush-instance-cache *store-controller*)
;; Are gensyms equal across db instantiations?
;; This forces a refetch of the object from db
(setq rv (equal (format nil "~A" x)
@@ -55,17 +54,9 @@
(defvar bt)
(deftest btree-make
- (finishes (setq bt (build-btree *store-controller*)))
+ (finishes (setq bt (make-btree *store-controller*)))
t)
-;; This is a very dangerous and naughty statement.
-;; It was probably placed in this file for a good reason,
-;; but nothing seems to reset it. The result is that after loading
-;; theses tests, nothing works as you expect it later.
-;; It may be that the proper fix is not just to take it out,
-;; but that is the best that I can do right now.
-;; (setq *auto-commit* nil)
-
(deftest btree-put
(finishes
(with-transaction (:store-controller *store-controller*)
@@ -115,7 +106,7 @@
(deftest indexed-btree-make
(finishes (with-transaction (:store-controller *store-controller*)
- (setq indexed (build-indexed-btree *store-controller*))))
+ (setq indexed (make-indexed-btree *store-controller*))))
t)
(defun key-maker (s key value)
@@ -134,11 +125,18 @@
(values t (slot2 value)))))))
t)
+;; ISE NOTE: indices accessor is not portable across backends in current
+;; system so I'm using alternate access (map-indices) instead
(deftest test-indices
(values
- (= (hash-table-count (indices indexed)) 2)
- (eq index1 (gethash 'slot1 (indices indexed)))
- (eq index2 (gethash 'slot2 (indices indexed))))
+ ;; (= (hash-table-count (indices indexed)) 2)
+ (let ((count 0))
+ (map-indices (lambda (x y) (declare (ignore x y)) (incf count)) indexed)
+ (eq count 2))
+ ;; (gethash 'slot1 (indices indexed)))
+ (eq index1 (get-index indexed 'slot1))
+ ;; (eq index2 (gethash 'slot2 (indices indexed))))
+ (eq index2 (get-index indexed 'slot2)))
t t t)
#|
@@ -321,7 +319,7 @@
(deftest rem-kv
(with-transaction (:store-controller *store-controller*)
- (let ((ibt (build-indexed-btree *store-controller*)))
+ (let ((ibt (make-indexed-btree *store-controller*)))
(loop for i from 0 to 10
do
(setf (get-value i ibt) (* i i)))
@@ -346,7 +344,7 @@
(deftest rem-idexkv
(with-transaction (:store-controller *store-controller*)
- (let* ((ibt (build-indexed-btree *store-controller*))
+ (let* ((ibt (make-indexed-btree *store-controller*))
(id1 (add-index ibt :index-name 'idx1 :key-form 'odd)))
(loop for i from 0 to 10
do
@@ -387,7 +385,7 @@
(deftest make-indexed2
(finishes (with-transaction (:store-controller *store-controller*)
- (setq indexed2 (build-indexed-btree *store-controller*))))
+ (setq indexed2 (make-indexed-btree *store-controller*))))
t)
(defun crunch (s k v)
@@ -473,7 +471,7 @@
;; Note: If this is not done inside a transaction,
;; it HANGS BDB!
(with-transaction (:store-controller *store-controller*)
- (let* ((ibt (build-indexed-btree *store-controller*))
+ (let* ((ibt (make-indexed-btree *store-controller*))
(id1 (add-index ibt :index-name 'idx1 :key-form 'odd)))
(loop for i from 0 to 10
do
@@ -533,7 +531,7 @@
(deftest cur-del2
(with-transaction (:store-controller *store-controller*)
- (let* ((ibt (build-indexed-btree *store-controller*))
+ (let* ((ibt (make-indexed-btree *store-controller*))
(id1 (add-index ibt :index-name 'idx1 :key-form 'odd)))
(loop for i from 0 to 10
do
@@ -691,12 +689,12 @@
(setq *auto-commit* t)
(remove-from-root key)
(setf exists1
- (from-root-existsp key)
+ (root-existsp key)
)
(add-to-root key 'a)
- (setf exists2 (from-root-existsp key))
+ (setf exists2 (root-existsp key))
(remove-from-root key)
- (setf exists3 (from-root-existsp key))
+ (setf exists3 (root-existsp key))
)
(setq *auto-commit* *prev-commit*)
)
@@ -709,7 +707,7 @@
;; This test not only does not work, it appears to
;; hang sleepycat forcing a recovery!?!?!?!
;; (deftest cursor-put
-;; (let* ((ibt (build-indexed-btree *store-controller*)))
+;; (let* ((ibt (make-indexed-btree *store-controller*)))
;; (let (
;; (index
;; (add-index ibt :index-name 'crunch :key-form 'crunch
--- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/10 01:39:13 1.4
+++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/19 04:53:02 1.5
@@ -20,12 +20,16 @@
(trace elephant::db-transaction-commit)
)
+(defvar inst1)
+(defvar inst2)
+(defvar inst3)
+
;; put list of objects, retrieve on value, range and by class
(deftest indexing-basic
(progn
-;; (format t "Global vars:~%")
-;; (format t "~%basic store: ~A ~A~%" *store-controller* (controller-path *store-controller*))
-;; (format t "auto-commit: ~A~%" *auto-commit*)
+ ;;(format t "Global vars:~%")
+ ;;(format t "~%basic store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*))
+ ;;(format t "auto-commit: ~A~%" *auto-commit*)
(disable-class-indexing 'idx-one :errorp nil)
(setf (find-class 'idx-one) nil)
--- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/05 23:13:08 1.6
+++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/19 04:53:02 1.7
@@ -14,50 +14,53 @@
(in-package :ele-tests)
(deftest remove-element
- (if (or (null *test-path-secondary*)
- (null *test-path-primary*))
+ (if (or (not (boundp '*test-spec-secondary*))
+ (null *test-spec-secondary*))
(progn
- (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.")
+ (format t "~%Single store mode: ignoring")
t)
- (let ((a (vector 'a 'b 'c))
- (ans (vector 'a 'c)))
- (setf a (ele::remove-indexed-element-and-adjust 1 a))
- (and (equal (aref a 0) (aref ans 0))
- (equal (aref a 1) (aref ans 1))
- (equal (length a) (length ans)))))
+ (let ((a (vector 'a 'b 'c))
+ (ans (vector 'a 'c)))
+ (setf a (ele::remove-indexed-element-and-adjust 1 a))
+ (and (equal (aref a 0) (aref ans 0))
+ (equal (aref a 1) (aref ans 1))
+ (equal (length a) (length ans)))))
t)
-
(deftest migrate1
- (if (or (null *test-path-secondary*)
- (null *test-path-primary*))
+ (if (or (not (boundp '*test-spec-secondary*) )
+ (null *test-spec-secondary*))
(progn
- (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.")
+ (format t "~%Single store mode: ignoring")
t)
(let ((old-store *store-controller*)
(*prev-commit* *auto-commit*)
(*auto-commit* t)
- (rv nil))
- (unwind-protect
- (let (
- (sc1 (open-store *test-path-primary*))
- (sc2 (open-store *test-path-secondary*)))
- (add-to-root "x" "y" :store-controller sc1)
- (copy-from-key "x" sc1 sc2)
- (setf rv (equal (get-from-root "x" :store-controller sc1)
- (get-from-root "x" :store-controller sc2))))
- (progn
- (setq *store-controller* old-store)
- (setq *auto-commit* *prev-commit*)))
+ (rv nil)
+ (sc1 nil)
+ (sc2 nil))
+ (unwind-protect
+ (progn
+ (setf sc1 (open-store *test-spec-primary*))
+ (setf sc2 (open-store *test-spec-secondary*))
+ (add-to-root "x" "y" :store-controller sc1)
+ (copy-from-key "x" sc1 sc2)
+ (setf rv (equal (get-from-root "x" :store-controller sc1)
+ (get-from-root "x" :store-controller sc2))))
+ (progn
+ (when sc1 (close-store sc1))
+ (when sc2 (close-store sc2))
+ (setq *store-controller* old-store)
+ (setq *auto-commit* *prev-commit*)))
rv))
- t)
+ t)
(deftest migrate2
- (if (or (null *test-path-secondary*)
- (null *test-path-primary*))
+ (if (or (not (boundp '*test-spec-secondary*) )
+ (null *test-spec-secondary*))
(progn
- (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.")
+ (format t "~%Single store mode: ignoring")
nil)
(let ((old-store *store-controller*)
(*prev-commit* *auto-commit*)
@@ -65,8 +68,8 @@
(rv nil))
(unwind-protect
(let
- ((sc1 (open-store *test-path-primary*))
- (sc2 (open-store *test-path-secondary*)))
+ ((sc1 (open-store *test-spec-primary*))
+ (sc2 (open-store *test-spec-secondary*)))
(let ((ibt (build-btree sc1)))
(loop for i from 0 to 10
do
@@ -80,18 +83,18 @@
(deftest migrate3
- (if (or (null *test-path-secondary*)
- (null *test-path-primary*))
+ (if (or (not (boundp '*test-spec-secondary*) )
+ (null *test-spec-secondary*))
(progn
- (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.")
+ (format t "~%Single store mode: ignoring")
t)
(let ((old-store *store-controller*)
(*prev-commit* *auto-commit*)
(*auto-commit* t)
(rv nil))
(unwind-protect
- (let ((sc1 (open-store *test-path-primary*))
- (sc2 (open-store *test-path-secondary*))
+ (let ((sc1 (open-store *test-spec-primary*))
+ (sc2 (open-store *test-spec-secondary*))
)
(let* ((ibt (build-indexed-btree sc1)))
(let (
@@ -125,10 +128,10 @@
(deftest migrate4
- (if (or (null *test-path-secondary*)
- (null *test-path-primary*))
+ (if (or (not (boundp '*test-spec-secondary*) )
+ (null *test-spec-secondary*))
(progn
- (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.")
+ (format t "~%Single store mode: ignoring")
t)
(finishes
(let ((old-store *store-controller*)
@@ -137,8 +140,8 @@
(rv nil))
(unwind-protect
(let* (
- (sc1 (open-store *test-path-primary*))
- (sc2 (open-store *test-path-secondary*))
+ (sc1 (open-store *test-spec-primary*))
+ (sc2 (open-store *test-spec-secondary*))
)
(let* ((ibt (build-indexed-btree sc1)))
(let (
@@ -158,34 +161,34 @@
t)
(deftest migrate5
- (if (or (null *test-path-secondary*)
- (null *test-path-primary*))
+ (if (or (not (boundp '*test-spec-secondary*) )
+ (null *test-spec-secondary*))
(progn
- (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.")
+ (format t "~%Single store mode: ignoring")
t)
(let ((*prev-commit* *auto-commit*))
- (prog2
- (setq *auto-commit* t)
- (let (
- (sc1 (open-store *test-path-primary*))
- (sc2 (open-store *test-path-secondary*)))
- (let* ((f1 (make-instance 'pfoo :sc sc1))
- (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1))
- (b1 (make-instance 'pbar :slot2 "another string" :sc sc1))
- )
- (let ((fm1
- (ele::migraten-pobj
- sc2 f1
- #'(lambda (dst src)
- (if (slot-boundp src 'slot1)
- (setf (slot1 dst) (slot1 src))))))
+ (prog2
+ (setq *auto-commit* t)
+ (let (
+ (sc1 (open-store *test-spec-primary*))
+ (sc2 (open-store *test-spec-secondary*)))
+ (let* ((f1 (make-instance 'pfoo :sc sc1))
+ (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1))
+ (b1 (make-instance 'pbar :slot2 "another string" :sc sc1))
+ )
+ (let ((fm1
+ (migrate ;; (ele::migraten-pobj
+ sc2 f1
+ #'(lambda (dst src)
+ (if (slot-boundp src 'slot1)
+ (setf (slot1 dst) (slot1 src))))))
(fm2
- (ele::migraten-pobj
+ (migrate ;; (ele::migraten-pobj
sc2 f2
#'(lambda (dst src)
(if (slot-boundp src 'slot1)
(setf (slot1 dst) (slot1 src))))))
- (bm1 (ele::migraten-pobj
+ (bm1 (migrate ;; (ele::migraten-pobj
sc2 b1
#'(lambda (dst src)
(if (slot-boundp src 'slot2)
--- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2006/02/04 22:25:10 1.9
+++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2006/02/19 04:53:02 1.10
@@ -375,7 +375,7 @@
;; test it both ways...since we won't know how they will want it
;; implemented, we will have to somehow make a choice here, maybe
;; based on the stype of *store-controller*
- (h (build-btree *store-controller*)))
+ (h (make-btree *store-controller*)))
(are-not-null
(in-out-eq f1)
(in-out-eq f2)
--- /project/elephant/cvsroot/elephant/tests/testsleepycat.lisp 2006/02/04 22:25:10 1.6
+++ /project/elephant/cvsroot/elephant/tests/testsleepycat.lisp 2006/02/19 04:53:02 1.7
@@ -13,12 +13,13 @@
(in-package "ELE-TESTS")
+
(defvar env)
(defvar db)
-(defun prepare-sleepycat()
+(defun prepare-sleepycat ()
(setq env (sleepycat::db-env-create))
- (sleepycat::db-env-open env *sleepycatdb-path* :create t :init-txn t :init-lock t
+ (sleepycat::db-env-open env (cdr *sleepycatdb-spec*) :create t :init-txn t :init-lock t
:init-mpool t :init-log t :thread t
:recover-fatal t)
@@ -27,11 +28,12 @@
:auto-commit t :create t :thread t))
(deftest prepares-sleepycat
- (if (not (find-package 'ele-bdb))
+ (progn
+ (if (not (find-package :sleepycat))
(progn
- (format t "package ele-bdb not found, so not runnning test prepares-sleepycat~%")
- t)
- (finishes (prepare-sleepycat)))
+ (format t "sleepycat db not valid, so not runnning test prepares-sleepycat~%")
+ t)
+ (finishes (prepare-sleepycat))))
t)
#|
@@ -77,7 +79,7 @@
(deftest test-seq1
(if (not (find-package 'ele-bdb))
(progn
- (format t "package ele-bdb not found, so not runnning test prepares-sleepycat~%")
+ (format t "database db not valid, so not runnning test test-seq1~%")
t)
(finishes (test-sequence1)))
t)
@@ -98,11 +100,11 @@
finally (sleepycat::db-sequence-remove seq :auto-commit t))))
(deftest test-seq2
- (if (not (find-package 'ele-bdb))
+ (if (not db)
(progn
- (format t "package ele-bdb not found, so not runnning test prepares-sleepycat~%")
- t)
- (finishes (test-sequence2)))
+ (format t "sleepycat db not valid, so not runnning test test-seq2~%")
+ t)
+ (finishes (test-sequence2)))
t)
(defun cleanup-sleepycat ()
@@ -113,9 +115,9 @@
(sleepycat::db-env-remove env "test"))
(deftest cleansup-sleepycat
- (if (not (find-package 'ele-bdb))
+ (if (not db)
(progn
- (format t "package ele-bdb not found, so not runnning test prepares-sleepycat~%")
+ (format t "sleepycat db not valid, so not runnning test cleanup-sleepycat~%")
t)
(finishes (cleanup-sleepycat)))
t)
1
0
Update of /project/elephant/cvsroot/elephant/src/memutil
In directory common-lisp:/tmp/cvs-serv7130/src/memutil
Added Files:
libmemutil.c memutil.lisp
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/src/memutil/libmemutil.c 2006/02/19 04:53:02 NONE
+++ /project/elephant/cvsroot/elephant/src/memutil/libmemutil.c 2006/02/19 04:53:02 1.1
/*
;;;
;;; libsleepycat.c -- C wrappers for Sleepycat for FFI
;;;
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee(a)common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net>
;;;
;;; This program is released under the following license
;;; ("GPL"). For differenct licensing terms, contact the
;;; copyright holders.
;;;
;;; This program is free software; you can redistribute it
;;; and/or modify it under the terms of the GNU General
;;; Public License as published by the Free Software
;;; Foundation; either version 2 of the License, or (at
;;; your option) any later version.
;;;
;;; This program is distributed in the hope that it will be
;;; useful, but WITHOUT ANY WARRANTY; without even the
;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
;;; PARTICULAR PURPOSE. See the GNU General Public License
;;; for more details.
;;;
;;; The GNU General Public License can be found in the file
;;; LICENSE which should have been distributed with this
;;; code. It can also be found at
;;;
;;; http://www.opensource.org/licenses/gpl-license.php
;;;
;;; You should have received a copy of the GNU General
;;; Public License along with this program; if not, write
;;; to the Free Software Foundation, Inc., 59 Temple Place,
;;; Suite 330, Boston, MA 02111-1307 USA
;;;
;;; Portions of this program (namely the C unicode string
;;; sorter) are derived from IBM's ICU:
;;;
;;; http://oss.software.ibm.com/icu/
;;;
;;; Copyright (c) 1995-2003 International Business Machines
;;; Corporation and others All rights reserved.
;;;
;;; ICU's copyright, license and warranty can be found at
;;;
;;; http://oss.software.ibm.com/cvs/icu/~checkout~/icu/license.html
;;;
;;; or in the file LICENSE.
;;;
*/
#include <string.h>
#include <wchar.h>
/* Pointer arithmetic utility functions */
/* should these be in network-byte order? probably not..... */
int read_int(char *buf, int offset) {
int i;
memcpy(&i, buf+offset, sizeof(int));
return i;
}
unsigned int read_uint(char *buf, int offset) {
unsigned int ui;
memcpy(&ui, buf+offset, sizeof(unsigned int));
return ui;
}
float read_float(char *buf, int offset) {
float f;
memcpy(&f, buf+offset, sizeof(float));
return f;
}
double read_double(char *buf, int offset) {
double d;
memcpy(&d, buf+offset, sizeof(double));
return d;
}
void write_int(char *buf, int num, int offset) {
memcpy(buf+offset, &num, sizeof(int));
}
void write_uint(char *buf, unsigned int num, int offset) {
memcpy(buf+offset, &num, sizeof(unsigned int));
}
void write_float(char *buf, float num, int offset) {
memcpy(buf+offset, &num, sizeof(float));
}
void write_double(char *buf, double num, int offset) {
memcpy(buf+offset, &num, sizeof(double));
}
char *offset_charp(char *p, int offset) {
return p + offset;
}
void copy_buf(char *dest, int dest_offset, char *src, int src_offset,
int length) {
memcpy(dest + dest_offset, src + src_offset, length);
}
--- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 04:53:02 NONE
+++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 04:53:02 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; memutil.lisp -- FFI interface to UFFI/memory as base for serializer.lisp
;;;
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee(a)common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)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.
;;;
(defpackage elephant-memutil
(:documentation "A low-level UFFI-based memory access and
serialization toolkit. Provides basic cross-platform
binary serialization support for backends.")
(:use common-lisp uffi)
#+cmu
(:use alien)
#+sbcl
(:use sb-alien)
#+cmu
(:import-from :sys
#:sap+)
#+sbcl
(:import-from :sb-sys
#:sap+)
#+openmcl
(:import-from :ccl
#:byte-length)
(:export
#:buffer-stream #:make-buffer-stream #:with-buffer-streams
#:resize-buffer-stream #:resize-buffer-stream-no-copy
#:reset-buffer-stream #:buffer-stream-buffer
#:buffer-stream-length #:buffer-stream-size
#:buffer-write-byte #:buffer-write-int
#:buffer-write-uint #:buffer-write-float #:buffer-write-double
#:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum
#:buffer-read-int #:buffer-read-uint #:buffer-read-float
#:buffer-read-double
#:buffer-read-ucs1-string
#+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string
#+(and sbcl sb-unicode) #:buffer-read-ucs4-string
#:byte-length
#:pointer-int #:pointer-void #:array-or-pointer-char
+NULL-CHAR+ +NULL-VOID+
))
(in-package "ELEPHANT-MEMUTIL")
#+cmu
(eval-when (:compile-toplevel)
(proclaim '(optimize (ext:inhibit-warnings 3))))
(eval-when (:compile-toplevel :load-toplevel)
(defparameter *c-library-extension*
#+(or darwin macosx) "dylib"
#-(or darwin macosx) "so" )
(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant/"))
(eval-when (:compile-toplevel :load-toplevel)
(unless
(uffi:load-foreign-library
(if (find-package 'asdf)
(merge-pathnames
(make-pathname :name "libmemutil" :type *c-library-extension*)
(asdf:component-pathname (asdf:find-system 'elephant)))
(format nil "~A/~A.~A" *elephant-lib-path* "libmemutil" *c-library-extension*))
:module "libmemutil")
(error "Couldn't load libmemutil.~A!" *c-library-extension*))
;; fini on user editable part
(def-type pointer-int (* :int))
(def-type pointer-void :pointer-void)
(def-foreign-type array-or-pointer-char
#+allegro (:array :char)
#+(or cmu sbcl scl openmcl) (* :char))
(def-type array-or-pointer-char array-or-pointer-char)
)
(declaim (inline read-int read-uint read-float read-double
write-int write-uint write-float write-double
offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs
;;resize-buffer-stream
;;buffer-stream-buffer buffer-stream-size buffer-stream-position
;;buffer-stream-length
reset-buffer-stream
buffer-write-byte buffer-write-int buffer-write-uint
buffer-write-float buffer-write-double buffer-write-string
buffer-read-byte buffer-read-fixnum buffer-read-int
buffer-read-uint buffer-read-float buffer-read-double
buffer-read-ucs1-string
#+(or lispworks (and allegro ics)) buffer-read-ucs2-string
#+(and sbcl sb-unicode) buffer-read-ucs4-string))
;; Constants and Flags
;; eventually write a macro which generates a custom flag function.
(defvar +NULL-VOID+ (make-null-pointer :void)
"A null pointer to a void type.")
(defvar +NULL-CHAR+ (make-null-pointer :char)
"A null pointer to a char type.")
;; Thread local storage (special variables)
(defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t)
"Vector of buffer-streams, which you can grab / return.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; buffer-streams
;;;
;;; a stream-like interface for our buffers; methods are
;;; below. ultimately we might want a gray / simple -stream
;;; for real, for now who cares?
(defstruct buffer-stream
"A stream-like interface to foreign (alien) char buffers."
(buffer (allocate-foreign-object :char 10) :type array-or-pointer-char)
(size 0 :type fixnum)
(position 0 :type fixnum)
(length 10 :type fixnum))
(defun grab-buffer-stream ()
"Grab a buffer-stream from the *buffer-streams* resource pool."
(declare (optimize (speed 3)))
(if (= (length *buffer-streams*) 0)
(make-buffer-stream)
(vector-pop *buffer-streams*)))
(defun return-buffer-stream (bs)
"Return a buffer-stream to the *buffer-streams* resource pool."
(declare (optimize (speed 3)))
(reset-buffer-stream bs)
(vector-push-extend bs *buffer-streams*))
(defmacro with-buffer-streams (names &body body)
"Grab a buffer-stream, executes forms, and returns the
stream to the pool on exit."
`(let ,(loop for name in names collect (list name '(grab-buffer-stream)))
(unwind-protect
(progn ,@body)
(progn
,@(loop for name in names
collect (list 'return-buffer-stream name))))))
;; Buffer management / pointer arithmetic
;; Notes: on Allegro: with-cast-pointer + deref-array is
;; faster than FFI + C pointer arithmetic. however pointer
;; arithmetic is usually consing. OpenMCL supports
;; non-consing pointer arithmentic though. Check these
;; CMUCL / SBCL things don't cons unless necessary.
;; TODO: #+openmcl versions which do macptr arith.
#+(or cmu sbcl)
(defun read-int (buf offset)
"Read a 32-bit signed integer from a foreign char buffer."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) buf)
(type fixnum offset))
(the (signed-byte 32)
(deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
(* integer)))))
#+(or cmu sbcl)
(defun read-uint (buf offset)
"Read a 32-bit unsigned integer from a foreign char buffer."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) buf)
(type fixnum offset))
(the (unsigned-byte 32)
(deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
(* (unsigned 32))))))
#+(or cmu sbcl)
(defun read-float (buf offset)
"Read a single-float from a foreign char buffer."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) buf)
(type fixnum offset))
(the single-float
(deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
(* single-float)))))
#+(or cmu sbcl)
(defun read-double (buf offset)
"Read a double-float from a foreign char buffer."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) buf)
(type fixnum offset))
(the double-float
(deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
(* double-float)))))
#+(or cmu sbcl)
(defun write-int (buf num offset)
"Write a 32-bit signed integer to a foreign char buffer."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) buf)
(type (signed-byte 32) num)
(type fixnum offset))
(setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
(* integer))) num))
#+(or cmu sbcl)
(defun write-uint (buf num offset)
"Write a 32-bit unsigned integer to a foreign char buffer."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) buf)
(type (unsigned-byte 32) num)
(type fixnum offset))
(setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
(* (unsigned 32)))) num))
#+(or cmu sbcl)
(defun write-float (buf num offset)
"Write a single-float to a foreign char buffer."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) buf)
(type single-float num)
(type fixnum offset))
(setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
(* single-float))) num))
#+(or cmu sbcl)
(defun write-double (buf num offset)
"Write a double-float to a foreign char buffer."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) buf)
(type double-float num)
(type fixnum offset))
(setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char))
(* double-float))) num))
#+(or cmu sbcl)
(defun offset-char-pointer (p offset)
"Pointer arithmetic."
(declare (optimize (speed 3) (safety 0))
(type (alien (* char)) p)
(type fixnum offset))
(sap-alien (sap+ (alien-sap p) offset) (* char)))
#-(or cmu sbcl)
(def-function ("read_int" read-int)
((buf array-or-pointer-char)
(offset :int))
:returning :int)
#-(or cmu sbcl)
(def-function ("read_uint" read-uint)
((buf array-or-pointer-char)
(offset :int))
:returning :unsigned-int)
#-(or cmu sbcl)
(def-function ("read_float" read-float)
((buf array-or-pointer-char)
(offset :int))
:returning :float)
#-(or cmu sbcl)
(def-function ("read_double" read-double)
((buf array-or-pointer-char)
(offset :int))
:returning :double)
#-(or cmu sbcl)
(def-function ("write_int" write-int)
((buf array-or-pointer-char)
(num :int)
(offset :int))
:returning :void)
#-(or cmu sbcl)
(def-function ("write_uint" write-uint)
((buf array-or-pointer-char)
[454 lines skipped]
1
0
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(a)common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)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(a)common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)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(a)common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)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]
1
0
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp:/tmp/cvs-serv7130/src
Added Files:
README
Removed Files:
IAN-TODO bdb-enable.lisp cmu-mop-patches.lisp collections.lisp
controller.lisp elephant.lisp index-tutorial.lisp
indexing.lisp libmemutil.c libsleepycat.c libsleepycat.def
libutil.c metaclasses.lisp openmcl-mop-patches.lisp
serializer.lisp sleepycat.lisp sql-collections.lisp
sql-controller.lisp sql-tutorial.lisp utils.lisp
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/src/README 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/README 2006/02/19 04:53:00 1.1
The organization of the new Elephant is as follows:
Top directory contains:
- A binary object serialization framework (serializer.lisp)
- Code necessary to support different platform MOPs
(to move to closer-to-MOP in 0.6.1) (cmu/openmcl-mop-patches.lisp)
- Top level transaction model (transaction.lisp)
- An environment model for 'current store' and multi-repository operation (controller.lisp)
- The metaclass protocol for supporting persistent objects (metaclass.lisp, classes.lisp)
- Interface specs for persistent btrees & cursors (collections.lisp)
- Indexing support for the metaclass (indexing.lisp, index-utils.lisp)
Backends provide support for:
- A store controller w/ a persistent root index (*-controller.lisp)
- Includes support for slot operations in metaclass protocol
- Collections defined via the specific controller (*-collections.lisp)
- Transactions specific to the backend (*-transactions.lisp)
1
0
Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory common-lisp:/tmp/cvs-serv7130/src/db-bdb
Added Files:
bdb-collections.lisp bdb-controller.lisp bdb-enable.lisp
bdb-transactions.lisp libsleepycat.c libutil.c package.lisp
sleepycat-old.lisp sleepycat.lisp
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 04:53:00 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; collections.lisp -- view Berkeley DBs as Lisp collections
;;;
;;; Initial version 8/26/2004 by Ben Lee
;;; <blee(a)common-lisp.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)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 "SLEEPYCAT")
(defclass bdb-btree (btree) ()
(:documentation "A BerkleyDB implementation of a BTree"))
;; It would be nice if this were a macro or a function
;; that would allow all of its arguments to be passed through;
;; otherwise an initialization slot is inaccessible.
;; I'll worry about that later.
;; Do these things need to take &rest arguments?
(defmethod build-btree ((sc bdb-store-controller))
(make-instance 'bdb-btree :sc sc))
(defmethod get-value (key (bt bdb-btree))
(declare (optimize (speed 3) (space 0) (safety 0)))
(let ((sc (get-con bt)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered (controller-btrees sc)
key-buf value-buf)))
(if buf (values (deserialize buf :sc sc) T)
(values nil nil))))))
(defmethod existsp (key (bt bdb-btree))
(declare (optimize (speed 3) (safety 0) (space 0)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
(controller-btrees (get-con bt))
key-buf value-buf)))
(if buf t
nil))))
(defmethod (setf get-value) (value key (bt bdb-btree))
(declare (optimize (speed 3) (safety 0) (space 0)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(serialize value value-buf)
(db-put-buffered (controller-btrees (get-con bt))
key-buf value-buf
:auto-commit *auto-commit*)
value))
(defmethod remove-kv (key (bt bdb-btree))
(declare (optimize (speed 3) (space 0) (safety 0)))
(with-buffer-streams (key-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(db-delete-buffered (controller-btrees (get-con bt))
key-buf :auto-commit *auto-commit*)))
;; Secondary indices
(defclass bdb-indexed-btree (indexed-btree bdb-btree)
(
(indices :accessor indices :initform (make-hash-table))
(indices-cache :accessor indices-cache :initform (make-hash-table)
:transient t)
)
(:metaclass persistent-metaclass)
(:documentation "A BDB-based BTree supports secondary indices."))
(defmethod shared-initialize :after ((instance bdb-indexed-btree) slot-names
&rest rest)
(declare (ignore slot-names rest))
(setf (indices-cache instance) (indices instance)))
(defmethod build-indexed-btree ((sc bdb-store-controller))
(let ((bt (make-instance 'bdb-indexed-btree :sc sc)))
;; (setf (:dbcn-spc-pst bt) (controller-path sc))
;; I must be confused with multipler inheritance, because the above
;;; initforms in bdb-indexed-btree should be working, but aren't.
;; (setf (indices bt) (make-hash-table))
;; (setf (indices-cache bt) (make-hash-table))
bt))
(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form)
(let ((bt (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)))
;; (setf (:dbcn-spc-pst bt) (controller-path sc))
;; I must be confused with multipler inheritance, because the above
;;; initforms in bdb-indexed-btree should be working, but aren't.
bt))
(defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate)
(let ((sc (get-con bt)))
;; Setting the value of *store-controller* is unfortunately
;; absolutely required at present, I think because the copying
;; of objects is calling "make-instance" without an argument.
;; I am sure I can find a way to make this cleaner, somehow.
(if (and (not (null index-name))
(symbolp index-name) (or (symbolp key-form) (listp key-form)))
;; Can it be that this fails?
(let (
(ht (indices bt))
(index (build-btree-index sc :primary bt
:key-form key-form)))
(setf (gethash index-name (indices-cache bt)) index)
(setf (gethash index-name ht) index)
(setf (indices bt) ht)
(when populate
(let ((key-fn (key-fn index)))
(with-buffer-streams (primary-buf secondary-buf)
(with-transaction (:store-controller sc)
(map-btree
#'(lambda (k v)
(multiple-value-bind (index? secondary-key)
(funcall key-fn index k v)
(when index?
(buffer-write-int (oid bt) primary-buf)
(serialize k primary-buf)
(buffer-write-int (oid index) secondary-buf)
(serialize secondary-key secondary-buf)
;; should silently do nothing if
;; the key/value already exists
(db-put-buffered
(controller-indices sc)
secondary-buf primary-buf)
(reset-buffer-stream primary-buf)
(reset-buffer-stream secondary-buf))))
bt)))))
index)
(error "Invalid index initargs!")))
)
(defmethod map-indices (fn (bt bdb-indexed-btree))
(maphash fn (indices-cache bt)))
(defmethod get-index ((bt bdb-indexed-btree) index-name)
(gethash index-name (indices-cache bt)))
(defmethod remove-index ((bt bdb-indexed-btree) index-name)
(remhash index-name (indices-cache bt))
(let ((indices (indices bt)))
(remhash index-name indices)
(setf (indices bt) indices)))
(defmethod (setf get-value) (value key (bt bdb-indexed-btree))
"Set a key / value pair, and update secondary indices."
(let ((sc (get-con bt)))
(let ((indices (indices-cache bt)))
(with-buffer-streams (key-buf value-buf secondary-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(serialize value value-buf)
(with-transaction (:store-controller sc)
(db-put-buffered (controller-btrees sc)
key-buf value-buf)
(loop for index being the hash-value of indices
do
(multiple-value-bind (index? secondary-key)
(funcall (key-fn index) index key value)
(when index?
;; Manually write value into secondary index
(buffer-write-int (oid index) secondary-buf)
(serialize secondary-key secondary-buf)
;; should silently do nothing if the key/value already
;; exists
(db-put-buffered (controller-indices sc)
secondary-buf key-buf)
(reset-buffer-stream secondary-buf))))
value))))
)
(defmethod remove-kv (key (bt bdb-indexed-btree))
"Remove a key / value pair, and update secondary indices."
(declare (optimize (speed 3)))
(let ((sc (get-con bt)))
(with-buffer-streams (key-buf secondary-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(with-transaction (:store-controller sc)
(let ((value (get-value key bt)))
(when value
(let ((indices (indices-cache bt)))
(loop
for index being the hash-value of indices
do
(multiple-value-bind (index? secondary-key)
(funcall (key-fn index) index key value)
(when index?
(buffer-write-int (oid index) secondary-buf)
(serialize secondary-key secondary-buf)
;; need to remove kv pairs with a cursor! --
;; this is a C performance hack
(db-delete-kv-buffered
(controller-indices (get-con bt))
secondary-buf key-buf)
(reset-buffer-stream secondary-buf))))
(db-delete-buffered (controller-btrees (get-con bt))
key-buf))))))))
;; This also needs to build the correct kind of index, and
;; be the correct kind of btree...
(defclass bdb-btree-index (btree-index bdb-btree)
()
(:metaclass persistent-metaclass)
(:documentation "A BDB-based BTree supports secondary indices."))
;; I now think this code should be split out into a separate
;; class...
(defmethod get-value (key (bt bdb-btree-index))
"Get the value in the primary DB from a secondary key."
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
(controller-indices-assoc (get-con bt))
key-buf value-buf)))
(if buf (values (deserialize buf :sc (get-con bt)) T)
(values nil nil)))))
(defmethod get-primary-key (key (bt btree-index))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (oid bt) key-buf)
(serialize key key-buf)
(let ((buf (db-get-key-buffered
(controller-indices (get-con bt))
key-buf value-buf)))
(if buf
(let ((oid (buffer-read-fixnum buf)))
(values (deserialize buf :sc (get-con bt)) oid))
(values nil nil)))))
;; Cursor operations
;; Node that I have not created a bdb-cursor, but have
;; created a sql-currsor. This is almost certainly wrong
;; and furthermore will badly screw things up when we get to
;; secondary cursors.
(defclass bdb-cursor (cursor)
((handle :accessor cursor-handle :initarg :handle))
(:documentation "A cursor for traversing (primary) BDB-BTrees."))
(defmethod make-cursor ((bt bdb-btree))
"Make a cursor from a btree."
(declare (optimize (speed 3)))
(make-instance 'bdb-cursor
:btree bt
:handle (db-cursor (controller-btrees (get-con bt)))
:oid (oid bt)))
(defmethod cursor-close ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(db-cursor-close (cursor-handle cursor))
(setf (cursor-initialized-p cursor) nil))
(defmethod cursor-duplicate ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(make-instance (type-of cursor)
:initialized-p (cursor-initialized-p cursor)
:oid (cursor-oid cursor)
:handle (db-cursor-duplicate
(cursor-handle cursor)
:position (cursor-initialized-p cursor))))
(defmethod cursor-current ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf
:current t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
(values t (deserialize key
:sc (get-con (cursor-btree cursor)))
(deserialize val
:sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))))
(defmethod cursor-first ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
(multiple-value-bind (key val)
(db-cursor-set-buffered (cursor-handle cursor)
key-buf value-buf :set-range t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
(values t (deserialize key
:sc (get-con (cursor-btree cursor)))
(deserialize val
:sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil)))))
;;A bit of a hack.....
(defmethod cursor-last ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (+ (cursor-oid cursor) 1) key-buf)
(if (db-cursor-set-buffered (cursor-handle cursor)
key-buf value-buf :set-range t)
(progn (reset-buffer-stream key-buf)
(reset-buffer-stream value-buf)
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :prev t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
(values t (deserialize key
:sc (get-con (cursor-btree cursor)))
(deserialize val
:sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor) key-buf
value-buf :last t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(progn
(setf (cursor-initialized-p cursor) t)
(values t (deserialize key
:sc (get-con (cursor-btree cursor)))
(deserialize val
:sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil))))))
(defmethod cursor-next ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :next t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(values t (deserialize key :sc (get-con (cursor-btree cursor)))
(deserialize val :sc (get-con (cursor-btree cursor))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-first cursor)))
(defmethod cursor-prev ((cursor bdb-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(with-buffer-streams (key-buf value-buf)
(multiple-value-bind (key val)
(db-cursor-move-buffered (cursor-handle cursor)
key-buf value-buf :prev t)
(if (and key (= (buffer-read-int key) (cursor-oid cursor)))
(values t (deserialize key :sc (get-con (cursor-btree cursor)))
(deserialize val :sc (get-con (cursor-btree cursor))))
(setf (cursor-initialized-p cursor) nil))))
(cursor-last cursor)))
(defmethod cursor-set ((cursor bdb-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
(serialize key key-buf)
(multiple-value-bind (k val)
(db-cursor-set-buffered (cursor-handle cursor)
key-buf value-buf :set t)
(if k
(progn (setf (cursor-initialized-p cursor) t)
(values t key (deserialize val :sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil)))))
(defmethod cursor-set-range ((cursor bdb-cursor) key)
(declare (optimize (speed 3)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-int (cursor-oid cursor) key-buf)
(serialize key key-buf)
(multiple-value-bind (k val)
(db-cursor-set-buffered (cursor-handle cursor)
key-buf value-buf :set-range t)
(if (and k (= (buffer-read-int k) (cursor-oid cursor)))
(progn (setf (cursor-initialized-p cursor) t)
(values t (deserialize k :sc (get-con (cursor-btree cursor)))
(deserialize val :sc (get-con (cursor-btree cursor)))))
(setf (cursor-initialized-p cursor) nil)))))
(defmethod cursor-get-both ((cursor bdb-cursor) key value)
(declare (optimize (speed 3)))
[360 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 04:53:00 1.1
[557 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-enable.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-enable.lisp 2006/02/19 04:53:00 1.1
[646 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/19 04:53:00 1.1
[741 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/libsleepycat.c 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libsleepycat.c 2006/02/19 04:53:00 1.1
[1734 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/libutil.c 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/libutil.c 2006/02/19 04:53:00 1.1
[1845 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/02/19 04:53:00 1.1
[1888 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat-old.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat-old.lisp 2006/02/19 04:53:00 1.1
[2953 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 04:53:00 1.1
[4821 lines skipped]
1
0
Update of /project/elephant/cvsroot/elephant/src/db-clsql
In directory common-lisp:/tmp/cvs-serv7130/src/db-clsql
Added Files:
sql-collections.lisp sql-controller.lisp sql-transaction.lisp
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 04:53:00 1.1
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
;;; sql-controller.lisp -- Interface to a CLSQL based object store.
;;;
;;; Initial version 10/12/2005 by Robert L. Read
;;; <read(a)robertlread.net>
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;; Copyright (c) 2005 by Robert L. Read
;;; <rread(a)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")
(defclass sql-btree-index (btree-index sql-btree)
()
(:metaclass persistent-metaclass)
(:documentation "A SQL-based BTree supports secondary indices."))
(defmethod get-value (key (bt sql-btree-index))
"Get the value in the primary DB from a secondary key."
(declare (optimize (speed 3)))
;; Below, the take the oid and add it to the key, then look
;; thing up--- where?
;; Somehow I suspect that what I am getting back here
;; is actually the main key...
(let* ((sc (get-con bt))
(con (controller-db sc)))
(let ((pk (sql-get-from-clcn (oid bt) key sc con)))
(if pk
(sql-get-from-clcn (oid (primary bt)) pk sc con))
)))
(defmethod get-primary-key (key (bt sql-btree-index))
(declare (optimize (speed 3)))
(let* ((sc (get-con bt))
(con (controller-db sc))
)
(sql-get-from-clcn (oid bt) key sc con)))
;; My basic strategy is to keep track of a current key
;; and to store all keys in memory so that we can sort them
;; to implement the cursor semantics. Clearly, passing
;; in a different ordering is a nice feature to have here.
(defclass sql-cursor (cursor)
((keys :accessor :sql-crsr-ks :initarg :sql-cursor-keys :initform '())
(curkey :accessor :sql-crsr-ck :initarg :sql-cursor-curkey :initform -1 :type integer))
(:documentation "A SQL cursor for traversing (primary) BTrees."))
(defmethod make-cursor ((bt sql-btree))
"Make a cursor from a btree."
(declare (optimize (speed 3)))
(make-instance 'sql-cursor
:btree bt
:oid (oid bt)))
(defmethod cursor-close ((cursor sql-cursor))
(setf (:sql-crsr-ck cursor) nil)
(setf (cursor-initialized-p cursor) nil))
;; Maybe this will still work?
;; I'm not sure what cursor-duplicate is meant to do, and if
;; the other state needs to be copied or now. Probably soo...
(defmethod cursor-duplicate ((cursor sql-cursor))
(declare (optimize (speed 3)))
(make-instance (type-of cursor)
:initialized-p (cursor-initialized-p cursor)
:oid (cursor-oid cursor)
;; Do we need to so some kind of copy on this collection?
:keys (:sql-crsr-ks cursor)
:curkey (:sql-crsr-ck cursor)
:handle (db-cursor-duplicate
(cursor-handle cursor)
:position (cursor-initialized-p cursor))))
(defmethod cursor-current ((cursor sql-cursor))
(declare (optimize (speed 3)))
(when (cursor-initialized-p cursor)
(has-key-value cursor)))
;; Only for use within an operation...
(defun my-generic-less-than (a b)
(cond
((and (typep a 'persistent) (typep b 'persistent))
(< (oid a) (oid b))
)
((and (numberp a ) (numberp b))
(< a b))
((and (stringp a) (stringp b))
(string< a b))
(t
(string< (format nil "~A" a) (format nil "~A" b)))
))
(defmethod cursor-un-init ((cursor sql-cursor) &key (returnpk nil))
(setf (cursor-initialized-p cursor) nil)
(if returnpk
(values nil nil nil nil)
(values nil nil nil)))
(clsql::locally-enable-sql-reader-syntax)
(defmethod cursor-init ((cursor sql-cursor))
(let* ((sc (get-con (cursor-btree cursor)))
(con (controller-db sc))
(tuples
(clsql:select [key]
:from [keyvalue]
:where [= [clctn_id] (oid (cursor-btree cursor))]
:database con
))
(len (length tuples)))
;; now we somehow have to load the keys into the array...
;; actually, this should be an adjustable vector...
(setf (:sql-crsr-ks cursor) (make-array (length tuples)))
(do ((i 0 (1+ i))
(tup tuples (cdr tup)))
((= i len) nil)
(setf (aref (:sql-crsr-ks cursor) i)
(deserialize-from-base64-string (caar tup) :sc sc)))
(sort (:sql-crsr-ks cursor) #'my-generic-less-than)
(setf (:sql-crsr-ck cursor) 0)
(setf (cursor-initialized-p cursor) t)
))
(clsql::restore-sql-reader-syntax-state)
;; we're assuming here that nil is not a legitimate key.
(defmethod get-current-key ((cursor sql-cursor))
(let ((x (:sql-crsr-ck cursor)))
(if (and (>= x 0) (< x (length (:sql-crsr-ks cursor))))
(svref (:sql-crsr-ks cursor) x)
'()
))
)
(defmethod get-current-value ((cursor sql-cursor))
(let ((key (get-current-key cursor)))
(if key
(get-value key (cursor-btree cursor))
'())))
(defmethod has-key-value ((cursor sql-cursor))
(let ((key (get-current-key cursor)))
(if key
(values t key (get-value key (cursor-btree cursor)))
(cursor-un-init cursor))))
(defmethod cursor-first ((cursor sql-cursor))
(declare (optimize (speed 3)))
;; Read all of the keys...
;; We need to get the contoller db from the btree somehow...
(cursor-init cursor)
(has-key-value cursor)
)
;;A bit of a hack.....
;; If you run off the end, this can set cursor-initalized-p to nil.
(defmethod cursor-last ((cursor sql-cursor) )
(unless (cursor-initialized-p cursor)
(cursor-init cursor))
(setf (:sql-crsr-ck cursor)
(- (length (:sql-crsr-ks cursor)) 1))
(setf (cursor-initialized-p cursor) t)
(has-key-value cursor))
(defmethod cursor-next ((cursor sql-cursor))
(if (cursor-initialized-p cursor)
(progn
(incf (:sql-crsr-ck cursor))
(has-key-value cursor))
(cursor-first cursor)))
(defmethod cursor-prev ((cursor sql-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(progn
(decf (:sql-crsr-ck cursor))
(has-key-value cursor))
(cursor-last cursor)))
(defmethod cursor-set ((cursor sql-cursor) key)
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(let ((p (position key (:sql-crsr-ks cursor) :test #'equal)))
(if p
(progn
(setf (:sql-crsr-ck cursor) p)
(setf (cursor-initialized-p cursor) t)
(has-key-value cursor)
)
(setf (cursor-initialized-p cursor) nil)))
(progn
(cursor-init cursor)
(let ((p (position key (:sql-crsr-ks cursor) :test #'equal)))
(if p
(progn
(setf (:sql-crsr-ck cursor) p)
(has-key-value cursor)
)
(setf (cursor-initialized-p cursor) nil))))
))
(defmethod cursor-set-range ((cursor sql-cursor) key)
(declare (optimize (speed 3)))
;; I'm a little fuzzy on when I should leave a cursor in
;; the initialized state...
(unless (cursor-initialized-p cursor)
(cursor-init cursor))
(let ((len (length (:sql-crsr-ks cursor)))
(vs '()))
(do ((i 0 (1+ i)))
((or (= i len)
vs)
vs)
(progn
(multiple-value-bind (h k v)
(cursor-next cursor)
(when (my-generic-less-than key k)
(setf vs t))
)
))
(if vs
(cursor-current cursor)
(cursor-un-init cursor))))
(defmethod cursor-get-both ((cursor sql-cursor) key value)
(declare (optimize (speed 3)))
(let* ((bt (cursor-btree cursor))
(v (get-value key bt)))
(if (equal v value)
;; We need to leave this cursor properly posistioned....
;; For a secondary cursor it's harder, but for this, it's simple
(cursor-set cursor key)
(cursor-un-init cursor))))
;; This needs to be rewritten!
(defmethod cursor-get-both-range ((cursor sql-cursor) key value)
(declare (optimize (speed 3)))
(let* ((bt (cursor-btree cursor))
(v (get-value key bt)))
;; Since we don't allow duplicates in primary cursors, I
;; guess this is all that needs to be done!
;; If there were a test to cover this, the semantics would be clearer...
(if (equal v value)
(cursor-set cursor key)
(cursor-un-init cursor))))
(defmethod cursor-delete ((cursor sql-cursor))
(declare (optimize (speed 3)))
(if (cursor-initialized-p cursor)
(multiple-value-bind
(has k v)
(cursor-current cursor)
(declare (ignore has v))
;; Now I need to suck the value out of the cursor, somehow....
(remove-kv k (cursor-btree cursor)))
(error "Can't delete with uninitialized cursor!")))
;; This needs to be changed!
(defmethod cursor-put ((cursor sql-cursor) value &key (key nil key-specified-p))
"Put by cursor. Not particularly useful since primaries
don't support duplicates. Currently doesn't properly move
the cursor."
(declare (optimize (speed 3)))
(error "Puts on sql-cursors are not yet implemented, because I can't get them to work on BDB cursors!"))
;; Secondary Cursors
(defclass sql-secondary-cursor (sql-cursor)
(
(dup-number :accessor :dp-nmbr :initarg :dup-number :initform 0 :type integer)
)
(:documentation "Cursor for traversing bdb secondary indices."))
(defmethod make-cursor ((bt sql-btree-index))
"Make a secondary-cursor from a secondary index."
(declare (optimize (speed 3)))
(make-instance 'sql-secondary-cursor
:btree bt
:oid (oid bt)))
(defmethod has-key-value-scnd ((cursor sql-secondary-cursor) &key (returnpk nil))
(let ((ck (:sql-crsr-ck cursor)))
(if (and (>= ck 0) (< ck (length (:sql-crsr-ks cursor))))
(let* ((cur-pk (aref (:sql-crsr-ks cursor)
(:sql-crsr-ck cursor)))
(sc (get-con (cursor-btree cursor)))
(con (controller-db sc))
(indexed-pk (sql-get-from-clcn-nth (cursor-oid cursor) cur-pk
sc con
(:dp-nmbr cursor))))
(if indexed-pk
(let ((v (get-value indexed-pk (primary (cursor-btree cursor)))))
(if v
(if returnpk
(values t cur-pk v indexed-pk)
(values t cur-pk v))
(cursor-un-init cursor :returnpk returnpk)))
(cursor-un-init cursor :returnpk returnpk)))
(progn
(cursor-un-init cursor :returnpk returnpk)))))
(defmethod cursor-current ((cursor sql-secondary-cursor) )
(cursor-current-x cursor))
(defmethod cursor-current-x ((cursor sql-secondary-cursor) &key (returnpk nil))
(has-key-value-scnd cursor :returnpk returnpk)
)
(defmethod cursor-pcurrent ((cursor sql-secondary-cursor))
(cursor-current-x cursor :returnpk t))
(defmethod cursor-pfirst ((cursor sql-secondary-cursor))
(cursor-first-x cursor :returnpk t))
(defmethod cursor-plast ((cursor sql-secondary-cursor))
(cursor-last-x cursor :returnpk t))
(defmethod cursor-pnext ((cursor sql-secondary-cursor))
(cursor-next-x cursor :returnpk t))
(defmethod cursor-pprev ((cursor sql-secondary-cursor))
(cursor-prev-x cursor :returnpk t))
(defmethod cursor-pset ((cursor sql-secondary-cursor) key)
(declare (optimize (speed 3)))
(unless (cursor-initialized-p cursor)
(cursor-init cursor))
(let ((idx (position key (:sql-crsr-ks cursor))))
(if idx
(progn
(setf (:sql-crsr-ck cursor) idx)
(setf (:dp-nmbr cursor) 0)
(cursor-current-x cursor :returnpk t))
(cursor-un-init cursor)
)))
(defun array-index-if (p a)
(do ((i 0 (1+ i)))
((or (not (array-in-bounds-p a i))
(funcall p (aref a i)))
(if (funcall p (aref a i))
i
-1)))
)
(defmethod cursor-pset-range ((cursor sql-secondary-cursor) key)
(declare (optimize (speed 3)))
(unless (cursor-initialized-p cursor)
(cursor-init cursor))
(let ((idx (array-index-if #'(lambda (x) (my-generic-less-than key x)) (:sql-crsr-ks cursor))))
(if (<= 0 idx)
(progn
(setf (:sql-crsr-ck cursor) idx)
(setf (:dp-nmbr cursor) 0)
(cursor-current-x cursor :returnpk t)
)
(cursor-un-init cursor :returnpk t)
)))
;; Moves the cursor to a the first secondary key / primary key pair,
;; with secondary key equal to the key argument, and primary key greater or equal to the pkey argument.
;; Returns has-tuple / secondary key / value / primary key.
(defmethod cursor-pget-both ((cursor sql-secondary-cursor) key pkey)
(declare (optimize (speed 3)))
;; It's better to get the value by the primary key,
;; as that is unique..
(let* ((bt (primary (cursor-btree cursor)))
(v (get-value pkey bt)))
;; Now, bascially we set the cursor to the key and
;; andvance it until we get the value that we want...
(if v
[217 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 04:53:00 1.1
[826 lines skipped]
--- /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/02/19 04:53:00 NONE
+++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/02/19 04:53:00 1.1
[869 lines skipped]
1
0
Update of /project/elephant/cvsroot/elephant
In directory common-lisp:/tmp/cvs-serv7130
Modified Files:
Makefile TODO ele-bdb.asd ele-clsql.asd ele-sqlite3.asd
elephant-tests.asd elephant.asd
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/Makefile 2006/01/29 01:08:31 1.8
+++ /project/elephant/cvsroot/elephant/Makefile 2006/02/19 04:52:58 1.9
@@ -32,10 +32,10 @@
all: libsleepycat.$(EXT) libmemutil.$(EXT)
-libmemutil.$(EXT): src/libmemutil.c
+libmemutil.$(EXT): src/memutil/libmemutil.c
gcc $(SHARED) -Wall -fPIC -O3 -o $@ $< -lm
-libsleepycat.$(EXT): src/libsleepycat.c
+libsleepycat.$(EXT): src/db-bdb/libsleepycat.c
gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm
--- /project/elephant/cvsroot/elephant/TODO 2006/02/14 15:31:09 1.12
+++ /project/elephant/cvsroot/elephant/TODO 2006/02/19 04:52:58 1.13
@@ -7,26 +7,26 @@
0.6.0 - Adding default class/slot indexing
- Finish indexing tests (Ian)
- Documentation update (Robert)
+* Add clsql like support for building .so/.dylib from asdf loader on most systems
+* Make elephant thread bound variables dynamic and modifiable by backends
+* Finish migration port and tests
+- Think about dynamic vs. object based store & transaction resolution?
+ - Error checking when mixed
+ - Current store specific *current-transaction* stack
+- Throw condition when store spec is invalid, etc
0.6.1 - performance, safety and portability
Stability:
-- Add clsql like support for building .so/.dylib from asdf loader on most systems
-- Cleanup multi-repository operation (ensure that conflicts between an object's
- registry and *store-controller* does not leed to lockup, especially with BDB (Both)
- Think through default vs. explicit store referencing all over the APIs (Both)
- Cleaner failure modes if operations are performed without repository or without
transaction or auto-commit (Both)
- Add asserts if *auto-index* is false and we're not in a transaction
+- Add asserts if *auto-index* is false and we're not in a transaction
to help users avoid lockups in bdb? Should be able to turn off for
performance but it will help catch missing with-transaction statemetns
in user code. (Both)
- BDB: determine how to detect deadlock conditions as an optional run-safe mode? (?)
- Does BDB have timeouts enabled on select? (Ian)
-- Fix backend dependency problems (missing functions with-transaction-sql, etc)
- caused by not having clsql loaded. Backends should not cause such failures
- and should use asdf to load their deps when the backends are instantiated; much
- like clsql does now
+ Does BDB have timeouts enabled on select? (Ian)
- Remove build gensym warnings
- Port elephant to closer-to-MOP to make it easier to support additional lisps (Both)
- (From Ben's e-mail) We are storing persistent objects incorrectly. They should be
@@ -38,8 +38,6 @@
to use a lot of locks. In general understanding how to use Sleepycat
efficiently seems like a good thing. (From Ben)
- Reclaim table storage on index drop (Ian)
-- Higher performance fix for allegro unicode serialization workaround than
- my current one (Ian)
- Add dependency information into secondary index callback functions so that
we can more easily compute which indices need to be updated to avoid the
global remove/add in order to maintain consistency (Ian)
--- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/15 01:54:07 1.5
+++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 04:52:58 1.6
@@ -1,10 +1,9 @@
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
-;;; ele-clsql.asd -- ASDF system definition for
-;;; a Berkeley-DB based back-end for Elephant
+;;; elephant.asd -- ASDF system definition for elephant
;;;
-;;; Initial version 10/12/2005 by Robert L. Read
-;;; <read(a)robertlread.net>
+;;; Initial version 8/26/2004 by Ben Lee
+;;; <blee(a)common-lisp.net>
;;;
;;; part of
;;;
@@ -13,46 +12,36 @@
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net>
;;;
-;;; This program is released under the following license
-;;; ("GPL"). For differenct licensing terms, contact the
-;;; copyright holders.
-;;;
-;;; This program is free software; you can redistribute it
-;;; and/or modify it under the terms of the GNU General
-;;; Public License as published by the Free Software
-;;; Foundation; either version 2 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be
-;;; useful, but WITHOUT ANY WARRANTY; without even the
-;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
-;;; PARTICULAR PURPOSE. See the GNU General Public License
-;;; for more details.
-;;;
-;;; The GNU General Public License can be found in the file
-;;; LICENSE which should have been distributed with this
-;;; code. It can also be found at
-;;;
-;;; http://www.opensource.org/licenses/gpl-license.php
-;;;
-;;; You should have received a copy of the GNU General
-;;; Public License along with this program; if not, write
-;;; to the Free Software Foundation, Inc., 59 Temple Place,
-;;; Suite 330, Boston, MA 02111-1307 USA
-;;;
+;;; 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 ele-bdb-system
+ (:use :cl :asdf))
+
+(in-package :ele-bdb-system)
(defsystem ele-bdb
- :name "ele-bdb"
- :author "Robert L. Read <rread(a)common-lisp.net>"
- :version "0.1"
- :maintainer "Robert L. Read <rread(a)common-lisp.net>"
+ :name "elephant"
+ :author "Ben Lee <blee(a)common-lisp.net>"
+ :version "0.6.0"
+ :maintainer "Ben Lee <blee(a)common-lisp.net>"
:licence "LLGPL"
- :description "Berkeley-DB based Object respository for Common Lisp"
- :long-description "Including this loads the Berkeley-DB code; you may have to edit the pathname!"
+ :description "Object database for Common Lisp"
+ :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro."
:components
((:module :src
:components
- ((:file "bdb-enable")
- )
- :serial t))
- :depends-on (:elephant ))
+ ((:module :db-bdb
+ :components
+ ((:file "package")
+ (:file "sleepycat")
+ (:file "bdb-controller")
+ (:file "bdb-transactions")
+ (:file "bdb-collections"))
+ :serial t))))
+ :depends-on (:uffi :elephant))
+
+
--- /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/04 22:25:09 1.3
+++ /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/19 04:52:58 1.4
@@ -1,10 +1,9 @@
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;
-;;; ele-clsql.asd -- ASDF system definition for
-;;; a CL-SQL based back-end for Elephant
+;;; elephant.asd -- ASDF system definition for elephant
;;;
-;;; Initial version 10/12/2005 by Robert L. Read
-;;; <read(a)robertlread.net>
+;;; Initial version 8/26/2004 by Ben Lee
+;;; <blee(a)common-lisp.net>
;;;
;;; part of
;;;
@@ -13,48 +12,26 @@
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net>
;;;
-;;; This program is released under the following license
-;;; ("GPL"). For differenct licensing terms, contact the
-;;; copyright holders.
-;;;
-;;; This program is free software; you can redistribute it
-;;; and/or modify it under the terms of the GNU General
-;;; Public License as published by the Free Software
-;;; Foundation; either version 2 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be
-;;; useful, but WITHOUT ANY WARRANTY; without even the
-;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
-;;; PARTICULAR PURPOSE. See the GNU General Public License
-;;; for more details.
-;;;
-;;; The GNU General Public License can be found in the file
-;;; LICENSE which should have been distributed with this
-;;; code. It can also be found at
-;;;
-;;; http://www.opensource.org/licenses/gpl-license.php
-;;;
-;;; You should have received a copy of the GNU General
-;;; Public License along with this program; if not, write
-;;; to the Free Software Foundation, Inc., 59 Temple Place,
-;;; Suite 330, Boston, MA 02111-1307 USA
-;;;
+;;; 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.
-(defsystem ele-clsql
- :name "ele-clsql"
- :author "Robert L. Read <read(a)robertlread.net>"
- :version "0.1"
- :maintainer "Robert L. Read <read(a)robertlread.net>"
+(defsystem ele-sql
+ :name "elephant"
+ :author "Ben Lee <blee(a)common-lisp.net>"
+ :version "0.6.0"
+ :maintainer "Ben Lee <blee(a)common-lisp.net>"
:licence "LLGPL"
:description "SQL-based Object respository for Common Lisp"
:long-description "An experimental CL-SQL based implementation of Elephant"
-
- :components
((:module :src
:components
- ((:file "sql-controller")
- (:file "sql-collections")
- )
- :serial t))
+ ((:module :db-clsql
+ :components
+ ((:file "sql-controller")
+ (:file "sql-transactions")
+ (:file "sql-collections"))
+ :serial t))))
:depends-on (:elephant :clsql :cl-base64))
+
+
--- /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/15 01:54:07 1.4
+++ /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/19 04:52:58 1.5
@@ -44,7 +44,7 @@
(defsystem ele-sqlite3
:name "ele-sqlite3"
:author "Robert L. Read <read(a)robertlread.net>"
- :version "0.1"
+ :version "0.6.0"
:maintainer "Robert L. Read <read(a)robertlread.net>"
:licence "GPL"
:description "SQLite3 based Object respository for Common Lisp"
@@ -56,4 +56,4 @@
(
)
:serial t))
- :depends-on (:ele-clsql :clsql-sqlite3))
+ :depends-on (:ele-sql :clsql-sqlite3))
--- /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/02/07 23:23:50 1.5
+++ /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/02/19 04:52:58 1.6
@@ -55,11 +55,25 @@
:components
((:file "elephant-tests")
(:file "testserializer")
- (:file "testsleepycat")
(:file "mop-tests")
(:file "testcollections")
(:file "testindexing")
(:file "testmigration")
)
:serial t)))
+
+(defsystem elephant-tests-bdb
+ :name "elephant"
+ :author "Ben Lee <blee(a)common-lisp.net>"
+ :version "0.1"
+ :maintainer "Ben Lee <blee(a)common-lisp.net>"
+ :licence "Lessor Lisp General Public License"
+ :description "Tests that only run under BDB"
+
+ :depends-on (:elephant-tests)
+ :components
+ ((:module :tests
+ :components
+ ((:file "testsleepycat")))))
+
--- /project/elephant/cvsroot/elephant/elephant.asd 2006/02/07 23:23:50 1.12
+++ /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 04:52:58 1.13
@@ -12,64 +12,49 @@
;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee
;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net>
;;;
-;;; This program is released under the following license
-;;; ("GPL"). For differenct licensing terms, contact the
-;;; copyright holders.
-;;;
-;;; This program is free software; you can redistribute it
-;;; and/or modify it under the terms of the GNU General
-;;; Public License as published by the Free Software
-;;; Foundation; either version 2 of the License, or (at
-;;; your option) any later version.
-;;;
-;;; This program is distributed in the hope that it will be
-;;; useful, but WITHOUT ANY WARRANTY; without even the
-;;; implied warranty of MERCHANTABILITY or FITNESS FOR A
-;;; PARTICULAR PURPOSE. See the GNU General Public License
-;;; for more details.
-;;;
-;;; The GNU General Public License can be found in the file
-;;; LICENSE which should have been distributed with this
-;;; code. It can also be found at
-;;;
-;;; http://www.opensource.org/licenses/gpl-license.php
-;;;
-;;; You should have received a copy of the GNU General
-;;; Public License along with this program; if not, write
-;;; to the Free Software Foundation, Inc., 59 Temple Place,
-;;; Suite 330, Boston, MA 02111-1307 USA
-;;;
+;;; 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-system
+ (:use :cl :asdf))
+
+(in-package :elephant-system)
(defsystem elephant
:name "elephant"
:author "Ben Lee <blee(a)common-lisp.net>"
- :version "0.5.0"
+ :version "0.6.0"
:maintainer "Ben Lee <blee(a)common-lisp.net>"
:licence "LLGPL"
:description "Object database for Common Lisp"
:long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro."
-
:components
((:module :src
:components
- ((:file "sleepycat")
- (:file "berkeley-db")
- (:file "elephant")
- (:file "utils")
- #+cmu
- (:file "cmu-mop-patches")
- #+openmcl
- (:file "openmcl-mop-patches")
- (:file "metaclasses")
- (:file "classes")
- (:file "controller")
- (:file "collections")
- (:file "serializer")
- (:file "index-utils")
- (:file "indexing"))
- #+openmcl
- (:file "openmcl-mop-patches")
- :serial t))
+ ((:module memutil
+ :components
+ ((:file "memutil")))
+ (:module elephant
+ :components
+ ((:file "elephant")
+ (:file "variables")
+ #+cmu (:file "cmu-mop-patches")
+ #+openmcl (:file "openmcl-mop-patches")
+ (:file "transactions")
+ (:file "metaclasses")
+ (:file "classes")
+ (:file "serializer")
+ (:file "cache")
+ (:file "controller")
+ (:file "collections")
+ (:file "classindex-utils")
+ (:file "classindex")
+ (:file "migrate")
+ (:file "backend"))
+ :serial t
+ :depends-on (memutil)))))
:depends-on (:uffi))
-
1
0
Update of /project/elephant/cvsroot/elephant/examples
In directory common-lisp:/tmp/cvs-serv7130/examples
Added Files:
index-tutorial.lisp sql-tutorial.lisp
Log Message:
See elephant-devel mail for changes...and take a big, deep breath...
--- /project/elephant/cvsroot/elephant/examples/index-tutorial.lisp 2006/02/19 04:52:58 NONE
+++ /project/elephant/cvsroot/elephant/examples/index-tutorial.lisp 2006/02/19 04:52:58 1.1
(defpackage elephant-tutorial
(:use :cl :elephant))
(in-package :elephant-tutorial)
(defclass simple-plog ()
((timestamp :accessor plog-timestamp :initarg :timestamp :index t)
(type :accessor plog-type :initarg :type :index t)
(data :accessor plog-data :initarg :data)
(user :accessor plog-user :initarg :user :index t))
(:metaclass persistent-metaclass)
(:documentation "Simple persistent log"))
(defclass url-record ()
((url :accessor url-record-url :initarg :url :initform "")
(fetched :accessor url-record-fetched :initarg :fetched :initform nil)
(analyzed :accessor url-record-analyzed :initarg :analyzed :initform nil))
(:documentation "An application object, declared persistent but not indexed"))
(defmethod print-object ((obj url-record) stream)
"Pretty print program objects so they're easy to inspect"
(format stream "<url: ~A ~A ~A>" (url-record-url obj) (url-record-fetched obj) (url-record-analyzed obj)))
(defclass url-log (simple-plog) ()
(:metaclass persistent-metaclass)
(:documentation "This class tracks events that transform our program object state"))
(defmethod print-object ((obj url-log) stream)
"Structured printing of log entries so they're easy to inspect at the repl"
(format stream "#plog[~A :: ~A]" (plog-type obj) (plog-data obj)))
(defun log-event (user type data)
"A helper function to generically log various events by user"
(make-instance 'url-log
:timestamp (get-universal-time)
:type type
:data data
:user user))
(defun report-events-by-time (user start end)
"A custom reporting function for our logs - pull out a time range. A real
implementation might do it by dates or by dates + times using one of the
lisp time libraries"
(let ((entries1 (get-instances-by-range 'url-log 'timestamp start end))
(entries2 (get-instances-by-value 'url-log 'user user)))
(format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2))
(format t "~{~A~%~}" (nreverse (intersection entries1 entries2)))))
;;
;; This code is the skeleton of a program
;;
(defvar *start-timestamp* nil)
(defvar *end-timestamp* nil)
(defun generate-events (user count &optional delay)
(setf *start-timestamp* (get-universal-time))
(loop for i from 1 upto count do
(let ((url (get-a-url user i)))
(sleep delay)
(fetch-url url user)
(sleep delay)
(analyze-url url user)
(sleep delay)))
(setf *end-timestamp* (get-universal-time)))
(defun get-a-url (user seq)
(let ((url (make-instance 'url-record :url (format nil "http://www.common-lisp.net/~A/" seq))))
(log-event user :received-url url)
url))
(defun fetch-url (url user)
(setf (url-record-fetched url) t)
(log-event user :fetched-url url))
(defun analyze-url (url user)
(setf (url-record-analyzed url) t)
(log-event user :analyzed-url url))
;; Top Level Test Code
(defun test-generate-and-report (name store-spec)
(open-store store-spec)
(generate-events name 10 0.2)
(report-events name)
(close-store))
(defun report-events (name)
(let ((first-third-start *start-timestamp*)
(first-third-end (+ *start-timestamp*
(/ (- *end-timestamp* *start-timestamp*) 3))))
(report-events-by-time name first-third-start first-third-end)))
--- /project/elephant/cvsroot/elephant/examples/sql-tutorial.lisp 2006/02/19 04:52:58 NONE
+++ /project/elephant/cvsroot/elephant/examples/sql-tutorial.lisp 2006/02/19 04:52:58 1.1
;;; sql-tutorial.lisp
;;;
;;; part of
;;;
;;; Elephant: an object-oriented database for Common Lisp
;;;
;;;
;;; 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.
(asdf:operate 'asdf:load-op :elephant)
(asdf:operate 'asdf:load-op :ele-bdb)
(asdf:operate 'asdf:load-op :elephant-tests)
(in-package "ELEPHANT-TESTS")
(open-store *testdb-path*)
(add-to-root "my key" "my value")
(get-from-root "my key")
(setq foo (cons nil nil))
(add-to-root "my key" foo)
(add-to-root "my other key" foo)
(eq (get-from-root "my key")
(get-from-root "my other key"))
(setf (car foo) T)
(get-from-root "my key")
(defclass my-persistent-class ()
((slot1 :accessor slot1)
(slot2 :accessor slot2))
(:metaclass persistent-metaclass))
(setq foo (make-instance 'my-persistent-class))
(add-to-root "foo" foo)
(add-to-root "bar" foo)
(eq (get-from-root "foo")
(get-from-root "bar"))
(get-from-root "foo")
(setf (slot1 foo) "one")
(setf (slot2 foo) "two")
(slot1 foo)
(slot2 foo)
(setf (slot1 foo) "three")
(slot1 (get-from-root "bar"))
(setq *auto-commit* nil)
(with-transaction ()
(setf (slot1 foo) 123456789101112)
(setf (slot2 foo) "onetwothree..."))
(defvar *friends-birthdays* (make-btree))
(add-to-root "friends-birthdays" *friends-birthdays*)
(setf (get-value "Andrew" *friends-birthdays*)
(encode-universal-time 0 0 0 22 12 1976))
(setf (get-value "Ben" *friends-birthdays*)
(encode-universal-time 0 0 0 14 4 1976))
(get-value "Andrew" *friends-birthdays*)
(decode-universal-time *)
(defvar curs (make-cursor *friends-birthdays*))
(cursor-close curs)
(setq curs (make-cursor *friends-birthdays*))
(cursor-current curs)
(cursor-first curs)
(cursor-next curs)
(cursor-next curs)
(cursor-close curs)
(with-transaction ()
(with-btree-cursor (curs *friends-birthdays*)
(loop
(multiple-value-bind (more k v) (cursor-next curs)
(unless more (return nil))
(format t "~A ~A~%" k v)))))
(defclass appointment ()
((date :accessor ap-date :initarg :date :type integer)
(type :accessor ap-type :initarg :type :type string))
(:metaclass persistent-metaclass))
(defvar *appointments* (with-transaction () (make-indexed-btree *store-controller*)))
(defun add-appointment (date type)
(with-transaction ()
(setf (get-value date *appointments*)
(make-instance 'appointment :date date :type type))))
(add-appointment (encode-universal-time 0 0 0 22 12 2004) "Birthday")
(add-appointment (encode-universal-time 0 0 0 14 4 2005) "Birthday")
(add-appointment (encode-universal-time 0 0 0 1 1 2005) "Holiday")
(defun key-by-type (secondary-db primary value)
(declare (ignore secondary-db primary))
(let ((type (ap-type value)))
(when type
(values t type))))
(with-transaction ()
(add-index *appointments* :index-name 'by-type
:key-form 'key-by-type
:populate t))
(defvar *by-type* (get-index *appointments* 'by-type))
(decode-universal-time (ap-date (get-value "Holiday" *by-type*)))
(with-btree-cursor (curs *by-type*)
(loop for (more? k v) =
(multiple-value-list (cursor-set curs "Birthday"))
then (multiple-value-list (cursor-next-dup curs))
do
(unless more? (return t))
(multiple-value-bind (s m h d mo y)
(decode-universal-time (ap-date v))
(declare (ignore s m h))
(format t "~A/~A/~A~%" mo d y))))
1
0
Update of /project/elephant/cvsroot/elephant/src/db-clsql
In directory common-lisp:/tmp/cvs-serv6758/db-clsql
Log Message:
Directory /project/elephant/cvsroot/elephant/src/db-clsql added to the repository
1
0