November 2005 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS update: elephant/doc/sql-backend.texinfo
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant/doc In directory common-lisp.net:/tmp/cvs-serv588/doc Modified Files: sql-backend.texinfo Log Message: Slightly more accurate NEWS. Date: Wed Nov 23 19:17:53 2005 Author: rread Index: elephant/doc/sql-backend.texinfo diff -u elephant/doc/sql-backend.texinfo:1.2 elephant/doc/sql-backend.texinfo:1.3 --- elephant/doc/sql-backend.texinfo:1.2 Wed Nov 23 18:51:34 2005 +++ elephant/doc/sql-backend.texinfo Wed Nov 23 19:17:52 2005 @@ -147,7 +147,7 @@ So you could put a symbolic link to libpq.so there, where libmemutil.so and libsleepycat.so will also reside. -Versions of CL-SQL older than 3.2.3 might requie something different. +Versions of CL-SQL older than 3.2.3 might require something different. @node Multi-repository Operation @comment node-name, next, previous, up

1 0

[elephant-cvs] CVS update: elephant/NEWS
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv588 Modified Files: NEWS Log Message: Slightly more accurate NEWS. Date: Wed Nov 23 19:17:52 2005 Author: rread Index: elephant/NEWS diff -u elephant/NEWS:1.7 elephant/NEWS:1.8 --- elephant/NEWS:1.7 Wed Nov 23 18:51:31 2005 +++ elephant/NEWS Wed Nov 23 19:17:52 2005 @@ -3,6 +3,14 @@ support for relational database backends, repository migration, and multi-repository operation. +As of this release, the documentation provides a +lot of information about installation and getting +things working; I wouldn't at all claim that it +is complete, smooth, or well organized. The more +notes I get about the use of Elephant, the more +inclined I will be to invest time in improving +the documentation. + October 7, 2004 - Elephant 0.2.1 released. Thanks to Bill Clementson,

1 0

[elephant-cvs] CVS update: elephant/doc/intro.texinfo
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant/doc In directory common-lisp.net:/tmp/cvs-serv31956 Modified Files: intro.texinfo Log Message: Slightly improved documentation. Date: Wed Nov 23 19:14:11 2005 Author: rread Index: elephant/doc/intro.texinfo diff -u elephant/doc/intro.texinfo:1.1 elephant/doc/intro.texinfo:1.2 --- elephant/doc/intro.texinfo:1.1 Sun Sep 19 19:44:43 2004 +++ elephant/doc/intro.texinfo Wed Nov 23 19:14:11 2005 @@ -14,6 +14,15 @@ relative to relational databases; hopefully Elephant inherits these properties. +This release, Elephant 0.3, also provieds support for +relational backends. It has been tested with Postgres and SQLite 3. +It is back-compatible with any code that ran against previous +versions of Elephant, but also supports simultaneous multi-repository +operation and convenient migration of data between repositories. +This hopefully allows decisions about the prefered back-end +storage mechanism to be delayed and changed, even after +an application that uses Elephant is mature. + Goals: @itemize

1 0

[elephant-cvs] CVS update: elephant/tests/testsleepycat/README
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant/tests/testsleepycat In directory common-lisp.net:/tmp/cvs-serv30677/tests/testsleepycat Added Files: README Log Message: This is the big merger from the SQL-BACK-END branch. Date: Wed Nov 23 18:52:10 2005 Author: rread Index: elephant/tests/testsleepycat/README diff -u /dev/null elephant/tests/testsleepycat/README:1.2 --- /dev/null Wed Nov 23 18:52:10 2005 +++ elephant/tests/testsleepycat/README Wed Nov 23 18:52:09 2005 @@ -0,0 +1 @@ +This directory needs to exists for the tests to go smoothly.

1 0

[elephant-cvs] CVS update: elephant/tests/testdb/README
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant/tests/testdb In directory common-lisp.net:/tmp/cvs-serv30677/tests/testdb Added Files: README Log Message: This is the big merger from the SQL-BACK-END branch. Date: Wed Nov 23 18:52:05 2005 Author: rread Index: elephant/tests/testdb/README diff -u /dev/null elephant/tests/testdb/README:1.2 --- /dev/null Wed Nov 23 18:52:06 2005 +++ elephant/tests/testdb/README Wed Nov 23 18:52:05 2005 @@ -0,0 +1 @@ +This directory needs to exists for the tests to go smoothly.

1 0

[elephant-cvs] CVS update: elephant/tests/testmigration.lisp elephant/tests/elephant-tests.lisp elephant/tests/mop-tests.lisp elephant/tests/testcollections.lisp elephant/tests/testserializer.lisp
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv30677/tests Modified Files: elephant-tests.lisp mop-tests.lisp testcollections.lisp testserializer.lisp Added Files: testmigration.lisp Log Message: This is the big merger from the SQL-BACK-END branch. Date: Wed Nov 23 18:52:00 2005 Author: rread Index: elephant/tests/testmigration.lisp diff -u /dev/null elephant/tests/testmigration.lisp:1.2 --- /dev/null Wed Nov 23 18:52:01 2005 +++ elephant/tests/testmigration.lisp Wed Nov 23 18:51:59 2005 @@ -0,0 +1,170 @@ +;; This file can really only be used if you +;; have preformed both: +;; (asdf:operate 'asdf:load-op :ele-bdb) +;; and +;; (asdf:operate 'asdf:load-op :ele-clsql) + +(in-package :ele-tests) + +(deftest remove-element + (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 + (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) + t) + + +(deftest migrate2 + (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 ((ibt (build-btree sc1))) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) + (let ((mig (migrate sc2 ibt))) + (btree-differ ibt mig)))) + (progn + (setq *store-controller* old-store) + (setq *auto-commit* *prev-commit*)))) + nil) + + +(deftest migrate3 + (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* ((ibt (build-indexed-btree sc1))) + (let ( + (index + (add-index ibt :index-name 'crunch :key-form 'crunch + :populate t)) + ) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) + (let* ((mig (migrate sc2 ibt)) + (nindex (gethash 'crunch (indices ibt)))) + (loop for i from 0 to 10 + do + (if (not + (equal + (get-value i index) + (get-value i nindex) + )) + (progn + (format t "YIKES ~A ~%" i) + ))) + (setf rv (not (btree-differ ibt mig))) + )))) + (progn + (setq *store-controller* old-store) + (setq *auto-commit* *prev-commit*))) + rv) + t) + + +(deftest migrate4 + (finishes + (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* ((ibt (build-indexed-btree sc1))) + (let ( + (index + (add-index ibt :index-name 'crunch :key-form 'crunch + :populate t)) + (x 0) + ) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) + ))) + (progn + (setq *store-controller* old-store) + (setq *auto-commit* *prev-commit*))) + )) + t) + +(deftest migrate5 + (finishes + (let ((old-store *store-controller*) + (*prev-commit* *auto-commit*) + (*auto-commit* t)) + (unwind-protect + (let ((osc (if (subtypep (type-of *store-controller*) 'sql-store-controller) + (open-store *test-path-primary*) + (open-store *test-path-secondary*) + ))) +;; really need to test the an error is thrown when attempting to migrate +;; non-persistent object! + (let* ((f1 (make-instance 'pfoo :sc *store-controller*)) + (f2 (make-instance 'pfoo :slot1 "this is a string" :sc *store-controller*)) + (b1 (make-instance 'pbar :slot2 "another string" :sc *store-controller*)) + ) + (let ((fm1 + (ele::migraten-pobj + osc f1 + #'(lambda (dst src) + (if (slot-boundp src 'slot1) + (setf (slot1 dst) (slot1 src)))))) + (fm2 + (ele::migraten-pobj + osc f2 + #'(lambda (dst src) + (if (slot-boundp src 'slot1) + (setf (slot1 dst) (slot1 src)))))) + (bm1 (ele::migraten-pobj + osc b1 + #'(lambda (dst src) + (if (slot-boundp src 'slot2) + (setf (slot2 dst) (slot2 src)))))) + ) + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 bm1) (slot2 b1)))))) + (progn + (setq *store-controller* old-store) + (setq *auto-commit* *prev-commit*)))) + ) + t) Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.5 elephant/tests/elephant-tests.lisp:1.6 --- elephant/tests/elephant-tests.lisp:1.5 Thu Feb 24 02:07:51 2005 +++ elephant/tests/elephant-tests.lisp Wed Nov 23 18:51:59 2005 @@ -81,6 +81,9 @@ (in-package :ele-tests) +;; 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* ;;"/usr/local/share/common-lisp/elephant-0.2/tests/testdb" @@ -93,11 +96,50 @@ ;;"/usr/local/share/common-lisp/elephant-0.2/tests/testdb" (namestring (merge-pathnames - #p"tests/sleepycatdb/" + #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* + *testpg-path* +) +(defvar *test-path-secondary* + *testdb-path* +) + + (defun do-all-tests() - (with-open-store (*testdb-path*) + (progn + (do-all-tests-spec *testdb-path*) + (do-all-tests-spec *testpg-path*) + )) + +(defun do-crazy-pg-tests() + (open-store *testpg-path*) + (do-test 'indexed-btree-make) + (do-test 'add-indices) + (do-test 'test-indices) + (do-test 'indexed-put) + (do-test 'indexed-get) + (close-store) + ) + +(defun do-migrate-test-spec(spud) + (with-open-store(spud) + (let ((*auto-commit* nil)) + (do-test 'migrate1)))) + +(defun do-all-tests-spec(spec) + (with-open-store (spec) (let ((*auto-commit* nil)) (do-tests)))) @@ -132,4 +174,4 @@ (defmacro are-not-null (&rest forms) `(values ,@(loop for form in forms - collect `(is-not-null ,form)))) \ No newline at end of file + collect `(is-not-null ,form)))) Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.7 elephant/tests/mop-tests.lisp:1.8 --- elephant/tests/mop-tests.lisp:1.7 Thu Feb 24 02:07:51 2005 +++ elephant/tests/mop-tests.lisp Wed Nov 23 18:51:59 2005 @@ -139,14 +139,14 @@ (deftest initform-test (let ((*auto-commit* t)) - (slot-value (make-instance 'p-initform-test) 'slot1)) + (slot-value (make-instance 'p-initform-test :sc *store-controller*) 'slot1)) 10) (deftest initarg-test (let ((*auto-commit* t)) (values - (slot-value (make-instance 'p-initform-test-2) 'slot1) - (slot-value (make-instance 'p-initform-test-2 :slot1 20) 'slot1))) + (slot-value (make-instance 'p-initform-test-2 :sc *store-controller*) 'slot1) + (slot-value (make-instance 'p-initform-test-2 :slot1 20 :sc *store-controller*) 'slot1))) 10 20) (deftest no-eval-initform @@ -155,7 +155,7 @@ ((slot1 :initarg :slot1 :initform (error "Shouldn't be called"))) (:metaclass persistent-metaclass)) (let ((*auto-commit* t)) - (make-instance 'no-eval-initform :slot1 "something")) + (make-instance 'no-eval-initform :slot1 "something" :sc *store-controller* )) t) t) @@ -168,8 +168,8 @@ ;; i wish i could use slot-makunbound but allegro sux (deftest makunbound - (let ((p (make-instance 'p-class))) - (with-transaction () + (let ((p (make-instance 'p-class :sc *store-controller*))) + (with-transaction (:store-controller *store-controller*) (setf (slot1 p) t) #-allegro (slot-makunbound p 'slot1) @@ -186,7 +186,7 @@ ((slot1 :initform 1 :accessor slot1)) (:metaclass persistent-metaclass)) (let* ((*auto-commit* t) - (foo (make-instance 'update-class))) + (foo (make-instance 'update-class :sc *store-controller*))) (defclass update-class () ((slot2 :initform 2 :accessor slot2)) (:metaclass persistent-metaclass)) @@ -207,7 +207,7 @@ (:metaclass persistent-metaclass)) (let* ((*auto-commit* t) - (foo (make-instance 'class-one))) + (foo (make-instance 'class-one :sc *store-controller*))) (change-class foo (find-class 'class-two)) (values (slot1 foo) @@ -215,9 +215,13 @@ 1 2) (deftest change-class2 - (with-transaction () - (let ((foo (make-instance 'btree))) - (change-class foo (find-class 'indexed-btree)) + (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) @@ -233,7 +237,7 @@ (:metaclass persistent-metaclass)) (let* ((*auto-commit* t) - (foo (make-instance 'class-one))) + (foo (make-instance 'class-one :sc *store-controller*))) (change-class foo (find-class 'class-two)) (values (slot1 foo) Index: elephant/tests/testcollections.lisp diff -u elephant/tests/testcollections.lisp:1.3 elephant/tests/testcollections.lisp:1.4 --- elephant/tests/testcollections.lisp:1.3 Thu Feb 24 02:06:05 2005 +++ elephant/tests/testcollections.lisp Wed Nov 23 18:51:59 2005 @@ -1,12 +1,29 @@ (in-package :ele-tests) +(deftest basicpersistence + (let ((old-store *store-controller*) + (*prev-commit* *auto-commit*) + (*auto-commit* t) + (rv nil)) + (unwind-protect + (let ((x (gensym))) + (add-to-root "x" x) + (let ((sc1 (open-store *test-path-primary*))) + (setf rv (equal (format nil "~A" x) + (format nil "~A" (get-from-root "x")))))) + (progn + (setq *store-controller* old-store) + (setq *auto-commit* *prev-commit*))) + rv) + t +) + (deftest testoid (progn (ele::next-oid *store-controller*) (let ((oid (ele::next-oid *store-controller*))) - (with-open-store (*testdb-path*) - (< oid (ele::next-oid *store-controller*))))) + (< oid (ele::next-oid *store-controller*)))) t) (defclass blob () @@ -24,17 +41,23 @@ (defvar bt) (deftest btree-make - (finishes (setq bt (make-instance 'btree))) + (finishes (setq bt (build-btree *store-controller*))) t) -(setq *auto-commit* nil) +;; 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 () - (loop for obj in objs - for key in keys - do (setf (get-value key bt) obj)))) + (with-transaction (:store-controller *store-controller*) + (loop for obj in objs + for key in keys + do (setf (get-value key bt) obj)))) t) (deftest btree-get @@ -48,8 +71,13 @@ (defvar first-key (first keys)) + +;; For some unkown reason, this fails on my server unless +;; I put the variable "first-key" here rather than use the string +;; "key-1". I need to understand this, but don't at present.... (deftest remove-kv - (finishes (with-transaction () (remove-kv first-key bt))) + (finishes + (with-transaction (:store-controller *store-controller*) (remove-kv "key-1" bt))) t) (deftest removed @@ -66,13 +94,14 @@ (subsetp (cdr keys) ks :test #'equalp)))) t) +;; I hate global variables! Yuck! (defvar indexed) (defvar index1) (defvar index2) (deftest indexed-btree-make - (finishes (with-transaction () - (setq indexed (make-instance 'indexed-btree)))) + (finishes (with-transaction (:store-controller *store-controller*) + (setq indexed (build-indexed-btree *store-controller*)))) t) (defun key-maker (s key value) @@ -81,7 +110,7 @@ (deftest add-indices (finishes - (with-transaction () + (with-transaction (:store-controller *store-controller*) (setf index1 (add-index indexed :index-name 'slot1 :key-form 'key-maker)) (setf index2 @@ -116,10 +145,10 @@ (deftest indexed-put (finishes - (with-transaction () + (with-transaction (:store-controller *store-controller*) (loop for obj in objs - for key in keys - do (setf (get-value key indexed) obj)))) + for key in keys + do (setf (get-value key indexed) obj)))) t) (deftest indexed-get @@ -131,6 +160,16 @@ (= (slot2 obj) (* i 100)))) t) + +(deftest simple-slot-get + (progn + (setf (get-value (nth 0 keys) indexed) (nth 0 objs)) + (let ((obj + (get-value 1 index1))) + (and (= (slot1 obj) 1) + (= (slot2 obj) (* 1 100))))) +t) + (deftest indexed-get-from-slot1 (loop with index = (get-index indexed 'slot1) for i from 1 to 1000 @@ -158,10 +197,10 @@ (get-primary-key 100 index2)) nil nil nil) + (deftest remove-kv-from-slot1 (finishes (remove-kv 2 index1)) t) - (deftest no-key-nor-indices-slot1 (values (get-value (second keys) indexed) @@ -172,7 +211,6 @@ (deftest remove-kv-from-slot2 (finishes (remove-kv 300 index2)) t) - (deftest no-key-nor-indices-slot2 (values (get-value (third keys) indexed) @@ -190,8 +228,11 @@ (subsetp (cdddr keys) ks :test #'equalp)))) t) +;; This is "4" below because they have removed the +;; first three keys, and are testing that the index reflect this, +;; and my code doesn't. (deftest get-first - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (c index1) (multiple-value-bind (has k v) (cursor-first c) @@ -200,7 +241,7 @@ t) (deftest get-first2 - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (c index2) (multiple-value-bind (has k v) (cursor-first c) @@ -209,7 +250,7 @@ t) (deftest get-last - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (c index1) (multiple-value-bind (has k v) (cursor-last c) @@ -218,7 +259,7 @@ t) (deftest get-last2 - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (c index2) (multiple-value-bind (has k v) (cursor-last c) @@ -227,7 +268,7 @@ t) (deftest set - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (c index1) (multiple-value-bind (has k v) (cursor-set c 200) @@ -236,7 +277,7 @@ t) (deftest set2 - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (c index2) (multiple-value-bind (has k v) (cursor-set c 500) @@ -245,7 +286,7 @@ t) (deftest set-range - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (c index1) (multiple-value-bind (has k v) (cursor-set-range c 199.5) @@ -254,7 +295,7 @@ t) (deftest set-range2 - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (c index2) (multiple-value-bind (has k v) (cursor-set-range c 501) @@ -262,12 +303,75 @@ (= (slot2 v) 600)))) t) +(deftest rem-kv + (with-transaction (:store-controller *store-controller*) + (let ((ibt (build-indexed-btree *store-controller*))) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) + (remove-kv 0 ibt) + (remove-kv 1 ibt) + (remove-kv 10 ibt) + (equal (list + (get-value 0 ibt) + (get-value 1 ibt) + (get-value 10 ibt) + (get-value 5 ibt) + ) + '(nil nil nil 25)) + )) +t + ) + +(defun odd (s k v) + (declare (ignore s k)) + (values t (mod v 2) +)) + +(deftest rem-idexkv + (with-transaction (:store-controller *store-controller*) + (let* ((ibt (build-indexed-btree *store-controller*)) + (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) + + (with-btree-cursor (c id1) + (cursor-first c) + (dotimes (i 10) + (multiple-value-bind (has key value) + (cursor-next c) + )) + ) + (remove-kv 4 ibt) + (remove-kv 5 ibt) + + (equal (list + (get-value 4 ibt) + (get-value 5 ibt) + (get-value 6 ibt) + (with-btree-cursor (c ibt) + (cursor-first c) + (dotimes (i 4) + (multiple-value-bind (has key value) + (cursor-next c) + value)) + (multiple-value-bind (has key value) + (cursor-next c) + value + ) + )) + '(nil nil 36 49) + ))) + t + ) + (defvar indexed2) (defvar index3) (deftest make-indexed2 - (finishes (with-transaction () - (setq indexed2 (make-instance 'indexed-btree)))) + (finishes (with-transaction (:store-controller *store-controller*) + (setq indexed2 (build-indexed-btree *store-controller*)))) t) (defun crunch (s k v) @@ -276,14 +380,14 @@ (deftest add-indices2 (finishes - (with-transaction () + (with-transaction (:store-controller *store-controller*) (setq index3 (add-index indexed2 :index-name 'crunch :key-form 'crunch)))) t) (deftest put-indexed2 (finishes - (with-transaction () + (with-transaction (:store-controller *store-controller*) (loop for i from 0 to 10000 do (setf (get-value i indexed2) (- i))))) @@ -295,13 +399,12 @@ t) (deftest get-from-index3 - (loop for i from 0 to 1000 - always (= (* i -10) (get-value i index3))) - t) - + (loop for i from 0 to 1000 + always (= (* i -10) (get-value i index3))) + t) (deftest dup-test - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (curs index3) (loop for (more k v) = (multiple-value-list (cursor-first curs)) @@ -311,8 +414,9 @@ (0 -1 -2 -3 -4 -5 -6 -7 -8 -9)) + (deftest nodup-test - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (curs index3) (loop for (m k v) = (multiple-value-list (cursor-next-nodup curs)) for i from 0 downto -9990 by 10 @@ -321,7 +425,7 @@ t) (deftest prev-nodup-test - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (curs index3) (cursor-last curs) (loop for (m k v) = (multiple-value-list (cursor-prev-nodup curs)) @@ -331,7 +435,7 @@ t) (deftest pnodup-test - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (curs index3) (loop for (m k v p) = (multiple-value-list (cursor-pnext-nodup curs)) for i from 0 to 9990 by 10 @@ -340,7 +444,7 @@ t) (deftest pprev-nodup-test - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (curs index3) (cursor-last curs) (loop for (m k v p) = (multiple-value-list (cursor-pprev-nodup curs)) @@ -349,9 +453,36 @@ always (= p i)))) t) +(deftest cur-del1 + ;; 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*)) + (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) +;; This appears to delete the SINGLE value pointed two by +;; the cursor at that time. (the way it is written now, the second-to-last element 9 = 81; +;; If you want to delete more, you have to iterate through the cursor, I suppose. + (with-btree-cursor (c id1) + (cursor-last c) + (cursor-delete c) + ) + (equal + (list + (get-value 4 ibt) + (get-value 5 ibt) + (get-value 9 ibt) + (get-value 10 ibt) + ) + '(16 25 nil 100)) + )) + t) + (deftest indexed-delete (finishes - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (curs index3) (cursor-last curs) (cursor-delete curs)))) @@ -365,7 +496,7 @@ (deftest indexed-delete2 (finishes - (with-transaction () + (with-transaction (:store-controller *store-controller*) (with-btree-cursor (curs index3) (cursor-first curs) (cursor-next-dup curs) @@ -383,6 +514,29 @@ v))) 0 0 nil -2) + +(deftest cur-del2 + (with-transaction (:store-controller *store-controller*) + (let* ((ibt (build-indexed-btree *store-controller*)) + (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) + (with-btree-cursor (c id1) + (cursor-first c) + (cursor-next-dup c) + (cursor-delete c) + ) + (equal (list + (get-value 1 id1) ;; + (get-value 0 id1) ;; This should be 0, but is returning nil! + ) + '(1 0)) + )) + t) + + + (deftest get-both (with-btree-cursor (c indexed2) (cursor-get-both c 200 -200)) @@ -414,12 +568,15 @@ (pcursor-pkey (cursor-pfirst c)) (pcursor-pkey (cursor-pnext c)) (pcursor-pkey (cursor-pnext-nodup c)) + (pcursor-pkey (cursor-pnext-dup c)) (pcursor-pkey (cursor-pprev c)) (pcursor-pkey (cursor-pprev-nodup c)) + (pcursor-pkey (cursor-plast c)) (pcursor-pkey (cursor-pset c 300)) (pcursor-pkey (cursor-pset-range c 199.5)) + (pcursor-pkey (cursor-pget-both c 10 101)) (pcursor-pkey (cursor-pget-both-range c 11 111.4)))) @@ -429,7 +586,7 @@ (deftest newindex (finishes - (with-transaction () + (with-transaction (:store-controller *store-controller*) (setq index4 (add-index indexed2 :index-name 'crunch :key-form 'crunch :populate t)))) @@ -451,3 +608,105 @@ (pcursor-pkey (cursor-pget-both-range c 11 111.4)))) 0 2 10 11 10 9 9999 3000 2000 101 112) + + +(deftest add-get-remove + (let ((r1 '()) + (r2 '()) + (*prev-commit* *auto-commit*)) + (unwind-protect + (progn + (setq *auto-commit* t) + (add-to-root "x1" "y1") + (add-to-root "x2" "y2") + (setf r1 (get-from-root "x1")) + (setf r2 (get-from-root "x2")) + (remove-from-root "x1") + (remove-from-root "x2") + (and + (equal "y1" r1) + (equal "y2" r2) + (equal nil (get-from-root "x1")) + (equal nil (get-from-root "x2")) + ) + ) + (setq *auto-commit* *prev-commit*) + )) + t) + +(deftest add-get-remove-symbol + (let ((foo (cons nil nil)) + (bar (cons 'a 'b)) + (f1 '()) + (f2 '()) + (b1 '()) + (b2 '()) + (*prev-commit* *auto-commit*)) + (unwind-protect + (progn + (setq *auto-commit* t) + (add-to-root "my key" foo) + (add-to-root "my other key" foo) + (setf f1 (get-from-root "my key")) + (setf f2 (get-from-root "my other key")) + (add-to-root "my key" bar) + (add-to-root "my other key" bar) + (setf b1 (get-from-root "my key")) + (setf b2 (get-from-root "my other key")) + (and + (equal f1 f2) + (equal b1 b2) + (equal f1 foo) + (equal b1 bar) + )) + (setq *auto-commit* *prev-commit*) + )) + t) + +(deftest existsp + (let ((exists1 '()) + (exists2 '()) + (exists3 '()) + (key "my key") + (*prev-commit* *auto-commit*) + ) + (unwind-protect + (progn + (setq *auto-commit* t) + (remove-from-root key) + (setf exists1 + (from-root-existsp key) + ) + (add-to-root key 'a) + (setf exists2 (from-root-existsp key)) + (remove-from-root key) + (setf exists3 (from-root-existsp key)) + ) + (setq *auto-commit* *prev-commit*) + ) + (values exists1 exists2 exists3) + ) + nil t nil + ) + + +;; 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 ( +;; (index +;; (add-index ibt :index-name 'crunch :key-form 'crunch +;; :populate t)) +;; ) +;; (loop for i from 0 to 10 +;; do +;; (setf (get-value i ibt) (* i i))) +;; ;; Now create a cursor, advance and put... +;; (let ((c (make-cursor ibt))) +;; (cursor-next c) +;; (cursor-next c) +;; (cursor-put c 4 :key 10) +;; (equal (get-value 10 ibt) 4))) +;; ) +;; t) Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.6 elephant/tests/testserializer.lisp:1.7 --- elephant/tests/testserializer.lisp:1.6 Thu Feb 24 02:06:05 2005 +++ elephant/tests/testserializer.lisp Wed Nov 23 18:51:59 2005 @@ -2,19 +2,19 @@ (defun in-out-value (var) (with-buffer-streams (out-buf) - (deserialize (serialize var out-buf)))) + (deserialize (serialize var out-buf) :sc *store-controller*))) (defun in-out-eq (var) (with-buffer-streams (out-buf) - (eq var (deserialize (serialize var out-buf))))) + (eq var (deserialize (serialize var out-buf) :sc *store-controller*)))) (defun in-out-equal (var) (with-buffer-streams (out-buf) - (equal var (deserialize (serialize var out-buf))))) + (equal var (deserialize (serialize var out-buf) :sc *store-controller*)))) (defun in-out-equalp (var) (with-buffer-streams (out-buf) - (equalp var (deserialize (serialize var out-buf))))) + (equalp var (deserialize (serialize var out-buf) :sc *store-controller*)))) (deftest fixnums (are-not-null @@ -33,7 +33,7 @@ (typep (in-out-value most-positive-fixnum) 'fixnum) (typep (in-out-value most-negative-fixnum) 'fixnum)) t t t t t) - + (deftest bignums (are-not-null (in-out-equal 10000000000) @@ -114,7 +114,7 @@ (defun in-out-uninterned-equal (var) (with-buffer-streams (out-buf) (serialize var out-buf) - (let ((new (deserialize (serialize var out-buf)))) + (let ((new (deserialize (serialize var out-buf) :sc *store-controller*))) (and (equal (symbol-name new) (symbol-name var)) (equal (symbol-package new) (symbol-package var)))))) @@ -299,7 +299,7 @@ (defun in-out-deep-equalp (var) (with-buffer-streams (out-buf) - (deep-equalp var (deserialize (serialize var out-buf))))) + (deep-equalp var (deserialize (serialize var out-buf) :sc *store-controller*)))) (deftest objects (are-not-null @@ -315,8 +315,8 @@ (l1 (make-list 100)) (h (make-hash-table :test 'equal)) (g (make-array '(2 3 4))) - (f (make-instance 'foo)) - (b (make-instance 'bar))) + (f (make-instance 'foo )) + (b (make-instance 'bar ))) (setf (car c1) c1) (setf (cdr c1) c1) (setf (car c2) c1) @@ -351,11 +351,16 @@ (deftest persistent (let* ((*auto-commit* t) - (f1 (make-instance 'pfoo)) - (f2 (make-instance 'pfoo :slot1 "this is a string")) - (b1 (make-instance 'pbar :slot2 "another string")) - (b2 (make-instance 'pbar)) - (h (make-instance 'btree))) + (f1 (make-instance 'pfoo :sc *store-controller*)) + (f2 (make-instance 'pfoo :slot1 "this is a string" :sc *store-controller*)) + (b1 (make-instance 'pbar :slot2 "another string" :sc *store-controller*)) + (b2 (make-instance 'pbar :sc *store-controller*)) + +;; Note, this as will will have to be split on clas,s if we we want to +;; 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*))) (are-not-null (in-out-eq f1) (in-out-eq f2) @@ -368,4 +373,7 @@ (eq f1 (slot1 f1))) (progn (setf (get-value f2 h) f2) (eq (get-value f2 h) f2)))) - t t t t t t t t) + t t t t t t t t) + + +

1 0

[elephant-cvs] CVS update: elephant/src/RUNTEST.lisp elephant/src/bdb-enable.lisp elephant/src/libmemutil.c elephant/src/libutil.c elephant/src/sql-collections.lisp elephant/src/sql-controller.lisp elephant/src/sql-tutorial.lisp elephant/src/classes.lisp elephant/src/collections.lisp elephant/src/controller.lisp elephant/src/elephant.lisp elephant/src/libsleepycat.c elephant/src/metaclasses.lisp elephant/src/serializer.lisp elephant/src/sleepycat.lisp elephant/src/utils.lisp
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv30677/src Modified Files: classes.lisp collections.lisp controller.lisp elephant.lisp libsleepycat.c metaclasses.lisp serializer.lisp sleepycat.lisp utils.lisp Added Files: RUNTEST.lisp bdb-enable.lisp libmemutil.c libutil.c sql-collections.lisp sql-controller.lisp sql-tutorial.lisp Log Message: This is the big merger from the SQL-BACK-END branch. Date: Wed Nov 23 18:51:41 2005 Author: rread Index: elephant/src/RUNTEST.lisp diff -u /dev/null elephant/src/RUNTEST.lisp:1.2 --- /dev/null Wed Nov 23 18:51:41 2005 +++ elephant/src/RUNTEST.lisp Wed Nov 23 18:51:37 2005 @@ -0,0 +1,44 @@ +(asdf:operate 'asdf:load-op :elephant) +(asdf:operate 'asdf:load-op :ele-clsql) +(asdf:oos 'asdf:load-op :clsql-postgresql-socket) +(asdf:operate 'asdf:load-op :ele-bdb) +(asdf:operate 'asdf:load-op :elephant-tests) + +(asdf:operate 'asdf:load-op :ele-sqlite3) + + +(in-package "ELEPHANT-TESTS") +(do-all-tests) +(do-all-tests-spec *testpg-path*) +(do-migrate-test-spec *testpg-path*) +(do-all-tests-spec *testdb-path*) +(do-all-tests-spec *testsqlite3-path*) + +;; The primary and secondary test-paths are +;; use for the migration tests. +(setq *test-path-primary* *testpg-path*) +(setq *test-path-primary* *testsqlite3-path*) +(setq *test-path-secondary* *testdb-path*) +(do-all-tests-spec *test-path-primary*) + + +(use-package :sb-profile) + +(profile "CLSQL") +(profile "POSTGRESQL-SOCKET") +(profile "ELEPHANT") + +(use-package "SB-PROFILE") + +(open-store *testpg-path*) +(open-store *testdb-path*) +(add-to-root "x1" "y1") +(get-from-root "x1") + + +(add-to-root "x2" '(a 4 "spud")) +(get-from-root "x2") + + + + Index: elephant/src/bdb-enable.lisp diff -u /dev/null elephant/src/bdb-enable.lisp:1.2 --- /dev/null Wed Nov 23 18:51:42 2005 +++ elephant/src/bdb-enable.lisp Wed Nov 23 18:51:37 2005 @@ -0,0 +1,107 @@ +(in-package "SLEEPYCAT") + +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; controller.lisp -- Lisp interface to a Berkeley DB store +;;; +;;; 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 +;;; + + +#+cmu +(eval-when (:compile-toplevel) + (proclaim '(optimize (ext:inhibit-warnings 3)))) + +(eval-when (:compile-toplevel :load-toplevel) + ;; UFFI + ;;(asdf:operate 'asdf:load-op :uffi) + + ;; DSO loading - Edit these for your system! + + ;; Under linux you may need to load some kind of pthread + ;; library. I can't figure out which is the right one. + ;; This one worked for me. There are known issues with + ;; Red Hat and Berkeley DB, search google. + #+linux + (unless + (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") + (error "Couldn't load libpthread!")) + + (unless + (uffi:load-foreign-library + (if (find-package 'asdf) + (merge-pathnames + #p"libmemutil.so" + (asdf:component-pathname (asdf:find-system 'elephant))) + "/usr/local/share/common-lisp/elephant-0.3/libmemutil.so") + :module "libmemutil") + (error "Couldn't load libmemutil.so!")) + + +;; This code has now been moved to the small, asdf-loadable system +;; called "bdb-enable". Do : (asdf:operate 'asdf:load-op :ele-bdb) +;; to enable the use of BerkeleyDB as a back store. + (unless + (uffi:load-foreign-library + ;; Sleepycat: this works on linux + #+linux +;; "/db/ben/lisp/db43/lib/libdb.so" + "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" + ;; this works on FreeBSD + #+(and (or bsd freebsd) (not darwin)) + "/usr/local/lib/db43/libdb.so" + #+darwin + ;; for Fink (OS X) -- but I will assume Linux more common... +;; "/sw/lib/libdb-4.3.dylib" + ;; a possible manual install + "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib" + :module "sleepycat") + (error "Couldn't load libdb (Sleepycat)!")) + + ;; Libsleepycat.so: edit this + (unless + (uffi:load-foreign-library + (if (find-package 'asdf) + (merge-pathnames + #p"libsleepycat.so" + (asdf:component-pathname (asdf:find-system 'elephant))) + "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.so") + :module "libsleepycat") + (error "Couldn't load libsleepycat!")) + +) Index: elephant/src/libmemutil.c diff -u /dev/null elephant/src/libmemutil.c:1.2 --- /dev/null Wed Nov 23 18:51:45 2005 +++ elephant/src/libmemutil.c Wed Nov 23 18:51:37 2005 @@ -0,0 +1,111 @@ +/* +;;; +;;; 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); +} + Index: elephant/src/libutil.c diff -u /dev/null elephant/src/libutil.c:1.2 --- /dev/null Wed Nov 23 18:51:45 2005 +++ elephant/src/libutil.c Wed Nov 23 18:51:37 2005 @@ -0,0 +1,111 @@ +/* +;;; +;;; 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); +} + Index: elephant/src/sql-collections.lisp diff -u /dev/null elephant/src/sql-collections.lisp:1.2 --- /dev/null Wed Nov 23 18:51:46 2005 +++ elephant/src/sql-collections.lisp Wed Nov 23 18:51:37 2005 @@ -0,0 +1,640 @@ +;;; -*- 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 +;;; +;;; 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 +;;; + +(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 (check-con (:dbcn-spc-pst 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 (check-con (:dbcn-spc-pst 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 (check-con (:dbcn-spc-pst (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 (check-con (:dbcn-spc-pst (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 + (do ((vs + (multiple-value-list (cursor-set cursor key)) + (multiple-value-list (cursor-next cursor)))) + ((or (null (car vs)) ;; We ran off the end.. + (not (equal key (cadr vs))) ;; We ran out of values matching this key.. + (equal v (caddr vs))) ;; we found what we are loodking for! +;; our return condition... + (if (equal v (caddr vs)) + (cursor-current-x cursor :returnpk t) + (cursor-un-init cursor :returnpk t)) + ) + ;; Here's a body that's nice for debugging... + ) +;; If we don't get a value, we have to un-init this cursor... + (cursor-un-init cursor :returnpk t)))) + +(defmethod cursor-pget-both-range ((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.. + (do ((vs + (append (multiple-value-list (cursor-set cursor key)) (list pkey)) + (multiple-value-list (cursor-next-x cursor :returnpk t)))) + ((or (null (car vs)) ;; We ran off the end.. + (not (equal key (cadr vs))) ;; We ran out of values matching this key.. + (equal pkey (caddr vs)) ;; we found what we are loodking for! + (my-generic-less-than ;; we went beond the pkey + pkey + (cadddr vs) + ) + ) + ;; our return condition... + (if (or (equal pkey (caddr vs)) + (my-generic-less-than ;; we went beond the pkey + pkey + (cadddr vs) + )) + (cursor-current-x cursor :returnpk t) + (cursor-un-init cursor :returnpk t)) + ) + )) + + +(defmethod cursor-delete ((cursor sql-secondary-cursor)) + "Delete by cursor: deletes ALL secondary indices." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (multiple-value-bind + (m k v p) + (cursor-current-x cursor :returnpk t) + (declare (ignore m k v)) + (remove-kv p (primary (cursor-btree cursor))) + (let ((ck (:sql-crsr-ck cursor)) + (dp (:dp-nmbr cursor))) + + (cursor-next cursor) +;; Now that we point to the old slot, remove the old slot from the array... + (setf (:sql-crsr-ks cursor) + (remove-indexed-element-and-adjust + ck + (:sql-crsr-ks cursor))) + ;; now move us back to where we were + (cursor-prev cursor) + )) + (error "Can't delete with uninitialized cursor!"))) + +(defmethod cursor-get-both ((cursor sql-secondary-cursor) key value) + "cursor-get-both not implemented for secondary indices. +Use cursor-pget-both." + (declare (ignore cursor key value)) + (error "cursor-get-both not implemented on secondary +indices. Use cursor-pget-both.")) + +(defmethod cursor-get-both-range ((cursor sql-secondary-cursor) key value) + "cursor-get-both-range not implemented for secondary indices. +Use cursor-pget-both-range." + (declare (ignore cursor key value)) + (error "cursor-get-both-range not implemented on secondary indices. Use cursor-pget-both-range.")) + +(defmethod cursor-put ((cursor sql-secondary-cursor) value &rest rest) + "Puts are forbidden on secondary indices. Try adding to +the primary." + (declare (ignore rest value cursor)) + (error "Puts are forbidden on secondary indices. Try adding to the primary.")) + + +(defmethod cursor-first ((cursor sql-secondary-cursor)) + (cursor-first-x cursor) + ) + +(defmethod cursor-first-x ((cursor sql-secondary-cursor) &key (returnpk nil)) + (declare (optimize (speed 3))) + (setf (:dp-nmbr cursor) 0) + (cursor-init cursor) + (has-key-value-scnd cursor :returnpk returnpk) + ) + +(defmethod cursor-next ((cursor sql-secondary-cursor)) + (cursor-next-x cursor) +) + +(defmethod cursor-next-x ((cursor sql-secondary-cursor) &key (returnpk nil)) + (if (cursor-initialized-p cursor) + (progn + (let ((cur-pk (get-current-key cursor))) + (incf (:sql-crsr-ck cursor)) + (if (equal cur-pk (get-current-key cursor)) + (incf (:dp-nmbr cursor)) + (setf (:dp-nmbr cursor) 0)) + (has-key-value-scnd cursor :returnpk returnpk))) + (cursor-first-x cursor :returnpk returnpk))) + +(defmethod cursor-prev ((cursor sql-secondary-cursor)) + (cursor-prev-x cursor) +) +(defmethod cursor-prev-x ((cursor sql-secondary-cursor) &key (returnpk nil)) + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (progn + (let ((cur-pk (get-current-key cursor))) + (decf (:sql-crsr-ck cursor)) + (if (equal cur-pk (get-current-key cursor)) + (decf (:dp-nmbr cursor)) + (setf (:dp-nmbr cursor) + (sql-get-from-clcn-cnt (cursor-oid cursor) + (get-current-key cursor) + (controller-db (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + + )))) + (has-key-value-scnd cursor :returnpk returnpk)) + (cursor-last-x cursor :returnpk returnpk))) + +(defmethod cursor-next-dup ((cursor sql-secondary-cursor)) + (cursor-next-dup-x cursor) +) + +(defmethod cursor-pnext-dup ((cursor sql-secondary-cursor)) + (cursor-next-dup-x cursor :returnpk t) +) + +(defmethod cursor-next-dup-x ((cursor sql-secondary-cursor) &key (returnpk nil)) + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (let* ((cur-pk (aref (:sql-crsr-ks cursor) + (:sql-crsr-ck cursor))) + (nxt-pk (aref (:sql-crsr-ks cursor) + (+ 1 (:sql-crsr-ck cursor)))) + ) + (if (equal cur-pk nxt-pk) + (progn + (incf (:dp-nmbr cursor)) + (incf (:sql-crsr-ck cursor)) + (has-key-value-scnd cursor :returnpk returnpk)) + (progn + (setf (:dp-nmbr cursor) 0) + (cursor-un-init cursor :returnpk returnpk) + ))))) + +(defmethod cursor-next-nodup ((cursor sql-secondary-cursor)) + (cursor-next-nodup-x cursor) +) +(defmethod cursor-next-nodup-x ((cursor sql-secondary-cursor) &key (returnpk nil)) + (if (cursor-initialized-p cursor) + (let ((n + (do ((i (:sql-crsr-ck cursor) (1+ i))) + ((not (equal (aref (:sql-crsr-ks cursor) i) + (aref (:sql-crsr-ks cursor) (+ 1 i)))) (+ 1 i))))) + (setf (:sql-crsr-ck cursor) n) + (setf (:dp-nmbr cursor) 0) + (has-key-value-scnd cursor :returnpk returnpk)) + (cursor-first-x cursor :returnpk returnpk) + )) + +(defmethod cursor-last ((cursor sql-secondary-cursor)) + (cursor-last-x cursor) +) +(defmethod cursor-last-x ((cursor sql-secondary-cursor) &key (returnpk nil)) + (unless (cursor-initialized-p cursor) + (cursor-init cursor)) + (setf (:sql-crsr-ck cursor) + (- (length (:sql-crsr-ks cursor)) 1)) + (setf (:dp-nmbr cursor) + (- (sql-get-from-clcn-cnt + (cursor-oid cursor) + (get-current-key cursor) + (controller-db (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + ) + 1)) + (assert (>= (:dp-nmbr cursor) 0)) + (setf (cursor-initialized-p cursor) t) + (has-key-value-scnd cursor :returnpk returnpk) +) + + + +(defmethod cursor-prev-nodup ((cursor sql-secondary-cursor)) + (cursor-prev-nodup-x cursor) +) +(defmethod cursor-prev-nodup-x ((cursor sql-secondary-cursor) &key (returnpk nil)) + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (progn + (setf (:sql-crsr-ck cursor) (- (:sql-crsr-ck cursor) (+ 1 (:dp-nmbr cursor)))) + (setf (:dp-nmbr cursor) + (- (sql-get-from-clcn-cnt (cursor-oid cursor) + (get-current-key cursor) + (controller-db (check-con (:dbcn-spc-pst (cursor-btree cursor)))) +) 1)) + (has-key-value-scnd cursor :returnpk returnpk)) + (cursor-last-x cursor :returnpk returnpk))) + + +(defmethod cursor-pnext-nodup ((cursor sql-secondary-cursor)) + (cursor-next-nodup-x cursor :returnpk t)) + +(defmethod cursor-pprev-nodup ((cursor sql-secondary-cursor)) + (cursor-prev-nodup-x cursor :returnpk t)) Index: elephant/src/sql-controller.lisp diff -u /dev/null elephant/src/sql-controller.lisp:1.2 --- /dev/null Wed Nov 23 18:51:46 2005 +++ elephant/src/sql-controller.lisp Wed Nov 23 18:51:38 2005 @@ -0,0 +1,650 @@ +;;; -*- 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 +;;; +;;; 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 +;;; + +(in-package "ELEPHANT") + +;;; other clsql packages would have to be added for +;;; non-postgresql databases, see the CL-SQL documentation +(eval-when ( :compile-toplevel :load-toplevel) + (asdf:oos 'asdf:load-op :clsql) + +;; Probably must be customized ... see documentation on installin postgres. + (defvar *clsql-foreign-lib-path* "/usr/lib") + (clsql:push-library-path *clsql-foreign-lib-path*) + (clsql:push-library-path *elephant-lib-path*) + +;; (asdf:oos 'asdf:load-op :clsql-postgresql-socket) + ) + +(defmacro with-transaction-sql ((&key + (store-controller-sql '*store-controller*)) + &body body) + "Execute a body with a transaction in place. On success, +the transaction is committed. Otherwise, the transaction is +aborted. If the body deadlocks, the body is re-executed in +a new transaction, retrying a fixed number of iterations. +*auto-commit* is false for the body of the transaction." + `(if (typep ,store-controller-sql 'elephant::sql-store-controller) + (if (clsql::in-transaction-p + :database + (controller-db ,store-controller-sql)) + (progn + ,@body) + (prog2 + (clsql::set-autocommit nil) + (clsql::with-transaction + (:database + (controller-db ,store-controller-sql)) + ,@body) + (clsql::set-autocommit t) + )))) + +(defclass sql-store-controller (store-controller) + ((dbonnection-spec :type list :accessor :dbcn-spc :initarg :dbconnection-spec + ;; for postgres, this is host, db, user, password + ;; If you can't get the lisp system to connect with + ;; this default information, make sure you can connect + ;; to the database called "test" under the user postgress + ;; with the psql console first. Then study the authorization + ;; and configuration files. + :initform '("localhost.localdomain" "test" "postgres" "") + ) + ) + (:documentation "Class of objects responsible for the +book-keeping of holding DB handles, the cache, table +creation, counters, locks, the root (for garbage collection,) +et cetera. This is the Postgresql-specific subclass of store-controller.") + ) + +(defmethod build-btree ((sc sql-store-controller)) + (make-sql-btree sc) + ) + +(defmethod get-transaction-macro-symbol ((sc sql-store-controller)) + 'with-transaction-sql + ) + + +(defun sql-test-and-construct (spec) + (if (sql-store-spec-p spec) + (open-store-sql spec) + nil) + ) + +(eval-when ( :load-toplevel) + (register-strategy 'sql-test-and-construct) + ) + +(defmacro with-open-store-sql ((spec) &body body) + "Executes the body with an open controller, +unconditionally closing the controller on exit." + `(let ((*store-controller* + (make-instance 'sql-store-controller :dbconnection-spec ,spec))) + (declare (special *store-controller*)) + (open-controller *store-controller*) + (unwind-protect + (progn ,@body) + (close-controller *store-controller*)))) + +(defun open-store-sql (spec &key (recover nil) + (recover-fatal nil) (thread t)) + "Conveniently open a store controller." + (setq *store-controller* + (if (sql-store-spec-p spec) + (make-instance 'sql-store-controller :dbconnection-spec spec) + (error (format nil "uninterpretable path/spec specifier: ~A" spec))) + ) + (open-controller *store-controller* :recover recover + :recover-fatal recover-fatal :thread thread) + ) + +;; When you build one of these, you have to put in the connection spec. +(defclass sql-btree (btree) + ( + ) + (:documentation "A SQL implementation of a BTree")) + +(defmethod get-value (key (bt sql-btree)) + (let* ((sc (check-con (:dbcn-spc-pst bt))) + (con (controller-db sc))) + (sql-get-from-clcn (oid bt) key sc con))) + + +(defmethod existsp (key (bt sql-btree)) + (let* ((sc (check-con (:dbcn-spc-pst bt))) + (con (controller-db sc))) + (sql-from-clcn-existsp (oid bt) key con) + ) + ) + +(defmethod (setf get-value) (value key (bt sql-btree)) + (let* ((sc (check-con (:dbcn-spc-pst bt))) + (con (controller-db sc))) + (sql-add-to-clcn (oid bt) key value sc con) + ) + ) +(defmethod remove-kv (key (bt sql-btree)) + (let* ((sc (check-con (:dbcn-spc-pst bt))) + (con (controller-db sc))) + (sql-remove-one-from-clcn (oid bt) + key + sc + con)) + ) + + +;; Because these things are transient, I can't move them +;; directly into the class above. I am not sure how best to +;; handle this problem. +(defclass sql-indexed-btree (indexed-btree sql-btree ) + ( + (indices :accessor indices :initform (make-hash-table) + ) + (indices-cache :accessor indices-cache :initform (make-hash-table) + :transient t) + ) + (:metaclass persistent-metaclass) + (:documentation "A SQL-based BTree that supports secondary indices.")) + +(defmethod build-indexed-btree ((sc sql-store-controller)) + (let ((bt (make-instance 'sql-indexed-btree :sc sc))) + (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) + bt + )) + +(defmethod build-btree-index ((sc sql-store-controller) &key primary key-form) + (let ((bt (make-instance 'sql-btree-index :primary primary :key-form key-form :sc sc))) + (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) + bt + )) + + +;; I need some way to get to the store-controller here... +;; I could be the store controller in the hash table, that's probably +;; the simplest thing to do.. +(defmethod add-index ((bt sql-indexed-btree) &key index-name key-form populate) + (let* ((sc (check-con (:dbcn-spc-pst bt))) + (con (controller-db sc))) + (if (and (not (null index-name)) + (symbolp index-name) (or (symbolp key-form) (listp key-form))) + (let ((indices (indices bt)) + (index (make-instance 'sql-btree-index :primary bt + :key-form key-form + :sc sc))) + (setf (gethash index-name (indices-cache bt)) index) + (setf (gethash index-name indices) index) + (setf (indices bt) indices) + (when populate + (let ((key-fn (key-fn index)) + ) + (with-transaction-sql (:store-controller-sql sc) + (map-btree + #'(lambda (k v) + (multiple-value-bind (index? secondary-key) + (funcall key-fn index k v) +;; This is a slow, DB cycle intensive operation. It could chunked somehow, +;; I think, probably making it 10 times faster. + (when index? + (sql-add-to-clcn (oid index) + secondary-key + k + sc con :insert-only t) + ))) + bt)))) + index) + (error "Invalid index initargs!")))) + + + +(defmethod (setf get-value) (value key (bt sql-indexed-btree)) + "Set a key / value pair, and update secondary indices." + (let* ((sc (check-con (:dbcn-spc-pst bt))) + (con (controller-db sc)) + (indices (indices-cache bt))) + (with-transaction-sql (:store-controller-sql sc) + (maphash + #'(lambda (k index) + (multiple-value-bind (index? secondary-key) + (funcall (key-fn index) index key value) + (when index? + (sql-add-to-clcn (oid index) + secondary-key + key + sc con :insert-only t) + ))) + indices) + ;; Now we place the actual value + (sql-add-to-clcn (oid bt) key value sc con) + ) + value)) + +(defmethod remove-kv (key (bt sql-indexed-btree)) + "Remove a key / value pair, and update secondary indices." + (declare (optimize (speed 3))) + (let* ( + (sc (check-con (:dbcn-spc-pst bt))) + (con (controller-db sc))) + (with-transaction-sql (:store-controller-sql sc) + (let ((value (get-value key bt))) + (when value + (let ((indices (indices-cache bt))) + (maphash + #'(lambda (k index) + (multiple-value-bind (index? secondary-key) + (funcall (key-fn index) index key value) + (when index? + ;; This function will in fact remove all of the + ;; duplicate keys; but this is not how the BDB system works. + ;; It appears to me, based on the behavior of tests, that + ;; this should remove the FIRST row that match not all. + (sql-remove-key-and-value-from-clcn (oid index) + secondary-key + key + con) + ;; And furthermore, we have to remove the index entry + ;; (remove-kv secondary-key index) + ))) + indices) + ;; Now we place the actual value + (sql-remove-from-clcn (oid bt) key sc con)) + ) + value)))) + + + +(defclass sql-btree-index (btree-index sql-btree) + () + (:metaclass persistent-metaclass) + (:documentation "A SQL-based BTree supports secondary indices.")) + + +(clsql::locally-enable-sql-reader-syntax) + +;; Check that the table exists and is in proper form. +;; If it is not in proper form, signal an error, no +;; way to recover from that automatically. If it +;; does not exist, return nil so we can create it later! + +;; These functions are probably not cross-database portable... +(defun keyvalue-table-exists (con) + ;; we want to use ":owner :all" because we don't really care who created + ;; the table, as long as we have the rights we need! + (clsql:table-exists-p [keyvalue] :database con :owner :all) + ) + +;; This is just an initial version; it is possible that +;; we might someday wish to use blobs instead; certainly, I am +;; storing blobs now in the Berkeley-db and we meed to make sure +;; we are properly testing that. However, blobs are awkward to +;; handle, so I am going to do this first... +(defun create-keyvalue-table (con) + ;; the "serial" specifiation here does not seem to work, ( + ;; apparently not supported by clsql, so I have to execute these + ;; commands specifically. This may be a database-dependent way of doing + ;; things, but sequences in general are NOT standardized across RDBMS. + ;; I prefer sequence to support the "get-next-oid" command, but there + ;; ARE other ways of doing it that could make this more portable. + ;; (execute-command create :database con) + ;; (execute-command idx-id :database con) + ;; (execute-command idx-key :database con) + ;; Danger: Rather than use 'serial as a type, CLSQL appears to support + ;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem! + + ;; ALL OF THIS needs to be inside a transaction. + (clsql::create-table [keyvalue] + '( + ([clctn_id] integer :not-null) + ([key] text :not-null) + ([value] text) + ) :database con + ) + ;; :constraints '("PRIMARY KEY (clctn_id key)" + ;; "UNIQUE (clctn_id,key)") + + ;; apparently in postgres this is failing pretty awfully because + ;; sequence-exists-p return nil and then we get an error that the sequence exists! + ;; (unless (sequence-exists-p [persistent_seq]) + (clsql::create-sequence [persistent_seq] + :database con) + ;;) + ;; (unless (index-exists-p [idx_clctn_id]) + (clsql::create-index [idx_clctn_id] :on [keyvalue] + :attributes '([clctn_id]) + :database con) + ;; ) + ;; (unless (index-exists-p [idx_key]) + (clsql::create-index [idx_key] :on [keyvalue] + :attributes '([key]) + :database con) + ;;) + ;; This is actually unique + ;; (unless (index-exists-p [idx_both]) + (clsql:create-index [idx_both] :on [keyvalue] + :attributes '([clctn_id] [key]) + :database con) + ;;) + ) + + +(defmethod open-controller ((sc sql-store-controller) + ;; At present these three have no meaning + &key + (recover nil) + (recover-fatal nil) + (thread t)) + (the sql-store-controller + (let* ((dbtype (car (:dbcn-spc sc))) + (con (clsql:connect (cdr (:dbcn-spc sc)) +;; WARNING: This line of code forces us to use postgresql. +;; If this were parametrized upwards we could concievably try +;; other backends. + :database-type dbtype +;; DNK :postgresql +;; :database-type :postgresql + :if-exists :old))) + (setf (gethash (:dbcn-spc sc) *dbconnection-spec*) sc) + (setf (slot-value sc 'db) con) + ;; Now we should make sure that the KEYVALUE table exists, and, if + ;; it does not, we need to create it.. + ;; This kind of thing is typically database-specific, but at least we + ;; can put it in a function.... + (unless (keyvalue-table-exists con) + (create-keyvalue-table con)) + (setf (slot-value sc 'root) (make-sql-btree sc)) + ;; Actaully, it would seem here that we must further set the oid + ;; of the root tree to 0 to ensure that we read the correct thing + ;; when we next opent he controller... + (setf (oid (slot-value sc 'root)) 0) + sc) + ) + ) + +(defun make-sql-btree (sc) + (let ((bt (make-instance 'sql-btree :sc sc))) + (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) + bt) + ) + +(defmethod close-controller ((sc sql-store-controller)) + (when (slot-value sc 'db) + ;; close the conneciton + ;; (actually clsql has pooling and other complications, I am not sure + ;; that this is complete.) + (clsql:disconnect :database (controller-db sc)) + (setf (slot-value sc 'root) nil) + )) + + +;; Because this is part of the public +;; interface that I'm tied to, it has to accept a store-controller... +(defmethod next-oid ((sc sql-store-controller )) + (let ((con (controller-db sc))) + (clsql:sequence-next [persistent_seq] + :database con)) + ) + + +;; if add-to-root is a method, then we can make it class dependent... +;; otherwise we have to change the original code. There is +;; almost no way to implement this without either changing the existing +;; file. If we can introduce a layer of class indirectio there, then +;; we can control things properly. In the meantime, I will implement +;; a proper method myself, but I will give it a name so it doesn't +;; conflict with 'add-to-root. 'add-to-root can remain a convenience symbol, +;; that will end up calling this routine! +(defmethod sql-add-to-root (key value (pgsc sql-store-controller ) con) + (sql-add-to-clcn 0 key value pgsc con) + ) +;;(defmethod sql-add-to-root (key value dbcon) +;; (sql-add-to-clcn 0 key value sc dbcon) +;; ) + +(defmethod sql-add-to-clcn ((clcn integer) key value sc con + &key (insert-only nil)) + (let ( + (vbs + (serialize-to-base64-string value)) + (kbs + (serialize-to-base64-string key)) + ) + (if (and (not insert-only) (sql-from-clcn-existsp clcn key con)) + (clsql::update-records [keyvalue] + :av-pairs `((key ,kbs) + (clctn_id ,clcn) + (value ,vbs)) + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con) + (clsql::insert-records :into [keyvalue] + :attributes '(key clctn_id value) + :values (list kbs clcn vbs) + :database con + )) + ) + value + ) + + + +(defmethod sql-get-from-root (key sc con) + (sql-get-from-clcn 0 key sc con)) + +;; This is a major difference betwen SQL and BDB: +;; BDB plans to give you one value and let you iterate, but +;; SQL by nature returns a set of values (when the keys aren't unique.) +;; +;; I serious problem here is what to do if the things aren't unique. +;; According to the Elepahnt documentation, you should get one value +;; (not clear which one, the "first" probably, and then use a +;; cursor to iterate over duplicates. +;; So although it is moderately clear how the cursor is supposed to +;; work, I'm not sure how I'm supposed to know what value should be +;; returend by this non-cursor function. +;; I suspect if I return the value that has the lowest OID, that will +;; match the behavior of the sleepycat function.... +;; To do that I have to read in all of the values and deserialized them +;; This could be a good reason to keep the oids out, and separte, in +;; a separate column. +(defmethod sql-get-from-clcn ((clcn integer) key sc con) + (sql-get-from-clcn-nth clcn key sc con 0) + ) +(defmethod sql-get-from-clcn-nth ((clcn integer) key sc con (n integer)) + (let* ( + (kbs + (serialize-to-base64-string key)) + (tuples + (clsql::select [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con + ))) + ;; Get the lowest value by sorting and taking the first value; + ;; this isn't a very good way to do things... + ;; Note also that this will be extremely inefficient if + ;; you have for example, a boolean index function. + ;; I could parametrize this routine to take an "nth" + ;; parameter. But there is almost no way to implement + ;; that efficiently without changing the database structure; + ;; but that's OK, I could add a column to support that + ;; relatively easily later on. + (if (< n (length tuples)) + (values (nth n (sort + (mapcar + #'(lambda (x) + (deserialize-from-base64-string (car x) :sc sc)) + tuples) + #'my-generic-less-than)) + t) + (values nil nil)))) + +(defmethod sql-get-from-clcn-cnt ((clcn integer) key con) + (let* ( + (kbs (serialize-to-base64-string key)) + (tuples + (clsql::select [count [value]] + :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con + ))) + (caar tuples))) + +(defmethod sql-dump-clcn ((clcn integer) sc con) + (let* ( + (tuples + (clsql::select [key] [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn]] + :database con + ))) + (mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string :sc sc)) x)) + tuples))) + +(defmethod sql-from-root-existsp (key con) + (sql-from-clcn-existsp 0 key con) + ) + +(defmethod sql-from-clcn-existsp ((clcn integer) key con) + (let* ( + (kbs (with-buffer-streams (out-buf) + (serialize-to-base64-string key)) + ) + (tuples + (clsql::select [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con + ))) + (if tuples + t + nil) + )) + +(defmethod sql-remove-from-root (key sc con) + (sql-remove-from-clcn 0 key sc con) + ) + +(defmethod sql-remove-from-clcn ((clcn integer) key sc con) + (let ( + (kbs (serialize-to-base64-string key)) + ) + (clsql::delete-records :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con + )) + ) +(defmethod sql-remove-one-from-clcn ((clcn integer) key sc con) + (let* ( + (kbs (serialize-to-base64-string key)) + ;; We want to remove the FIRST value, based on our ordering. + ;; have little choice but to read everything in and delete based on + ;; the "value field". + (tuples + (clsql::select [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con + ))) + (if (< (length tuples) 1) + nil + (let ((to-remove + (serialize-to-base64-string + (nth 0 (sort + (mapcar + #'(lambda (x) + (deserialize-from-base64-string (car x) :sc sc)) + tuples) + #'my-generic-less-than))))) + (clsql::delete-records :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs] + [= [value] to-remove]] + :database con + ) + ) + ) + )) + +(defmethod sql-remove-key-and-value-from-clcn ((clcn integer) key value con) + (let* ( + (kbs (serialize-to-base64-string key)) + (vbs (serialize-to-base64-string value))) + (clsql::delete-records :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs] + [= [value] vbs]] + :database con + ) + )) + +(clsql::restore-sql-reader-syntax-state) + + + + +(defmethod persistent-slot-writer-aux ((sc sql-store-controller) new-value instance name) + (let* ((con (controller-db sc))) + (sql-add-to-root + (form-slot-key (oid instance) name) + new-value + sc con) + )) + +;; This was almost ncecessary to allow this functionality to be included +;; only if you load ele-clsql. It could also be used in bdb, and probably +;; should be, but there is some strange macro stuff there that I am afraid +;; to change, so I am implementing it only here. +(defmethod persistent-slot-reader-aux ((sc sql-store-controller) instance name) + (let* ((con (controller-db sc))) + (multiple-value-bind (v existsp) + (sql-get-from-root + (form-slot-key (oid instance) name) + sc con) + (if existsp + v + (error 'unbound-slot :instance instance :name name)))) + ) + +(defmethod persistent-slot-boundp-aux ((sc sql-store-controller) instance name) + (let* ((con (controller-db sc))) + (if (sql-from-root-existsp + (form-slot-key (oid instance) name) + con ) + t nil))) + + + Index: elephant/src/sql-tutorial.lisp diff -u /dev/null elephant/src/sql-tutorial.lisp:1.2 --- /dev/null Wed Nov 23 18:51:46 2005 +++ elephant/src/sql-tutorial.lisp Wed Nov 23 18:51:38 2005 @@ -0,0 +1,116 @@ +(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)))) + + Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.13 elephant/src/classes.lisp:1.14 --- elephant/src/classes.lisp:1.13 Thu Feb 24 02:07:52 2005 +++ elephant/src/classes.lisp Wed Nov 23 18:51:37 2005 @@ -45,13 +45,31 @@ (defmethod initialize-instance :before ((instance persistent) &rest initargs - &key from-oid) + &key from-oid + spec + ;; Putting the default use + ;; of the global variable here + ;; is very bad for testing and multi-repository + ;; use; it is, however, good for making + ;; things work exactly the way they originally did! + (sc *store-controller*)) "Sets the OID." (declare (ignore initargs)) + +;; This lines are fundamentally valuable in making sure that +;; we hvae completely specified things. +;; (if (null sc) +;; (break)) (if (not from-oid) - (setf (oid instance) (next-oid *store-controller*)) + (setf (oid instance) (next-oid sc)) (setf (oid instance) from-oid)) - (cache-instance *store-controller* instance)) + (if (not spec) + (if (not (typep sc 'bdb-store-controller)) + (setf (:dbcn-spc-pst instance) (:dbcn-spc sc)) + (setf (:dbcn-spc-pst instance) (controller-path sc)) + ) + (setf (:dbcn-spc-pst instance) spec)) + (cache-instance sc instance)) (defclass persistent-object (persistent) () @@ -141,7 +159,7 @@ (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 + (if (eq slot-names t) ; t means all slots (transient-slot-names class) (remove-if #'persistent-slot-p slot-names))) (persistent-slot-inits @@ -150,23 +168,27 @@ ;; 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)))) + 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)))))) - ;; let the implementation initialize the transient slots - (apply #'call-next-method instance transient-slot-inits initargs))))) + 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)))) + ) + ;; let the implementation initialize the transient slots + (apply #'call-next-method instance transient-slot-inits initargs)))))) (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; probably should delete discarded slots, but we'll worry about that later @@ -237,14 +259,26 @@ (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." - (declare (optimize (speed 3))) - (with-buffer-streams (key-buf) - (buffer-write-int (oid instance) key-buf) - (serialize (slot-definition-name slot-def) key-buf) - (db-delete-buffered - (controller-db *store-controller*) key-buf - :transaction *current-transaction* - :auto-commit *auto-commit*)) + (declare (optimize (speed 3)) + (ignore class)) + (if (sql-store-spec-p (:dbcn-spc-pst instance)) + (progn + (let* ((sc (check-con (:dbcn-spc-pst instance))) + (con (controller-db sc))) + (sql-remove-from-root + (form-slot-key (oid instance) (slot-definition-name slot-def)) + sc + con + ) + )) + (with-buffer-streams (key-buf) + (buffer-write-int (oid instance) key-buf) + (serialize (slot-definition-name slot-def) key-buf) + (db-delete-buffered + (controller-db (check-con (:dbcn-spc-pst instance))) key-buf + :transaction *current-transaction* + :auto-commit *auto-commit*)) + ) instance) #+allegro @@ -253,4 +287,4 @@ until (eq (slot-definition-name slot) slot-name) finally (if (typep slot 'persistent-slot-definition) (slot-makunbound-using-class class instance slot) - (call-next-method)))) \ No newline at end of file + (call-next-method)))) Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.11 elephant/src/collections.lisp:1.12 --- elephant/src/collections.lisp:1.11 Sat Sep 25 20:57:37 2004 +++ elephant/src/collections.lisp Wed Nov 23 18:51:37 2005 @@ -48,10 +48,36 @@ (:documentation "Abstract superclass of all collection types.")) ;;; btree access -(defclass btree (persistent-collection) () +(defclass btree (persistent-collection) + +;; I don't like having to put this here, as this is only used by +;; the extending class indexed-btree. But I can't figure out +;; how to make the :transient flag work on that class without +;; creating a circularity in the class presidence list... +( +) (:documentation "A hash-table like interface to a BTree, which stores things in a semi-ordered fashion.")) +(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. +(defun make-bdb-btree (sc) + (let ((bt (make-instance 'bdb-btree :sc sc))) + (setf (:dbcn-spc-pst bt) (controller-path sc)) + bt) + ) + +;; somehow these functions need to be part of our strategy, +;; or better yet methods on the store-controller. + + + (defgeneric get-value (key bt) (:documentation "Get a value from a Btree.")) @@ -61,45 +87,128 @@ (defgeneric remove-kv (key bt) (:documentation "Remove a key / value pair from a BTree.")) -(defmethod get-value (key (bt btree)) +(defmethod get-value (key (bt bdb-btree)) (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-btrees *store-controller*) + (controller-btrees + (check-con (:dbcn-spc-pst bt)) +;; *store-controller* + ) key-buf value-buf))) - (if buf (values (deserialize buf) T) + (if buf (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) T) (values nil nil))))) -(defmethod (setf get-value) (value key (bt btree)) +(defmethod existsp (key (bt bdb-btree)) + (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-btrees (check-con (:dbcn-spc-pst bt))) + key-buf value-buf))) + (if buf t + nil)))) + + +(defmethod (setf get-value) (value key (bt bdb-btree)) (declare (optimize (speed 3))) (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 *store-controller*) + (db-put-buffered (controller-btrees (check-con (:dbcn-spc-pst bt))) key-buf value-buf :auto-commit *auto-commit*) value)) -(defmethod remove-kv (key (bt btree)) +(defmethod remove-kv (key (bt bdb-btree)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) - (db-delete-buffered (controller-btrees *store-controller*) + (db-delete-buffered (controller-btrees (check-con (:dbcn-spc-pst bt))) key-buf :auto-commit *auto-commit*))) ;; Secondary indices -(defclass indexed-btree (btree) - ((indices :accessor indices :initform (make-hash-table)) + (defclass indexed-btree () + ( + ) + (:documentation "A BTree which supports 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)) + :transient t +) + ) (:metaclass persistent-metaclass) - (:documentation "A BTree which supports secondary indices.")) + (:documentation "A BDB-based BTree supports secondary indices.")) + + +(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) + ) + +(defun btree-differ (x y) + (let ((cx1 (make-cursor x)) + (cy1 (make-cursor y)) + (done nil) + (rv nil) + (mx nil) + (kx nil) + (vx nil) + (my nil) + (ky nil) + (vy nil)) + (cursor-first cx1) + (cursor-first cy1) + (do ((i 0 (1+ i))) + (done nil) + (multiple-value-bind (m k v) (cursor-current cx1) + (setf mx m) + (setf kx k) + (setf vx v)) + (multiple-value-bind (m k v) (cursor-current cy1) + (setf my m) + (setf ky k) + (setf vy v)) + (if (not (and (equal mx my) + (equal kx ky) + (equal vx vy))) + (setf rv (list mx my kx ky vx vy))) + (setf done (and (not mx) (not mx)) + ) + (cursor-next cx1) + (cursor-next cy1) + ) + (cursor-close cx1) + (cursor-close cy1) + rv + )) + (defmethod shared-initialize :after ((instance indexed-btree) slot-names &rest rest) @@ -124,39 +233,47 @@ (defgeneric remove-index (bt index-name) (:documentation "Remove a named index.")) -(defmethod add-index ((bt indexed-btree) &key index-name key-form populate) - (if (and (not (null index-name)) - (symbolp index-name) (or (symbolp key-form) (listp key-form))) - (let ((indices (indices bt)) - (index (make-instance 'btree-index :primary bt - :key-form key-form))) - (setf (gethash index-name (indices-cache bt)) index) - (setf (gethash index-name indices) index) - (setf (indices bt) indices) - (when populate - (let ((key-fn (key-fn index))) - (with-buffer-streams (primary-buf secondary-buf) - (with-transaction () - (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 *store-controller*) - secondary-buf primary-buf) - (reset-buffer-stream primary-buf) - (reset-buffer-stream secondary-buf)))) - bt))))) - index) - (error "Invalid index initargs!"))) - +(defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) + (let ((sc (check-con (:dbcn-spc-pst 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 get-index ((bt indexed-btree) index-name) (gethash index-name (indices-cache bt))) @@ -166,65 +283,75 @@ (remhash index-name indices) (setf (indices bt) indices))) -(defmethod (setf get-value) (value key (bt indexed-btree)) +(defmethod (setf get-value) (value key (bt bdb-indexed-btree)) "Set a key / value pair, and update secondary indices." - (declare (optimize (speed 3))) - (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 () - (db-put-buffered (controller-btrees *store-controller*) - 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? - (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 *store-controller*) - secondary-buf key-buf) - (reset-buffer-stream secondary-buf)))) - value)))) - -(defmethod remove-kv (key (bt indexed-btree)) - "Remove a key / value pair, and update secondary indices." - (declare (optimize (speed 3))) - (with-buffer-streams (key-buf secondary-buf) - (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (with-transaction () - (let ((value (get-value key bt))) - (when value - (let ((indices (indices-cache bt))) - (loop - for index being the hash-value of indices + (let ((sc (check-con (:dbcn-spc-pst 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? (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 - (sleepycat::db-delete-kv-buffered - (controller-indices *store-controller*) - secondary-buf key-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)))) - (db-delete-buffered (controller-btrees *store-controller*) - key-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 (check-con (:dbcn-spc-pst 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 + (sleepycat::db-delete-kv-buffered + (controller-indices (check-con (:dbcn-spc-pst bt))) + secondary-buf key-buf) + (reset-buffer-stream secondary-buf)))) + (db-delete-buffered (controller-btrees (check-con (:dbcn-spc-pst bt))) + key-buf)))))))) +;; This also needs to build the correct kind of index, and +;; be the correct kind of btree... (defclass btree-index (btree) ((primary :type indexed-btree :reader primary :initarg :primary) - (key-form :reader key-form :initarg :key-form) + (key-form :reader key-form :initarg :key-form :initform nil) (key-fn :type function :accessor key-fn :transient t)) (:metaclass persistent-metaclass) (:documentation "Secondary index to an indexed-btree.")) + +(defclass bdb-btree-index (btree-index bdb-btree ) + () + (:metaclass persistent-metaclass) + (:documentation "A BDB-based BTree supports secondary indices.")) + (defmethod shared-initialize :after ((instance btree-index) slot-names &rest rest) (declare (ignore slot-names rest)) @@ -233,16 +360,18 @@ (setf (key-fn instance) (fdefinition key-form)) (setf (key-fn instance) (compile nil key-form))))) -(defmethod get-value (key (bt btree-index)) +;; 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 *store-controller*) + (controller-indices-assoc (check-con (:dbcn-spc-pst bt))) key-buf value-buf))) - (if buf (values (deserialize buf) T) + (if buf (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) T) (values nil nil))))) (defmethod (setf get-value) (value key (bt btree-index)) @@ -260,11 +389,11 @@ (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (let ((buf (db-get-key-buffered - (controller-indices *store-controller*) + (controller-indices (check-con (:dbcn-spc-pst bt))) key-buf value-buf))) (if buf (let ((oid (buffer-read-fixnum buf))) - (values (deserialize buf) oid)) + (values (deserialize buf :sc (check-con (:dbcn-spc-pst bt))) oid)) (values nil nil))))) (defmethod remove-kv (key (bt btree-index)) @@ -275,18 +404,39 @@ ;; 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 cursor () - ((handle :accessor cursor-handle :initarg :handle) + ( (oid :accessor cursor-oid :type fixnum :initarg :oid) + +;; (intialized-p cursor) means that the cursor has +;; a legitimate position, not that any initialization +;; action has been taken. The implementors of this abstract class +;; should make sure that happens under the sheets... +;; According to my understanding, cursors are initialized +;; when you invoke an operation that sets them to something +;; (such as cursor-first), and are uninitialized if you +;; move them in such a way that they no longer have a legimtimate +;; value. (initialized-p :accessor cursor-initialized-p :type boolean :initform nil :initarg :initialized-p) (btree :accessor cursor-btree :initarg :btree)) (:documentation "A cursor for traversing (primary) BTrees.")) +(defclass bdb-cursor (cursor) + ( + (handle :accessor cursor-handle :initarg :handle) + ) + (:documentation "A cursor for traversing (primary) BDB-BTrees.")) + + (defgeneric make-cursor (bt) (:documentation "Construct a cursor for traversing BTrees.")) + (defgeneric cursor-close (cursor) (:documentation "Close the cursor. Make sure to close cursors before the @@ -352,14 +502,15 @@ "Put by cursor. Currently doesn't properly move the cursor.")) -(defmethod make-cursor ((bt btree)) +(defmethod make-cursor ((bt bdb-btree)) "Make a cursor from a btree." (declare (optimize (speed 3))) - (make-instance 'cursor + (make-instance 'bdb-cursor :btree bt - :handle (db-cursor (controller-btrees *store-controller*)) + :handle (db-cursor (controller-btrees (check-con (:dbcn-spc-pst bt)))) :oid (oid bt))) + (defmacro with-btree-cursor ((var bt) &body body) "Macro which opens a named cursor on a BTree (primary or not), evaluates the forms, then closes the cursor." @@ -375,13 +526,17 @@ (multiple-value-bind (more k v) (cursor-next curs) (unless more (return nil)) (funcall fn k v))))) +(defun dump-btree (bt) + (format t "DUMP ~A~%" bt) + (map-btree #'(lambda (k v) (format t "k ~A / v ~A~%" k v)) bt) + ) -(defmethod cursor-close ((cursor cursor)) +(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 cursor)) +(defmethod cursor-duplicate ((cursor bdb-cursor)) (declare (optimize (speed 3))) (make-instance (type-of cursor) :initialized-p (cursor-initialized-p cursor) @@ -390,7 +545,7 @@ (cursor-handle cursor) :position (cursor-initialized-p cursor)))) -(defmethod cursor-current ((cursor cursor)) +(defmethod cursor-current ((cursor bdb-cursor)) (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -399,10 +554,13 @@ :current t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key) (deserialize val))) + (values t (deserialize key + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil)))))) -(defmethod cursor-first ((cursor cursor)) +(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) @@ -411,11 +569,14 @@ 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) (deserialize val))) + (values t (deserialize key + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil))))) ;;A bit of a hack..... -(defmethod cursor-last ((cursor cursor)) +(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) @@ -429,7 +590,10 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key) (deserialize val))) + (values t (deserialize key + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil)))) (multiple-value-bind (key val) (db-cursor-move-buffered (cursor-handle cursor) key-buf @@ -437,10 +601,13 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key) (deserialize val))) + (values t (deserialize key + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil)))))) -(defmethod cursor-next ((cursor cursor)) +(defmethod cursor-next ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -448,11 +615,12 @@ (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) (deserialize val)) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))) (cursor-first cursor))) -(defmethod cursor-prev ((cursor cursor)) +(defmethod cursor-prev ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -460,11 +628,12 @@ (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) (deserialize val)) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))) (cursor-last cursor))) -(defmethod cursor-set ((cursor cursor) key) +(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) @@ -474,10 +643,10 @@ key-buf value-buf :set t) (if k (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize val))) + (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil))))) -(defmethod cursor-set-range ((cursor cursor) key) +(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) @@ -487,10 +656,11 @@ 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) (deserialize val))) + (values t (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil))))) -(defmethod cursor-get-both ((cursor cursor) key value) +(defmethod cursor-get-both ((cursor bdb-cursor) key value) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -505,7 +675,7 @@ (values t key value)) (setf (cursor-initialized-p cursor) nil))))) -(defmethod cursor-get-both-range ((cursor cursor) key value) +(defmethod cursor-get-both-range ((cursor bdb-cursor) key value) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -516,10 +686,10 @@ key-buf value-buf :get-both-range t) (if k (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize v))) + (values t key (deserialize v :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil))))) -(defmethod cursor-delete ((cursor cursor)) +(defmethod cursor-delete ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -530,11 +700,12 @@ (when (and key (= (buffer-read-int key) (cursor-oid cursor))) ;; in case of a secondary index this should delete everything ;; as specified by the BDB docs. - (remove-kv (deserialize key) (cursor-btree cursor))) + (remove-kv (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (cursor-btree cursor))) (setf (cursor-initialized-p cursor) nil))) (error "Can't delete with uninitialized cursor!"))) -(defmethod cursor-put ((cursor cursor) value &key (key nil key-specified-p)) +(defmethod cursor-put ((cursor bdb-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." @@ -548,7 +719,9 @@ value-buf :current t) (declare (ignore v)) (if (and k (= (buffer-read-int k) (cursor-oid cursor))) - (setf (get-value (deserialize k) (cursor-btree cursor)) + (setf (get-value + (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (cursor-btree cursor)) value) (setf (cursor-initialized-p cursor) nil)))) (error "Can't put with uninitialized cursor!")))) @@ -558,6 +731,9 @@ (defclass secondary-cursor (cursor) () (:documentation "Cursor for traversing secondary indices.")) +(defclass bdb-secondary-cursor (bdb-cursor) () + (:documentation "Cursor for traversing bdb secondary indices.")) + (defgeneric cursor-pcurrent (cursor) (:documentation "Returns has-tuple / secondary key / value / primary key @@ -639,16 +815,18 @@ different key.) Returns has-tuple / secondary key / value / primary key.")) -(defmethod make-cursor ((bt btree-index)) + +(defmethod make-cursor ((bt bdb-btree-index)) "Make a secondary-cursor from a secondary index." (declare (optimize (speed 3))) - (make-instance 'secondary-cursor + (make-instance 'bdb-secondary-cursor :btree bt :handle (db-cursor - (controller-indices-assoc *store-controller*)) + (controller-indices-assoc (check-con (:dbcn-spc-pst bt)))) :oid (oid bt))) -(defmethod cursor-pcurrent ((cursor secondary-cursor)) + +(defmethod cursor-pcurrent ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -658,11 +836,17 @@ :current t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key) (deserialize val) + (values t + (deserialize + key + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize + val + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) (progn (buffer-read-int pkey) (deserialize pkey)))) (setf (cursor-initialized-p cursor) nil)))))) -(defmethod cursor-pfirst ((cursor secondary-cursor)) +(defmethod cursor-pfirst ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -671,12 +855,14 @@ key-buf pkey-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) (deserialize val) + (values t +(deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) +(deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) (progn (buffer-read-int pkey) (deserialize pkey)))) (setf (cursor-initialized-p cursor) nil))))) ;;A bit of a hack..... -(defmethod cursor-plast ((cursor secondary-cursor)) +(defmethod cursor-plast ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) @@ -690,9 +876,11 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key) (deserialize val) + (values t + (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) (progn (buffer-read-int pkey) - (deserialize pkey)))) + (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))) (setf (cursor-initialized-p cursor) nil)))) (multiple-value-bind (key pkey val) (db-cursor-pmove-buffered (cursor-handle cursor) key-buf @@ -700,11 +888,12 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key) (deserialize val) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) (progn (buffer-read-int pkey) (deserialize pkey)))) (setf (cursor-initialized-p cursor) nil)))))) -(defmethod cursor-pnext ((cursor secondary-cursor)) +(defmethod cursor-pnext ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -712,12 +901,15 @@ (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf value-buf :next t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key) (deserialize val) + (values t (deserialize key + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) (progn (buffer-read-int pkey) (deserialize pkey))) (setf (cursor-initialized-p cursor) nil)))) (cursor-pfirst cursor))) -(defmethod cursor-pprev ((cursor secondary-cursor)) +(defmethod cursor-pprev ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -725,12 +917,15 @@ (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf value-buf :prev t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key) (deserialize val) + (values t (deserialize key + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val + :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) (progn (buffer-read-int pkey) (deserialize pkey))) (setf (cursor-initialized-p cursor) nil)))) (cursor-plast cursor))) -(defmethod cursor-pset ((cursor secondary-cursor) key) +(defmethod cursor-pset ((cursor bdb-secondary-cursor) key) (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -740,11 +935,11 @@ key-buf pkey-buf value-buf :set t) (if k (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize val) - (progn (buffer-read-int pkey) (deserialize pkey)))) + (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))) (setf (cursor-initialized-p cursor) nil))))) -(defmethod cursor-pset-range ((cursor secondary-cursor) key) +(defmethod cursor-pset-range ((cursor bdb-secondary-cursor) key) (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -754,11 +949,12 @@ key-buf pkey-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) (deserialize val) - (progn (buffer-read-int pkey) (deserialize pkey)))) + (values t (deserialize k :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))) (setf (cursor-initialized-p cursor) nil))))) -(defmethod cursor-pget-both ((cursor secondary-cursor) key pkey) +(defmethod cursor-pget-both ((cursor bdb-secondary-cursor) key pkey) (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (let ((primary-oid (oid (primary (cursor-btree cursor))))) @@ -772,10 +968,10 @@ (declare (ignore p)) (if k (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize val) pkey)) + (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) pkey)) (setf (cursor-initialized-p cursor) nil)))))) -(defmethod cursor-pget-both-range ((cursor secondary-cursor) key pkey) +(defmethod cursor-pget-both-range ((cursor bdb-secondary-cursor) key pkey) (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (let ((primary-oid (oid (primary (cursor-btree cursor))))) @@ -788,11 +984,11 @@ pkey-buf value-buf :get-both-range t) (if k (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize val) - (progn (buffer-read-int p) (deserialize p)))) + (values t key (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (progn (buffer-read-int p) (deserialize p :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))))) (setf (cursor-initialized-p cursor) nil)))))) -(defmethod cursor-delete ((cursor secondary-cursor)) +(defmethod cursor-delete ((cursor bdb-secondary-cursor)) "Delete by cursor: deletes ALL secondary indices." (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) @@ -804,30 +1000,31 @@ (when (and key (= (buffer-read-int key) (cursor-oid cursor)) (= (buffer-read-int pkey) (oid (primary (cursor-btree cursor))))) - (remove-kv (deserialize pkey) (primary (cursor-btree cursor)))) + (remove-kv (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (primary (cursor-btree cursor)))) (setf (cursor-initialized-p cursor) nil))) (error "Can't delete with uninitialized cursor!"))) -(defmethod cursor-get-both ((cursor secondary-cursor) key value) +(defmethod cursor-get-both ((cursor bdb-secondary-cursor) key value) "cursor-get-both not implemented for secondary indices. Use cursor-pget-both." (declare (ignore cursor key value)) (error "cursor-get-both not implemented on secondary indices. Use cursor-pget-both.")) -(defmethod cursor-get-both-range ((cursor secondary-cursor) key value) +(defmethod cursor-get-both-range ((cursor bdb-secondary-cursor) key value) "cursor-get-both-range not implemented for secondary indices. Use cursor-pget-both-range." (declare (ignore cursor key value)) (error "cursor-get-both-range not implemented on secondary indices. Use cursor-pget-both-range.")) -(defmethod cursor-put ((cursor secondary-cursor) value &rest rest) +(defmethod cursor-put ((cursor bdb-secondary-cursor) value &rest rest) "Puts are forbidden on secondary indices. Try adding to the primary." (declare (ignore rest value cursor)) (error "Puts are forbidden on secondary indices. Try adding to the primary.")) -(defmethod cursor-next-dup ((cursor secondary-cursor)) +(defmethod cursor-next-dup ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -835,10 +1032,11 @@ (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf :next-dup t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key) (deserialize val)) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))))) -(defmethod cursor-next-nodup ((cursor secondary-cursor)) +(defmethod cursor-next-nodup ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -846,11 +1044,12 @@ (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf :next-nodup t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key) (deserialize val)) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))) (cursor-first cursor))) -(defmethod cursor-prev-nodup ((cursor secondary-cursor)) +(defmethod cursor-prev-nodup ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) @@ -858,11 +1057,12 @@ (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf :prev-nodup t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key) (deserialize val)) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))) (cursor-last cursor))) -(defmethod cursor-pnext-dup ((cursor secondary-cursor)) +(defmethod cursor-pnext-dup ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -870,11 +1070,12 @@ (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf value-buf :next-dup t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key) (deserialize val) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) (progn (buffer-read-int pkey) (deserialize pkey))) (setf (cursor-initialized-p cursor) nil)))))) -(defmethod cursor-pnext-nodup ((cursor secondary-cursor)) +(defmethod cursor-pnext-nodup ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -882,12 +1083,13 @@ (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf value-buf :next-nodup t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key) (deserialize val) - (progn (buffer-read-int pkey) (deserialize pkey))) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (progn (buffer-read-int pkey) (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil)))) (cursor-pfirst cursor))) -(defmethod cursor-pprev-nodup ((cursor secondary-cursor)) +(defmethod cursor-pprev-nodup ((cursor bdb-secondary-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) @@ -895,8 +1097,10 @@ (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf value-buf :prev-nodup t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key) (deserialize val) - (progn (buffer-read-int pkey) (deserialize pkey))) + (values t (deserialize key :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (deserialize val :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))) + (progn (buffer-read-int pkey) + (deserialize pkey :sc (check-con (:dbcn-spc-pst (cursor-btree cursor)))))) (setf (cursor-initialized-p cursor) nil)))) (cursor-plast cursor))) Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.12 elephant/src/controller.lisp:1.13 --- elephant/src/controller.lisp:1.12 Thu Feb 24 02:06:10 2005 +++ elephant/src/controller.lisp Wed Nov 23 18:51:37 2005 @@ -42,20 +42,47 @@ (in-package "ELEPHANT") + +;; This list contains functions that take one arugment, +;; the "spec", and will construct an appropriate store +;; controller from it. +(defvar *strategies* '()) + +(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant-0.3/") + +(defun register-strategy (spec-to-controller) + (setq *strategies* (delete spec-to-controller *strategies*)) + (setq *strategies* (cons spec-to-controller *strategies*)) + ) + +(defun get-controller (spec) + (let ((store-controllers nil)) + (dolist (s *strategies*) + (let ((sc (funcall s spec))) + (if sc + (push sc store-controllers)))) + (if (not (= (length store-controllers) 1)) + (error "Strategy resolution for this spec completely failed!") + (car store-controllers)) + )) + + (defclass store-controller () + ;; purely abstract class doesn't need a slot, though it + ;; should take the common ones. ((path :type (or pathname string) :accessor controller-path :initarg :path) + (root :reader controller-root) + (db :type (or null pointer-void) :accessor controller-db :initform '()) (environment :type (or null pointer-void) :accessor controller-environment) - (db :type (or null pointer-void) :accessor controller-db) (oid-db :type (or null pointer-void) :accessor controller-oid-db) (oid-seq :type (or null pointer-void) :accessor controller-oid-seq) (btrees :type (or null pointer-void) :accessor controller-btrees) (indices :type (or null pointer-void) :accessor controller-indices) (indices-assoc :type (or null pointer-void) :accessor controller-indices-assoc) - (root :reader controller-root) (instance-cache :accessor instance-cache :initform (make-cache-table :test 'eql))) (:documentation "Class of objects responsible for the @@ -63,6 +90,35 @@ creation, counters, locks, the root (for garbage collection,) et cetera.")) +(defclass bdb-store-controller (store-controller) + ( + ) + (:documentation "Class of objects responsible for the +book-keeping of holding DB handles, the cache, table +creation, counters, locks, the root (for garbage collection,) +et cetera.")) + +;; Without somemore sophistication, these functions +;; need to be defined here, so that they will be available for testing +;; even if you do not use the strategy in question... +(defun bdb-store-spec-p (path) + (stringp path)) + +(defun sql-store-spec-p (path) + (listp path)) + + +;; This has now way of passing in optionals? +(defun bdb-test-and-construct (spec) + (if (bdb-store-spec-p spec) + (open-store-bdb spec) + nil) + ) + +(eval-when ( :load-toplevel) + (register-strategy 'bdb-test-and-construct) + ) + (defgeneric open-controller (sc &key recover recover-fatal thread) (:documentation "Opens the underlying environment and all the necessary @@ -73,6 +129,118 @@ "Close the db handles and environment. Tries to wipe out references to the db handles.")) +(defgeneric build-btree (sc) + (:documentation + "Construct a btree of the appropriate type corresponding to this store-controller.")) + +(defgeneric build-indexed-btree (sc) + (:documentation + "Construct a btree of the appropriate type corresponding to this store-controller.")) + +(defgeneric get-transaction-macro-symbol (sc) + (:documentation + "Return the strategy-specific macro symbol that will let you do a transaction within that macro.")) + + +(defun make-indexed-btree (&optional (sc *store-controller*)) + (build-indexed-btree sc) + ) + + +(defgeneric build-btree-index (sc &key primary key-form) + (:documentation + "Construct a btree of the appropriate type corresponding to this store-controller.")) + +(defgeneric copy-from-key (key src dst) + (:documentation + "Move the object identified by key on the root in the src to the dst.")) + +(defmethod copy-from-key (key src dst) + (let ((v (get-from-root key :store-controller src))) + (if v + (add-to-root key v :store-controller dst) + v)) + ) + +(defun copy-btree-contents (src dst) + (map-btree + #'(lambda (k v) + (setf (get-value k dst) v) + ) + src) + ) + +;; I don't know if I need a "deeper" copy here or not.... +(defun my-copy-hash-table (ht) + (let ((nht (make-hash-table))) + (maphash + #'(lambda (k v) + (setf (gethash k nht) v)) + ht) + nht) + ) + +(defun add-index-from-index (iname v dstibt dstsc) + (declare (type btree-index v) + (type indexed-btree dstibt)) + (let ((kf (key-form v))) + (format t " kf ~A ~%" kf) + (let ((index + (build-btree-index dstsc :primary dstibt + :key-form kf))) + ;; Why do I have to do this here? + (setf (indices dstibt) (make-hash-table)) + (setf (indices-cache dstibt) (make-hash-table)) + (setf (gethash iname (indices-cache dstibt)) index) + (setf (gethash iname (indices dstibt)) index) + ) + ) + ) + +(defun my-copy-indices (ht dst dstsc) + (maphash + #'(lambda (k v) + (add-index-from-index k v dst dstsc)) + ht) + ) + +(defmethod migrate ((dst store-controller) obj) + "Copy a currently persistent object to a new repository." + (if (typep obj 'btree) + ;; For a btree, we need to copy the object with the indices intact, + ;; then just read it out... + (if (typep obj 'indexed-btree) + ;; We have to copy the indexes.. + (let ((nobj (build-indexed-btree dst))) + (my-copy-indices (indices obj) nobj dst) + (copy-btree-contents obj nobj) + nobj + ) + (let ((nobj (build-btree dst))) + (copy-btree-contents obj nobj) + nobj) + ) + (error (format nil "the migrate function cannot migrate objects like ~A~%" obj) + ))) + +;; ;; This routine attempst to do a destructive migration +;; ;; of the object to the new repository +(defmethod migraten-pobj ((dst store-controller) obj copy-fn) + "Migrate a persistent object and apply a binary (lambda (dst src) ...) function to the new object." + ;; The simplest thing to do here is to make + ;; an object of the new class; + ;; we will make it the responsibility of the caller to + ;; perform the copy on the slots --- or + ;; we can force them to pass in this function. + (if (typep obj 'persistent) + (let ((nobj (make-instance (type-of obj) :sc dst))) + (apply copy-fn (list nobj obj)) + nobj) + (error (format "obj ~A is not a persistent object!~%" obj)) + ) + ) + + (defun add-to-root (key value &key (store-controller *store-controller*)) "Add an arbitrary persistent thing to the root, so you can retrieve it in a later session. N.B. this means it (and @@ -85,6 +253,13 @@ (declare (type store-controller store-controller)) (get-value key (controller-root store-controller))) +(defun from-root-existsp (key &key (store-controller *store-controller*)) + "Get a something from the root." + (declare (type store-controller store-controller)) + (if (existsp key (controller-root store-controller)) + t + nil)) + (defun remove-from-root (key &key (store-controller *store-controller*)) "Remove something from the root." (declare (type store-controller store-controller)) @@ -104,14 +279,14 @@ ;; Should get cached since make-instance calls cache-instance (make-instance class-name :from-oid oid)))) -(defun next-oid (sc) +(defmethod next-oid ((sc bdb-store-controller)) "Get the next OID." - (declare (type store-controller sc)) + (declare (type bdb-store-controller sc)) (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ :auto-commit t :txn-nosync t)) ;; Open/close -(defmethod open-controller ((sc store-controller) &key (recover nil) +(defmethod open-controller ((sc bdb-store-controller) &key (recover nil) (recover-fatal nil) (thread t)) (let ((env (db-env-create))) ;; thread stuff? @@ -124,6 +299,7 @@ (indices (db-create env)) (indices-assoc (db-create env))) (setf (controller-db sc) db) + (setf (gethash (controller-path sc) *dbconnection-spec*) sc) (db-open db :file "%ELEPHANT" :database "%ELEPHANTDB" :auto-commit t :type DB-BTREE :create t :thread thread) @@ -160,11 +336,11 @@ :auto-commit t :create t :thread t) (setf (controller-oid-seq sc) oid-seq))) - (let ((root (make-instance 'btree :from-oid -1))) + (let ((root (make-instance 'bdb-btree :from-oid -1 :sc sc))) (setf (slot-value sc 'root) root)) sc))) -(defmethod close-controller ((sc store-controller)) +(defmethod close-controller ((sc bdb-store-controller)) (when (slot-value sc 'root) ;; no root (setf (slot-value sc 'root) nil) @@ -187,6 +363,49 @@ (setf (controller-environment sc) nil) nil)) +;; Do these things need to take &rest arguments? +(defmethod build-btree ((sc bdb-store-controller)) + (make-bdb-btree sc) + ) + + +(defun make-btree (&optional (sc *store-controller*)) + (build-btree sc) + ) + +(defmethod get-transaction-macro-symbol ((sc bdb-store-controller)) + 'with-transaction + ) + +(defun open-store (spec &key (recover nil) + (recover-fatal nil) (thread t)) + "Conveniently open a store controller." + (setq *store-controller* + (get-controller spec)) + (open-controller *store-controller* :recover recover + :recover-fatal recover-fatal :thread thread)) + +(defun open-store-bdb (spec &key (recover nil) + (recover-fatal nil) (thread t)) + "Conveniently open a store controller." + (setq *store-controller* + (if (bdb-store-spec-p spec) + (make-instance 'bdb-store-controller :path spec) + (error (format nil "uninterpretable path/spec specifier: ~A" spec)))) + (open-controller *store-controller* :recover recover + :recover-fatal recover-fatal :thread thread)) + + +(defmacro with-open-store-bdb ((path) &body body) + "Executes the body with an open controller, + unconditionally closing the controller on exit." + `(let ((*store-controller* (make-instance 'bdb-store-controller :path ,path))) + (declare (special *store-controller*)) + (open-controller *store-controller*) + (unwind-protect + (progn ,@body) + (close-controller *store-controller*)))) + (defmacro with-open-controller ((&optional (sc '*store-controller*)) &body body) "Executes body with the specified controller open, closing @@ -198,34 +417,37 @@ ,@body)) (close-controller ,sc))) -(defun open-store (path &key (recover nil) - (recover-fatal nil) (thread t)) - "Conveniently open a store controller." - (setq *store-controller* (make-instance 'store-controller :path path)) - (open-controller *store-controller* :recover recover - :recover-fatal recover-fatal :thread thread)) - (defun close-store () "Conveniently close the store controller." - (close-controller *store-controller*)) + (if *store-controller* + (close-controller *store-controller*))) -(defmacro with-open-store ((path) &body body) +(defmacro with-open-store ((spec) &body body) "Executes the body with an open controller, unconditionally closing the controller on exit." - `(let ((*store-controller* (make-instance 'store-controller :path ,path))) - (declare (special *store-controller*)) - (open-controller *store-controller*) - (unwind-protect - (progn ,@body) - (close-controller *store-controller*)))) + `(let ((*store-controller* + (get-controller ,spec))) + (declare (special *store-controller*)) +;; (open-controller *store-controller*) + (unwind-protect + (progn ,@body) + (close-controller *store-controller*)))) + ;;; Make these respect the transaction keywords (e.g. degree-2) -(defun start-transaction (&key (parent *current-transaction*)) - "Start a transaction. May be nested but not interleaved." - (vector-push-extend *current-transaction* *transaction-stack*) - (setq *current-transaction* - (db-transaction-begin (controller-environment *store-controller*) - :parent parent))) +;; (defun start-transaction (&key (parent *current-transaction*)) +;; "Start a transaction. May be nested but not interleaved." +;; (vector-push-extend *current-transaction* *transaction-stack*) +;; (setq *current-transaction* +;; (db-transaction-begin (controller-environment *store-controller*) +;; :parent parent))) + +(defun start-ele-transaction (&key (parent *current-transaction*) (store-controller *store-controller*)) + "Start a transaction. May be nested but not interleaved." + (vector-push-extend *current-transaction* *transaction-stack*) + (setq *current-transaction* + (db-transaction-begin (controller-environment store-controller) + :parent parent))) (defun commit-transaction () "Commit the current transaction." @@ -236,3 +458,12 @@ "Abort the current transaction." (db-transaction-abort) (setq *current-transaction* (vector-pop *transaction-stack*))) + +(defgeneric persistent-slot-reader-aux (sc instance name) + (:documentation + "Auxilliary method to allow implementation-specific slot reading")) + +(defgeneric persistent-slot-writer-aux (sc new-value instance name) + (:documentation + "Auxilliary method to allow implementation-specific slot writing")) + Index: elephant/src/elephant.lisp diff -u elephant/src/elephant.lisp:1.14 elephant/src/elephant.lisp:1.15 --- elephant/src/elephant.lisp:1.14 Thu Feb 24 02:07:52 2005 +++ elephant/src/elephant.lisp Wed Nov 23 18:51:37 2005 @@ -49,20 +49,49 @@ (:use common-lisp sleepycat uffi) (:shadow #:with-transaction) (:export #:*store-controller* #:*current-transaction* #:*auto-commit* + #:bdb-store-controller + #:sql-store-controller + #:make-bdb-btree + #:make-sql-btree + #:bdb-indexed-btree + #:sql-indexed-btree + #:from-root-existsp #:open-store #:close-store #:with-open-store #:store-controller #:open-controller #:close-controller #:with-open-controller #:controller-path #:controller-environment #:controller-db #:controller-root #:add-to-root #:get-from-root #:remove-from-root #:start-transaction #:commit-transaction #:abort-transaction + #:start-ele-transaction #:commit-transaction #:abort-transaction + #:build-btree + #:make-btree + #:make-indexed-btree + #:copy-from-key + #:open-store-bdb + #:open-store-sql + #:btree-differ + #:migrate + #:persistent-slot-boundp-sql + #:persistent-slot-reader-sql + #:persistent-slot-writer-sql + #:*elephant-lib-path* + #:persistent #:persistent-object #:persistent-metaclass - #:persistent-collection #:btree #:get-value #:remove-kv + #:persistent-collection #:btree + #:bdb-btree #:sql-btree + #:get-value #:remove-kv + #:indexed-btree #:add-index #:get-index #:remove-index #:btree-index #:get-primary-key #:indices #:primary #:key-form #:key-fn + #:build-indexed-btree + #:make-indexed-btree + + #:bdb-cursor #:sql-cursor + #:cursor-init #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:map-btree #:cursor-close #:cursor-duplicate #:cursor-current #:cursor-first @@ -249,4 +278,4 @@ #+cmu (eval-when (:compile-toplevel) - (proclaim '(optimize (ext:inhibit-warnings 3)))) \ No newline at end of file + (proclaim '(optimize (ext:inhibit-warnings 3)))) Index: elephant/src/libsleepycat.c diff -u elephant/src/libsleepycat.c:1.11 elephant/src/libsleepycat.c:1.12 --- elephant/src/libsleepycat.c:1.11 Thu Feb 24 02:04:13 2005 +++ elephant/src/libsleepycat.c Wed Nov 23 18:51:37 2005 @@ -58,6 +58,11 @@ #include <string.h> #include <wchar.h> +/* Some utility stuff used to be here but has been placed in + libmemutil.c */ + +/* Pointer arithmetic utility functions */ +/* should these be in network-byte order? probably not..... */ /* Pointer arithmetic utility functions */ /* should these be in network-byte order? probably not..... */ int read_int(char *buf, int offset) { Index: elephant/src/metaclasses.lisp diff -u elephant/src/metaclasses.lisp:1.7 elephant/src/metaclasses.lisp:1.8 --- elephant/src/metaclasses.lisp:1.7 Thu Feb 24 02:07:52 2005 +++ elephant/src/metaclasses.lisp Wed Nov 23 18:51:37 2005 @@ -42,8 +42,43 @@ (in-package "ELEPHANT") +(defvar *dbconnection-spec* + (make-hash-table :test 'equal)) + +(defun connection-is-indeed-open (con) + t ;; I don't yet know how to implement this + ) + +;; This needs to be a store-controller method... +(defun check-con (spec &optional sc ) + (let ((con (gethash spec *dbconnection-spec*))) + (if (and con (connection-is-indeed-open con)) + con + (if (not (typep sc 'bdb-store-controller)) + (progn + (error "We can't default to *store-controller* in a multi-use enviroment.")) + ;; (setf (gethash spec *dbconnection-spec*) + ;; (clsql:connect (cdr (:dbcn-spc sc)) + ;; :database-type :postgresql-socket + ;; :if-exists :old))) + (error "We don't know how to open a bdb-connection here!") + ;; if they don't give us connection-spec, we can't reopen things... + )))) + + + (defclass persistent () - ((%oid :accessor oid :initarg :from-oid)) + ((%oid :accessor oid :initarg :from-oid) + ;; This is just an idea for storing connections in the persistent + ;; objects; these should be transient as well, if that flag exists! + ;; In the case of sleepy cat, this is the controller-db from + ;; the store-controller. In the case of SQL this is + ;; the connection spec (since the connection might be broken?) + ;; It probably would be better to put a string in here in the case + ;; of sleepycat... + (dbonnection-spec-pst :type (or list string) :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst + :initform '()) + ) (:documentation "Abstract superclass for all persistent classes (common to user-defined classes and collections.)")) @@ -65,7 +100,12 @@ (cdr (%persistent-slots class))) (defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list) - (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class))))) +;; (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class))))) + (setf (%persistent-slots class) (cons new-slot-list + (if (slot-boundp class '%persistent-slots) + (car (%persistent-slots class)) + nil) + ))) (defclass persistent-slot-definition (standard-slot-definition) ()) @@ -155,8 +195,8 @@ (defmethod compute-effective-slot-definition-initargs ((class slots-class) direct-slots) (let* ((name (loop for s in direct-slots - when s - do (return (slot-definition-name s)))) + when s + do (return (slot-definition-name s)))) (initer (dolist (s direct-slots) (when (%slot-definition-initfunction s) (return s)))) @@ -184,7 +224,7 @@ (defun ensure-transient-chain (slot-definitions initargs) (declare (ignore initargs)) (loop for slot-definition in slot-definitions - always (transient slot-definition))) + always (transient slot-definition))) (defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions) (let ((initargs (call-next-method))) @@ -194,19 +234,22 @@ (setf (getf initargs :allocation) :database) initargs)))) + (defmacro persistent-slot-reader (instance name) - `(progn - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid ,instance) key-buf) - (serialize ,name key-buf) - (let ((buf (db-get-key-buffered - (controller-db *store-controller*) - key-buf value-buf))) - (if buf (deserialize buf) - #+cmu - (error 'unbound-slot :instance ,instance :slot ,name) - #-cmu - (error 'unbound-slot :instance ,instance :name ,name)))))) +`(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance))) + (persistent-slot-reader-aux (check-con (:dbcn-spc-pst ,instance)) ,instance ,name) + (progn + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ,instance) key-buf) + (serialize ,name key-buf) + (let ((buf (db-get-key-buffered + (controller-db (check-con (:dbcn-spc-pst ,instance))) + key-buf value-buf))) + (if buf (deserialize buf :sc (check-con (:dbcn-spc-pst instance))) + #+cmu + (error 'unbound-slot :instance ,instance :slot ,name) + #-cmu + (error 'unbound-slot :instance ,instance :name ,name))))))) #+(or cmu sbcl) (defun make-persistent-reader (name) @@ -216,16 +259,18 @@ (persistent-slot-reader instance name))) (defmacro persistent-slot-writer (new-value instance name) - `(progn - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid ,instance) key-buf) - (serialize ,name key-buf) - (serialize ,new-value value-buf) - (db-put-buffered (controller-db *store-controller*) - key-buf value-buf - :transaction *current-transaction* - :auto-commit *auto-commit*) - ,new-value))) + `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance))) + (persistent-slot-writer-aux (check-con (:dbcn-spc-pst ,instance)) ,new-value ,instance ,name) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ,instance) key-buf) + (serialize ,name key-buf) + (serialize ,new-value value-buf) + (db-put-buffered + (controller-db (check-con (:dbcn-spc-pst ,instance))) + key-buf value-buf + :transaction *current-transaction* + :auto-commit *auto-commit*) + ,new-value))) #+(or cmu sbcl) (defun make-persistent-writer (name) @@ -234,15 +279,22 @@ (type persistent-object instance)) (persistent-slot-writer new-value instance name))) +;; This this is not a good way to form a key... +(defun form-slot-key (oid name) + (format nil "~A ~A" oid name) + ) + (defmacro persistent-slot-boundp (instance name) - `(progn - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid ,instance) key-buf) - (serialize ,name key-buf) - (let ((buf (db-get-key-buffered - (controller-db *store-controller*) - key-buf value-buf))) - (if buf T nil))))) + `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance))) + (persistent-slot-boundp-aux (check-con (:dbcn-spc-pst ,instance)) ,instance ,name) + (progn + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ,instance) key-buf) + (serialize ,name key-buf) + (let ((buf (db-get-key-buffered + (controller-db (check-con (:dbcn-spc-pst ,instance))) + key-buf value-buf))) + (if buf T nil)))))) #+(or cmu sbcl) (defun make-persistent-slot-boundp (name) @@ -265,11 +317,11 @@ (defun persistent-slot-names (class) (let ((slot-definitions (class-slots class))) (loop for slot-definition in slot-definitions - when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition)) - collect (slot-definition-name slot-definition)))) + when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition)) + collect (slot-definition-name slot-definition)))) (defun transient-slot-names (class) (let ((slot-definitions (class-slots class))) (loop for slot-definition in slot-definitions - unless (persistent-p slot-definition) - collect (slot-definition-name slot-definition)))) \ No newline at end of file + unless (persistent-p slot-definition) + collect (slot-definition-name slot-definition)))) Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.10 elephant/src/serializer.lisp:1.11 --- elephant/src/serializer.lisp:1.10 Thu Feb 24 02:06:10 2005 +++ elephant/src/serializer.lisp Wed Nov 23 18:51:37 2005 @@ -261,7 +261,7 @@ (push slot-name ret)) finally (return ret))) -(defun deserialize (buf-str) +(defun deserialize (buf-str &key sc) "Deserialize a lisp value from a buffer-stream." (declare (optimize (speed 3) (safety 0)) (type (or null buffer-stream) buf-str)) @@ -306,7 +306,8 @@ ((= tag +ucs4-string+) (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) ((= tag +persistent+) - (get-cached-instance *store-controller* +;; (get-cached-instance *store-controller* + (get-cached-instance sc (buffer-read-fixnum bs) (%deserialize bs))) ((= tag +single-float+) @@ -361,13 +362,33 @@ (let* ((id (buffer-read-fixnum bs)) (maybe-o (gethash id *circularity-hash*))) (if maybe-o maybe-o - (let ((o (make-instance (%deserialize bs)))) - (setf (gethash id *circularity-hash*) o) - (loop for i fixnum from 0 below (%deserialize bs) - do - (setf (slot-value o (%deserialize bs)) - (%deserialize bs))) - o)))) + (let ((typedesig (%deserialize bs))) + ;; now, depending on what typedesig is, we might + ;; or might not need to specify the store controller here.. + (let ((o + (or (ignore-errors + (if (subtypep typedesig 'persistent) + (make-instance typedesig :sc sc) + ;; if the this type doesn't exist in our object + ;; space, we can't reconstitute it, but we don't want + ;; to abort completely, we will return a special object... + ;; This behavior could be configurable; the user might + ;; prefer an abort here, but I prefer surviving... + (make-instance typedesig) + ) + ) + (list 'uninstantiable-object-of-type typedesig) + ) + )) + (if (listp o) + o + (progn + (setf (gethash id *circularity-hash*) o) + (loop for i fixnum from 0 below (%deserialize bs) + do + (setf (slot-value o (%deserialize bs)) + (%deserialize bs))) + o))))))) ((= tag +array+) (let* ((id (buffer-read-fixnum bs)) (maybe-array (gethash id *circularity-hash*))) @@ -464,3 +485,73 @@ #-(or cmu sbcl allegro) (byte 32 (* 32 position)) ) + + +(eval-when (:compile-toplevel :load-toplevel) + (asdf:operate 'asdf:load-op :cl-base64) +) +(defun ser-deser-equal (x1 &keys sc) + (let* ( + (x1s (serialize-to-base64-string x1)) + (x1prime (deserialize-from-base64-string x1s :sc sc))) + (assert (equal x1 x1prime)) + (equal x1 x1prime))) + + +(defun serialize-to-base64-string (x) + (with-buffer-streams (out-buf) + (cl-base64::usb8-array-to-base64-string + (sleepycat::buffer-read-byte-vector + (serialize x out-buf)))) + ) + + +(defun deserialize-from-base64-string (x &keys sc) + (with-buffer-streams (other) + (deserialize + (sleepycat::buffer-write-byte-vector + other + (cl-base64::base64-string-to-usb8-array x)) + :sc sc + ) + )) + +;; (defclass blob () +;; ((slot1 :accessor slot1 :initarg :slot1) +;; (slot2 :accessor slot2 :initarg :slot2))) + +;; (defvar keys (loop for i from 1 to 1000 +;; collect (concatenate 'string "key-" (prin1-to-string i)))) + +;; (defvar objs (loop for i from 1 to 1000 +;; collect (make-instance 'blob +;; :slot1 i +;; :slot2 (* i 100)))) +;; (defmethod blob-equal ((a blob) (b blob)) +;; (and (equal (slot1 a) (slot1 b)) +;; (equal (slot2 a) (slot2 b)))) + +;; (defun test-base64-serializer () +;; (let* ((x1 "spud") +;; (x2 (cons 'a 'b)) +;; (objs (loop for i from 1 to 1000 +;; collect (make-instance 'blob +;; :slot1 i +;; :slot2 (* i 100)))) +;; ) +;; (and +;; (ser-deser-equal x1) +;; (ser-deser-equal x2) +;; (reduce +;; #'(lambda (x y) (and x y)) +;; (mapcar +;; #'(lambda (x) +;; (equal x +;; (with-buffer-streams (other) +;; (deserialize (serialize x other)) +;; ))) +;; ;; (deserialize-from-base64-string +;; ;; (serialize-to-base64-string x)))) +;; objs) +;; :initial-value t) +;; ))) Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.13 elephant/src/sleepycat.lisp:1.14 --- elephant/src/sleepycat.lisp:1.13 Thu Feb 24 02:06:09 2005 +++ elephant/src/sleepycat.lisp Wed Nov 23 18:51:37 2005 @@ -124,44 +124,18 @@ (eval-when (:compile-toplevel) (proclaim '(optimize (ext:inhibit-warnings 3)))) -(eval-when (:compile-toplevel :load-toplevel) - ;; UFFI - ;;(asdf:operate 'asdf:load-op :uffi) - ;; DSO loading - Edit these for your system! +(eval-when (:compile-toplevel :load-toplevel) - ;; Under linux you may need to load some kind of pthread - ;; library. I can't figure out which is the right one. - ;; This one worked for me. There are known issues with - ;; Red Hat and Berkeley DB, search google. - #+linux - (unless - (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") - (error "Couldn't load libpthread!")) - - (unless - (uffi:load-foreign-library - ;; Sleepycat: this works on linux - #+linux - "/db/ben/lisp/db43/lib/libdb.so" - ;; this works on FreeBSD - #+(and (or bsd freebsd) (not darwin)) - "/usr/local/lib/db43/libdb.so" - #+darwin - "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib" - :module "sleepycat") - (error "Couldn't load libdb (Sleepycat)!")) - - ;; Libsleepycat.so: edit this - (unless - (uffi:load-foreign-library - (if (find-package 'asdf) - (merge-pathnames - #p"libsleepycat.so" - (asdf:component-pathname (asdf:find-system 'elephant))) - "/usr/local/share/common-lisp/elephant-0.2/libsleepycat.so") - :module "libsleepycat") - (error "Couldn't load libsleepycat!")) + (unless + (uffi:load-foreign-library + (if (find-package 'asdf) + (merge-pathnames + #p"libmemutil.so" + (asdf:component-pathname (asdf:find-system 'elephant))) + (format nil "~A/~A" *elephant-lib-path* "libmemutil.so")) + :module "libmemutil") + (error "Couldn't load libmemutil.so!")) ;; fini on user editable part @@ -786,7 +760,32 @@ (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (incf (buffer-stream-position bs)) - (deref-array (buffer-stream-buffer bs) '(:array :char) position))) + (deref-array (buffer-stream-buffer bs) '(:array :unsigned-byte) position))) + +(defun buffer-read-byte-vector (bs) + "Read the whole buffer into byte vector." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let* ((position (buffer-stream-position bs)) + (size (buffer-stream-size bs)) + (vlen (- size position))) + (if (>= vlen 0) + (let ((v (make-array vlen :element-type '(unsigned-byte 8)))) + (dotimes (i vlen v) + (setf (aref v i) (buffer-read-byte bs)))) + nil))) + +(defun buffer-write-byte-vector (bs bv) + "Read the whole buffer into byte vector." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs)) + (let* ((position (buffer-stream-position bs)) + (size (buffer-stream-size bs)) + (vlen (length bv)) + (writable (max vlen (- size position)))) + (dotimes (i writable bs) + (buffer-write-byte (aref bv i) bs)))) + (defun buffer-read-fixnum (bs) "Read a 32-bit signed integer, which is assumed to be a fixnum." @@ -828,6 +827,17 @@ (setf (buffer-stream-position bs) (+ position 8)) (read-double (buffer-stream-buffer bs) position))) +;; A non-back-compatible change was made in SBCL 8 moving to SBCL 9, +;; in that the function copy-from-system-area disappeared. +;; This code is an attempt to allow compilation under bothe SBCL 8 and SBCL 9. +;; Thanks to Juho Snellman for this idiom. +(eval-when (:compile-toplevel) + (defun new-style-copy-p () + (if (find-symbol "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL") + '(:and) + '(:or))) + ) + (defun buffer-read-ucs1-string (bs byte-length) "Read a UCS1 string." (declare (optimize (speed 3) (safety 0)) @@ -841,6 +851,14 @@ :length byte-length :null-terminated-p nil) #+(and sbcl sb-unicode) (let ((res (make-string byte-length :element-type 'base-char))) +#+#.(sleepycat::new-style-copy-p) + (sb-kernel:copy-ub8-from-system-area + (sb-alien:alien-sap (buffer-stream-buffer bs)) + (* position sb-vm:n-byte-bits) + res + (* sb-vm:vector-data-offset sb-vm:n-word-bits) + (* byte-length sb-vm:n-byte-bits)) +#-#.(sleepycat::new-style-copy-p) (sb-kernel:copy-from-system-area (sb-alien:alien-sap (buffer-stream-buffer bs)) (* position sb-vm:n-byte-bits) @@ -877,6 +895,14 @@ (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position byte-length)) (let ((res (make-string (/ byte-length 4) :element-type 'character))) +#+#.(sleepycat::new-style-copy-p) + (sb-kernel:copy-ub8-from-system-area + (sb-alien:alien-sap (buffer-stream-buffer bs)) + (* position sb-vm:n-byte-bits) + res + (* sb-vm:vector-data-offset sb-vm:n-word-bits) + (* byte-length sb-vm:n-byte-bits)) +#-#.(sleepycat::new-style-copy-p) (sb-kernel:copy-from-system-area (sb-alien:alien-sap (buffer-stream-buffer bs)) (* position sb-vm:n-byte-bits) Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.8 elephant/src/utils.lisp:1.9 --- elephant/src/utils.lisp:1.8 Thu Feb 24 02:06:08 2005 +++ elephant/src/utils.lisp Wed Nov 23 18:51:38 2005 @@ -99,36 +99,65 @@ #+(or cmu sbcl allegro) *resourced-byte-spec*)) (funcall thunk))) +;; get rid of spot idx and adjust the arrray +(defun remove-indexed-element-and-adjust (idx array) + (let ((last (- (length array) 1))) + (do ((i idx (1+ i))) + ((= i last) nil) + (progn + (setf (aref array i) (aref array (+ 1 i))))) + (adjust-array array last))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Macros - ;; Good defaults for elephant -(defmacro with-transaction ((&key transaction - (environment '(controller-environment - *store-controller*)) - (parent '*current-transaction*) - degree-2 dirty-read txn-nosync - txn-nowait txn-sync - (retries 100)) - &body body) +(defmacro with-transaction ( + (&key transaction + (store-controller '*store-controller*) + environment + (parent '*current-transaction*) + degree-2 dirty-read txn-nosync + txn-nowait txn-sync + (retries 100)) + &body body +) "Execute a body with a transaction in place. On success, the transaction is committed. Otherwise, the transaction is aborted. If the body deadlocks, the body is re-executed in a new transaction, retrying a fixed number of iterations. *auto-commit* is false for the body of the transaction." - `(sleepycat:with-transaction (:transaction ,transaction - :environment ,environment - :parent ,parent - :degree-2 ,degree-2 - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync - :retries ,retries) - (let ((*auto-commit* nil)) - ,@body))) + `(if (not (typep ,store-controller 'elephant::bdb-store-controller)) + (elephant::with-transaction-sql (:store-controller-sql ,store-controller) + ,@body) +;; (if (clsql::in-transaction-p +;; :database +;; (controller-db ,store-controller)) +;; (progn +;; ,@body) +;; (prog2 +;; (clsql::set-autocommit nil) +;; (clsql::with-transaction +;; (:database +;; (controller-db ,store-controller)) +;; ,@body) +;; (clsql::set-autocommit t))) + (let ((env (if ,environment ,environment + (controller-environment ,store-controller)))) + (sleepycat:with-transaction (:transaction ,transaction + :environment env + :parent ,parent + :degree-2 ,degree-2 + :dirty-read ,dirty-read + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync + :retries ,retries) + + (let ((*auto-commit* nil)) + ,@body))) + )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[elephant-cvs] CVS update: elephant/doc/Makefile elephant/doc/sql-backend.texinfo elephant/doc/elephant.texinfo elephant/doc/make-ref.lisp elephant/doc/reference.texinfo
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant/doc In directory common-lisp.net:/tmp/cvs-serv30677/doc Modified Files: elephant.texinfo make-ref.lisp reference.texinfo Added Files: Makefile sql-backend.texinfo Log Message: This is the big merger from the SQL-BACK-END branch. Date: Wed Nov 23 18:51:35 2005 Author: rread Index: elephant/doc/Makefile diff -u /dev/null elephant/doc/Makefile:1.2 --- /dev/null Wed Nov 23 18:51:35 2005 +++ elephant/doc/Makefile Wed Nov 23 18:51:34 2005 @@ -0,0 +1,8 @@ + + + +docs: includes-stuff + makeinfo -v --html --force elephant.texinfo + +includes-stuff: + cd includes; lisp < ../make-ref.lisp Index: elephant/doc/sql-backend.texinfo diff -u /dev/null elephant/doc/sql-backend.texinfo:1.2 --- /dev/null Wed Nov 23 18:51:35 2005 +++ elephant/doc/sql-backend.texinfo Wed Nov 23 18:51:34 2005 @@ -0,0 +1,327 @@ +@c -*-texinfo-*- + +@node SQL back-end +@comment node-name, next, previous, up +@chapter SQL back-end +@cindex SQL back-end + +@menu +* SQL-Introduction:: The design and status of the SQL back-end extention. +* Extention Status:: The current status of the SQL back-end extention. +* Back-compatibility:: Issues if you have already been using Elephant +* Multi-repository Operation:: Specifying repositories +* Setting up PostGres:: An example +* Repository Migration:: How to move objects from one repository to another +@end menu + +@node SQL-Introduction +@comment node-name, next, previous, up +@section SQL-Introduction + +Although originally designed as an interface to the BerkeleyDB system, +the original Elephant system has been experimenetally extended to +support the use of relational database management systems as the +implementation of the persistent store. This relies on Kevin Rosenberg's +CL-SQL interface to relational systems. + +Although the BerkeleyDB system is an ideal object store for LISP objects, +one might prefer the licensing of a different system. For example, at +the time of this writing, it is my interpretation that one cannot use +the BerkeleyDB system behind a public website +http://www.sleepycat.com/download/licensinginfo.shtml#redistribute +unless one releases the entire web application as open source. + +Neither the PostGres DBMS nor SQLite 3 has any such restriction. Elephant itself is released +under the GPL. It is somewhat debatable if the GPL allows one to construct +to construct a non-open-source web application but the preponderance of +opinion appears to be that it does. Thefore using Elephant and the other +GPLed software that it depends upon allows one to host a a non open-source +web application. This might be a reason to use Elephant on PostGres of SQLite rather +than Elephant on BerkeleyDB. + +Other reasons to use a relational database system might include: +familiarity with those systems, the fact that some part of your application +needs to use the truly relational aspects of those systems, preference for +the tools associated with those systems, etc. + +The SQL back-end extention of Elephant provides a function for migrating +data seamlessly between repositories. That is, one can quite easily move +data from a BerkeleyDB repository to a PostGres repository, and vice versa. +In fact, one of the most important aspects of the extention is that it +makes Elephant a multi-repository system, rather than a single repository +system, as addition to allowing different implementation strategies for +those repositories. This offers at least the possiblity than once +can develop using one backend, for example BerkeleyDB, and then later +move to MySQL. + +At the time of this writing, the basic strategy for the SQL implementation +is quite simple. The same serializer used for the Sleepycat implementation +is employed, the byte-string is base64 encoded, and placed in a single +table which is managed by Elephant. + +As of Elephant 0.3, Elephant has been tested to work with both Postgres, and +SQLite 3, thanks do Dan Knapp. + +@node Extention Status +@comment node-name, next, previous, up +@section Extention Status + +As far as is known at this writing, all functionality except nested transaction +support and cursor-put's that is supported by the BerkeleyDB backend is supported by the CL-SQL +based back-end. Concurrency and transaction atomicity has not been tested well +for the CL-SQL based system. + +Additionally, it is NOT the case that the Elephant system currently provides +transaction support across multiple repositories; it provides the transaction +support provided by the underlying repository to the user in a per-repository +basis. + +The PostGres backend is as currently employed is about 5 times slower than +the BerkeleyDB backend. This could probably change with continued development. + +CL-SQL supports a lot of DBMS systems, but only PostGres has been tested. + +The SQL back-end extention has only been tested under SBCL 0.8.18. + +The SQL back-end is as easy to use as the BerkeleyDB back-end. However, +the multi-repository version somewhat complicates the underlying +persistent object management. At the time of this writing, the +community has not decided if this extention will be a part of +Elephant proper or a separate branch; if it is not made a part of +Elephant proper, a user might prefer the simpler (and better maintained?) +system if they only want to use the BerkeleyDB back-end. + + +@node Back-compatibility +@comment node-name, next, previous, up +@section Back-compatibility + +The CL-SQL based extention is very back-compatible with any existing Elephant +application, except for two items. + +First, the routines ``build-btree'' and ``build-index-btree'' should be used +in place of the previous approach to direct calls to make-instance. This is +necessary, because the underlying class of the object depends on what repository +it is stored in. These routines, like make-instance on persistent objects directly, +allow you to specify the store controller at creation time. However, build-btree +and build-index-btree will use the global *store-controller* if no keyword +argument is provided. + +Secondly, in addition to executing: +@lisp +(asdf:operate 'asdf:load-op :elephant) +@end lisp +to load elephant, one must at least one of: +@lisp +(asdf:operate 'asdf:load-op :ele-clsql) +(asdf:operate 'asdf:load-op :ele-bdb) +@end lisp + +To use SQLLite3, you must execute: +@lisp +(asdf:operate 'asdf:load-op :ele-sqlite3) +@end lisp + +depending on whether or not you wish to use the clsql backend or the BerkeleyDB +backend, or both. + +You will have to have the CL-SQL package installed. Following the +documentation for CL-SQL under the section ``How CLSQL finds and loads foreign +libraries'' you may need to do something like: +@lisp +(clsql:push-library-path "/usr/lib/") +@end lisp + +before doing +@lisp +(asdf:oos 'asdf:load-op :clsql-postgresql-socket) +@end lisp + +in order for clsql to find the PostGres library libpq.so, for example. + +Without modifcation, Elephant uses this as it's lib path: +@lisp +/usr/local/share/common-lisp/elephant-0.3/ +@end lisp + +So you could put a symbolic link to libpq.so there, where libmemutil.so and +libsleepycat.so will also reside. + +Versions of CL-SQL older than 3.2.3 might requie something different. + +@node Multi-repository Operation +@comment node-name, next, previous, up +@section Multi-repository Operation + +Elephant now keeps a small hashtables that maps ``database specifications'' into +actual database connections. + +If a database spec is a string, it is assumed to be a BerkeleyDB path. +If it is a list, it is a assumed to be a CL-SQL connection specification. +For example: +@lisp +ELE-TESTS> *testdb-path* +"/home/read/projects/elephant/elephant/tests/testdb/" +ELE-TESTS> *testpg-path* +(:postgresql "localhost.localdomain" "test" "postgres" "") +ELE-TESTS> +@end lisp + + +The tests now have a function @code{do-all-tests-spec} that take a spec and +based on its type attempt to open the correct kind of store controller and +perform the tests. + +The routine @code{get-controller} takes this specifiation. + +The basic strategy is that the ``database specification'' object is stored in +every persistent object and collection so that the repository can be found. + +In this way, objects that reside in different repositories can coexist within +the LISP object space, allowing data migration. + + + + +@node Setting up PostGres +@comment node-name, next, previous, up +@section Setting up PostGres + + +To set up a PostGres based back end, you should: + +@enumerate +@item Install postgres and make sure postmaster is running. + +@item Create a database called ``test'' and set its permissions +to be reached by whatever connection specification you intend to use. The +tests use: + +@lisp +(defvar *testpg-path* +'(:postgreql "localhost.localdomain" "test" "postgres" "")) +@end lisp + +meaning that connections must be allowed to the database test, user ``postgres'', +no password, connected from the same machine ``localhost.localdomain''. +(This would be changed to something more secure in a real application.) +Typically you edit the file : pg_hba.conf to enable various kinds of connections +in postgres. + +@item Be sure to enable socket connection to postgres when you invoke the postmaster. + +@item Test that you can connect to the database with these credentials by running: + +@code{ psql -h 127.0.0.1 -U postgres test} + +Before you attempt to connect with Elephant. +@end enumerate + + +meaning that connections must be allowed to the database test, user ``postgres'', +no password, connected from the same machine ``localhost.localdomain''. +(This would be changed to something more secure in a real application.) + +Furthermore, you must grant practically all creation/read/write privileges +to the user postgres on this schema, so that it can construct the tables +it needs. + +Upon first opening a CL-SQL based store controller, the tables, indexes, +sequences, and so on needed by the Elephant system will be created in the +schema named ``test'' automatically. + +To run the tests, execute: + +@lisp +(asdf:operate 'asdf:load-op :elephant) +(asdf:operate 'asdf:load-op :ele-clsql) +(asdf:oos 'asdf:load-op :clsql-postgresql-socket) +(in-package "ELEPHANT-TESTS") +(do-all-tests-spec *testpg-path*) +@end lisp + +This should produce a small number of errors (about 7) for those test having +to do with migration and the BerkeleyDB system specifically. + +If you execute: + +@lisp +(asdf:operate 'asdf:load-op :ele-bdb) +@end lisp + +Then connection to the BerkeleyDB system will be enabled, and you should +be able to execute both + +@lisp +(do-all-tests-spec *testpg-path*) +(do-all-tests-spec *testdb-path*) +@end lisp + +with no errors in either case. + +At present the system has only been tested under PostGres. Some code +parametrization would be required to work with other databases. + +Setting up SQLite3 is even easier. Install SQLite3 (I had to use +the source rather than the binary install, in order to get the dynamic +libraries constructed.) + +An example use of SQLLite3 would be: +@lisp +(asdf:operate 'asdf:load-op :elephant) +(asdf:operate 'asdf:load-op :ele-clsql) +(asdf:operate 'asdf:load-op :ele-sqlite3) +(in-package "ELEPHANT-TESTS") +(setq *test-path-primary* '(:sqlite3 "testdb")) +(do-all-tests-spec *test-path-primary*) +@end lisp + +The file RUNTESTS.lisp, although possibly not exactly what you want, +contains useful example code. + +You can of course migrate between the three currently supported repository +strategies in any combination: BDB, Postgresql, and SQLite3. + +In all probability, other relational datbases would be very easy to +support but have not yet been tested. The basic pattern of +the ``path'' specifiers is (cons clsqal-database-type-symbol (normal-clsql-connection-specifier)). + +@node Repository Migration +@comment node-name, next, previous, up +@section Repository Migration + + +This version of Elephant supports migration betwen store controllers, +whether of the same implementation strategy or not. + +The tests @code{migrate1} - @code{migrate5} are demonstrations of this techinque. + +The functions for performing these migrations are: + +@code{migraten-pobj} + +The name of this function is meant to imply that it is +destructive of the object in question, mutating it to +point at the new repository. + +Which requies that you provide a copy-function to copy whatever +slots you want from the persistent object as deeply or as shallowly +as you desire. + +Data collections (btree's) can be move with the function: + +@code{migrate} + +A simple object that does not inherit from ``persistent'' but is +attached to a key (on the root) can be copied with the routine + +@code{copy-from-key} + +It is hoped that these routines would allow, with some labor, +a user to use one repository, and later decide to start using +a different implementation strategy, and easily migrate the +objects to the the new repository. The old repository could +then be abandoned, or multiple repositories could be used +at the same time. + + Index: elephant/doc/elephant.texinfo diff -u elephant/doc/elephant.texinfo:1.1 elephant/doc/elephant.texinfo:1.2 --- elephant/doc/elephant.texinfo:1.1 Sun Sep 19 19:44:43 2004 +++ elephant/doc/elephant.texinfo Wed Nov 23 18:51:34 2005 @@ -43,6 +43,7 @@ * Introduction:: Introducing Elephant! * Tutorial:: A leisurely walk-through. * Reference:: API documentation. +* SQL back-end:: CL-SQL based implementation * Design Notes:: Internals. * Copying:: Your rights and freedoms. * Concept Index:: @@ -56,6 +57,7 @@ @include tutorial.texinfo @include reference.texinfo @include notes.texinfo +@include sql-backend.texinfo @include copying.texinfo @node Concept Index Index: elephant/doc/make-ref.lisp diff -u elephant/doc/make-ref.lisp:1.1 elephant/doc/make-ref.lisp:1.2 --- elephant/doc/make-ref.lisp:1.1 Sun Sep 19 19:44:43 2004 +++ elephant/doc/make-ref.lisp Wed Nov 23 18:51:34 2005 @@ -1,7 +1,10 @@ (require 'asdf) (require 'elephant) -(load "docstrings.lisp") +(load "../docstrings.lisp") (defun make-docs () - (when (check-complete) - (sb-texinfo:generate-includes #p"includes" (find-package :ele)))) \ No newline at end of file +;; (when (check-complete) + (when t + (sb-texinfo:generate-includes #p"includes" (find-package :ele)))) + +(make-docs) Index: elephant/doc/reference.texinfo diff -u elephant/doc/reference.texinfo:1.1 elephant/doc/reference.texinfo:1.2 --- elephant/doc/reference.texinfo:1.1 Sun Sep 19 19:44:42 2004 +++ elephant/doc/reference.texinfo Wed Nov 23 18:51:34 2005 @@ -43,7 +43,7 @@ @include includes/var-elephant-star-auto-commit-star.texinfo @include includes/var-elephant-star-current-transaction-star.texinfo -@include includes/fun-elephant-start-transaction.texinfo +@include includes/fun-elephant-start-ele-transaction.texinfo @include includes/fun-elephant-commit-transaction.texinfo @include includes/fun-elephant-abort-transaction.texinfo

1 0

[elephant-cvs] CVS update: elephant/ele-bdb.asd elephant/ele-clsql.asd elephant/ele-sqlite3.asd elephant/CREDITS elephant/INSTALL elephant/Makefile elephant/NEWS elephant/TODO elephant/elephant-tests.asd elephant/elephant.asd
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv30677 Modified Files: CREDITS INSTALL Makefile NEWS TODO elephant-tests.asd elephant.asd Added Files: ele-bdb.asd ele-clsql.asd ele-sqlite3.asd Log Message: This is the big merger from the SQL-BACK-END branch. Date: Wed Nov 23 18:51:32 2005 Author: rread Index: elephant/ele-bdb.asd diff -u /dev/null elephant/ele-bdb.asd:1.2 --- /dev/null Wed Nov 23 18:51:32 2005 +++ elephant/ele-bdb.asd Wed Nov 23 18:51:31 2005 @@ -0,0 +1,59 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; ele-clsql.asd -- ASDF system definition for +;;; a CL-SQL based back-end for Elephant +;;; +;;; 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) 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 +;;; + +(defsystem ele-bdb + :name "ele-bdb" + :author "Robert L. Read <read(a)robertlread.net>" + :version "0.1" + :maintainer "Robert L. Read <read(a)robertlread.net>" + :licence "GPL" + :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!" + + :components + ((:module :src + :components + ((:file "bdb-enable") + ) + :serial t)) + :depends-on (:elephant )) Index: elephant/ele-clsql.asd diff -u /dev/null elephant/ele-clsql.asd:1.2 --- /dev/null Wed Nov 23 18:51:32 2005 +++ elephant/ele-clsql.asd Wed Nov 23 18:51:31 2005 @@ -0,0 +1,60 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; ele-clsql.asd -- ASDF system definition for +;;; a CL-SQL based back-end for Elephant +;;; +;;; 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) 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 +;;; + +(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>" + :licence "GPL" + :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)) + :depends-on (:elephant :clsql :cl-base64)) Index: elephant/ele-sqlite3.asd diff -u /dev/null elephant/ele-sqlite3.asd:1.2 --- /dev/null Wed Nov 23 18:51:32 2005 +++ elephant/ele-sqlite3.asd Wed Nov 23 18:51:31 2005 @@ -0,0 +1,59 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; ele-clsql.asd -- ASDF system definition for +;;; a CL-SQL based back-end for Elephant +;;; +;;; 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) 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 +;;; + +(defsystem ele-sqlite3 + :name "ele-sqlite3" + :author "Robert L. Read <read(a)robertlread.net>" + :version "0.1" + :maintainer "Robert L. Read <read(a)robertlread.net>" + :licence "GPL" + :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!" + + :components + ((:module :src + :components + ( + ) + :serial t)) + :depends-on (:elephant :clsql :cl-base64 :clsql-sqlite3)) Index: elephant/CREDITS diff -u elephant/CREDITS:1.5 elephant/CREDITS:1.6 --- elephant/CREDITS:1.5 Tue Oct 18 20:58:37 2005 +++ elephant/CREDITS Wed Nov 23 18:51:31 2005 @@ -2,8 +2,14 @@ Authors: Andrew Blumberg and Ben Lee <ablumberg(a)common-lisp.net> and <blee(a)common-lisp.net> +Current maintainer: Robert L. Read +<read(a)robertlread.net> + http://www.common-lisp.net/project/elephant + +The CL-SQL based backend was written by Robert L. Read. + Thanks to: Sleepycat for Berkeley DB, especially Ron Cohen and Michael @@ -38,4 +44,5 @@ Various other people whom I'm forgetting who answered my many idiotic questions -test +Dan Knapp fixed the fact that nil's were indistinguishable from +unbound slots, and proved the system works with SQLite3. Index: elephant/INSTALL diff -u elephant/INSTALL:1.11 elephant/INSTALL:1.12 --- elephant/INSTALL:1.11 Fri Oct 8 04:32:36 2004 +++ elephant/INSTALL Wed Nov 23 18:51:31 2005 @@ -3,8 +3,9 @@ Requirements ------------ -CMUCL 19a, SBCL 0.8.14, OpemMCL 0.14.2, or Allegro CL 6.2. -I've tested under x86 FreeBSD, Linux and PPC Darwin. I +CMUCL 19a, SBCL 0.9.5, OpemMCL 0.14.2, or Allegro CL 6.2. +This version ahs been tested under Linux and SBCL 0.9.5, but +Dan Knapp has also run something very closed under Darwin. can't personally test Win32 but I've compiled under Visual Studio .NET and a user has gotten it to work with Visual Studio 6. A Lispworks version will come if requested. @@ -12,6 +13,7 @@ ASDF - http://www.cliki.net/asdf UFFI 1.4.24+ - http://uffi.b9.com +(I have been testing with UFFI 1.5.4 and I recommend you use that.) I've patched src/functions.lisp to support some kinds of :out arguments. it is backwards-compatible so shouldn't @@ -19,11 +21,7 @@ 1.4.25+, but just in case you have 1.4.24 I have included it. -Sleepycat Berkeley DB 4.2 - http://www.sleepycat.com - -The version number is important -- the headers have changed -siginificantly. When 4.3 comes out, I'll have to reroll my -constants..... +Sleepycat Berkeley DB 4.3 - http://www.sleepycat.com A C compiler, probably gcc or Visual Studio. Presumably you have this if you installed Sleepycat. @@ -36,7 +34,7 @@ 0) Unpack Elephant. I put mine in the directory -/usr/local/share/common-lisp/elephant-0.1/ +/usr/local/share/common-lisp/elephant-0.3/ 1) Install UFFI. If you're using 1.4.24 replace @@ -44,18 +42,24 @@ with the provided file. -2) Install Berkeley DB 4.2. Under Un*x, you may actually +2) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. + +For relational database systems, refering the formal documentation +other the heading "SQL-BACK-END". + +For Berkeley 4.3: +Under Un*x, you may actually already have this installed, though it may be compiled with funny options, so if things don't work you may want to try to start from scratch. FreeBSD has a port for this, as I'm sure do other BSDs (including Darwin/Fink.) Take note of where libdb.so and db.h are installed (usually -/usr/local/BerekleyDB.4.2/lib/libdb.so and -/usr/local/BerekleyDB.4.2/include/db.h, or +/usr/local/BerekleyDB.4.3/lib/libdb.so and +/usr/local/BerekleyDB.4.3/include/db.h, or /usr/local/lib/db42/libdb.so and /usr/local/include/db42/db.h.) -3) Compile and install the libsleepycat shared library. +Compile and install the libsleepycat shared library. Under Un*x, edit Makefile and run (using GNU make, gmake on BSD) @@ -64,15 +68,26 @@ This compiles src/libsleepycat.c and installs it into -/usr/local/share/common-lisp/elephant-0.2/ +/usr/local/share/common-lisp/elephant-0.3/ + +You probably have to make sure this directory exists before running +make install. + +If you need to change this path, you will change it in the Makefile +and also in controller.lisp on the line: + +(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant-0.3/") or where you specified. On Darwin / OS X you need to have -the developer tools installed. +the developer tools installed. In the Makefile and other places +there are commented-out lines showing settings that some users have used for +OS X; if you are using that I assume you will have to comment out the +appropriate lines and uncomment those examples. For Win32 (directions courtesy of Bill Clementson): Create an MSVC dll project and add src/libsleepycat.c, -src/libsleepycat.def and the Berkeley DB libdb42.lib files +src/libsleepycat.def and the Berkeley DB libdb43.lib files to the project (should be in the build_win32/release folder) Add the Berkeley DB dbinc include files directory and the @@ -82,11 +97,11 @@ Build the Elephant DLL file -Since you've statically included libdb42.lib inside +Since you've statically included libdb43.lib inside libsleepycat.c, it may or may not be necessary to load -libdb42.dll into Lisp (see below.) +libdb43.dll into Lisp (see below.) -4) Compile and load Elephant: +3) Compile and load Elephant: First, edit src/sleepycat.lisp so that it points to the correct libraries. If you're using Un*x and ASDF, this is @@ -110,6 +125,9 @@ ----------- Quick Start ----------- +(These instructions were correct for Elephant 0.2. They +are now somewhat obsolete in Elephant 0.3; better information +can be found in the formal documentation.) For more complete documentation see TUTORIAL and NOTES. But a REPL session is worth a thousand words, so ... Index: elephant/Makefile diff -u elephant/Makefile:1.6 elephant/Makefile:1.7 --- elephant/Makefile:1.6 Thu Feb 24 02:06:20 2005 +++ elephant/Makefile Wed Nov 23 18:51:31 2005 @@ -7,9 +7,16 @@ SHELL=/bin/sh UNAME:=$(shell uname -s) -DB43DIR=/db/ben/lisp/db43 +# DB43DIR=/db/ben/lisp/db43 +# Dan Knapp contributed this line, which came form OS X? +#DB43DIR=/sw +# But I will assume that Linux is more common? +DB43DIR=/usr/local/BerkeleyDB.4.3/ + DBLIBDIR=$(DB43DIR)/lib/ DBINCDIR=$(DB43DIR)/include/ +# Dan Knapp contributed this line; for fink/OS X? +#DBINCDIR=$(DB43DIR)/include/db4/ # *BSD users will probably want #DBLIBDIR=/usr/local/lib/db43 @@ -21,6 +28,12 @@ SHARED=-shared endif -libsleepycat.so: src/libsleepycat.c - gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm +all: libsleepycat.so libmemutil.so + +libmemutil.so: src/libmemutil.c + gcc $(SHARED) -Wall -fPIC -O3 -o $@ $< -lm + +libsleepycat.so: src/libsleepycat.c + gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm + Index: elephant/NEWS diff -u elephant/NEWS:1.6 elephant/NEWS:1.7 --- elephant/NEWS:1.6 Fri Oct 8 02:53:04 2004 +++ elephant/NEWS Wed Nov 23 18:51:31 2005 @@ -1,3 +1,8 @@ +November 30, 2005 - Elephant 0.3.0 released by +the new maintainer, Robert L. Read, providing +support for relational database backends, repository +migration, and multi-repository operation. + October 7, 2004 - Elephant 0.2.1 released. Thanks to Bill Clementson, Index: elephant/TODO diff -u elephant/TODO:1.7 elephant/TODO:1.8 --- elephant/TODO:1.7 Tue Sep 21 21:34:37 2004 +++ elephant/TODO Wed Nov 23 18:51:31 2005 @@ -1,5 +1,20 @@ Merge in the todos from the source and the NOTES! +October 19, 2005 + +The SQL back-end stuff has only been tested with +Postgress and SBCL. + +Using SQLite and mysql would really expand the +usage of the system, I assume. + +The database-stuff is fairly slow since it +does normal serialization and then Base64 encoding. +This is very safe and simple, but costs us a lot of bytes +to and from the database; a better serializer would +make things MUCH faster. + + new counters in 4.3 (october) understand the profiler / timer, tweak performance of CLOS Index: elephant/elephant-tests.asd diff -u elephant/elephant-tests.asd:1.3 elephant/elephant-tests.asd:1.4 --- elephant/elephant-tests.asd:1.3 Thu Feb 24 02:07:55 2005 +++ elephant/elephant-tests.asd Wed Nov 23 18:51:31 2005 @@ -58,6 +58,7 @@ (:file "mop-tests") (:file "testcollections") (:file "testsleepycat") + (:file "testmigration") ) :serial t))) - \ No newline at end of file + Index: elephant/elephant.asd diff -u elephant/elephant.asd:1.7 elephant/elephant.asd:1.8 --- elephant/elephant.asd:1.7 Thu Feb 24 02:07:54 2005 +++ elephant/elephant.asd Wed Nov 23 18:51:31 2005 @@ -60,8 +60,8 @@ (:file "cmu-mop-patches") (:file "metaclasses") (:file "classes") - (:file "collections") (:file "controller") + (:file "collections") (:file "serializer")) :serial t)) :depends-on (:uffi))

1 0

[elephant-cvs] CVS update: elephant/tests/testsleepycat/README
by rread＠common-lisp.net 23 Nov '05

23 Nov '05

Update of /project/elephant/cvsroot/elephant/tests/testsleepycat In directory common-lisp.net:/tmp/cvs-serv30609/tests/testsleepycat Added Files: Tag: SQL-BACK-END README Log Message: Just a README in this directory. Date: Wed Nov 23 18:48:25 2005 Author: rread

1 0