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

[elephant-cvs] CVS update: elephant/CREDITS elephant/TODO
by rread＠common-lisp.net 19 Oct '05

19 Oct '05

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv27977 Modified Files: Tag: SQL-BACK-END CREDITS TODO Log Message: Minor changes to the credits file. Date: Wed Oct 19 17:24:51 2005 Author: rread Index: elephant/CREDITS diff -u elephant/CREDITS:1.4.2.1 elephant/CREDITS:1.4.2.2 --- elephant/CREDITS:1.4.2.1 Tue Oct 18 22:00:44 2005 +++ elephant/CREDITS Wed Oct 19 17:24:50 2005 @@ -2,7 +2,13 @@ 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: Index: elephant/TODO diff -u elephant/TODO:1.7 elephant/TODO:1.7.2.1 --- elephant/TODO:1.7 Tue Sep 21 21:34:37 2004 +++ elephant/TODO Wed Oct 19 17:24:51 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

1 0

[elephant-cvs] CVS update: elephant/doc/includes/Marker-for-directory.txt
by rread＠common-lisp.net 19 Oct '05

19 Oct '05

Update of /project/elephant/cvsroot/elephant/doc/includes In directory common-lisp.net:/tmp/cvs-serv21790/includes Added Files: Tag: SQL-BACK-END Marker-for-directory.txt Log Message: Adding this file just to make the directory come out Date: Wed Oct 19 15:56:53 2005 Author: rread

1 0

[elephant-cvs] CVS update: Directory change: elephant/doc/includes
by rread＠common-lisp.net 19 Oct '05

19 Oct '05

Update of /project/elephant/cvsroot/elephant/doc/includes In directory common-lisp.net:/tmp/cvs-serv21688/includes Log Message: Directory /project/elephant/cvsroot/elephant/doc/includes added to the repository --> Using per-directory sticky tag `SQL-BACK-END' Date: Wed Oct 19 15:51:10 2005 Author: rread New directory elephant/doc/includes added

1 0

[elephant-cvs] CVS update: elephant/doc/Makefile elephant/doc/make-ref.lisp
by rread＠common-lisp.net 19 Oct '05

19 Oct '05

Update of /project/elephant/cvsroot/elephant/doc In directory common-lisp.net:/tmp/cvs-serv18583 Modified Files: Tag: SQL-BACK-END make-ref.lisp Added Files: Tag: SQL-BACK-END Makefile Log Message: Adding not-very-good Makefile to build documentation from texinfo source Date: Wed Oct 19 15:19:03 2005 Author: rread Index: elephant/doc/make-ref.lisp diff -u elephant/doc/make-ref.lisp:1.1.2.1 elephant/doc/make-ref.lisp:1.1.2.2 --- elephant/doc/make-ref.lisp:1.1.2.1 Tue Oct 18 22:41:25 2005 +++ elephant/doc/make-ref.lisp Wed Oct 19 15:19:03 2005 @@ -1,7 +1,10 @@ (require 'asdf) (require 'elephant) -(load "docstrings.lisp") +(load "../docstrings.lisp") (defun make-docs () - (when (check-complete) +;; (when (check-complete) + (when t (sb-texinfo:generate-includes #p"includes" (find-package :ele)))) + +(make-docs)

1 0

[elephant-cvs] CVS update: Directory change: elephant/tests/testsleepycat
by rread＠common-lisp.net 19 Oct '05

19 Oct '05

Update of /project/elephant/cvsroot/elephant/tests/testsleepycat In directory common-lisp.net:/tmp/cvs-serv17499/testsleepycat Log Message: Directory /project/elephant/cvsroot/elephant/tests/testsleepycat added to the repository --> Using per-directory sticky tag `SQL-BACK-END' Date: Wed Oct 19 14:51:02 2005 Author: rread New directory elephant/tests/testsleepycat added

1 0

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

18 Oct '05

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv16451/tests Modified Files: Tag: SQL-BACK-END elephant-tests.lisp mop-tests.lisp testcollections.lisp testserializer.lisp Log Message: Differences of existing files based on sql-back-end work Date: Tue Oct 18 22:41:33 2005 Author: rread Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.5 elephant/tests/elephant-tests.lisp:1.5.2.1 --- elephant/tests/elephant-tests.lisp:1.5 Thu Feb 24 02:07:51 2005 +++ elephant/tests/elephant-tests.lisp Tue Oct 18 22:41:32 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,35 @@ ;;"/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* +'("localhost.localdomain" "test" "postgres" "")) + (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 +159,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.7.2.1 --- elephant/tests/mop-tests.lisp:1.7 Thu Feb 24 02:07:51 2005 +++ elephant/tests/mop-tests.lisp Tue Oct 18 22:41:32 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.3.2.1 --- elephant/tests/testcollections.lisp:1.3 Thu Feb 24 02:06:05 2005 +++ elephant/tests/testcollections.lisp Tue Oct 18 22:41:32 2005 @@ -1,12 +1,32 @@ (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 + (if (typep *store-controller* 'sql-store-controller) + *testpg-path* + *testdb-path*)))) + (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 +44,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 @@ -49,7 +75,8 @@ (defvar first-key (first keys)) (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 +93,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 +109,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 +144,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 +159,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 +196,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 +210,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 +227,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 +240,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 +249,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 +258,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 +267,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 +276,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 +285,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 +294,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 +302,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 +379,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 +398,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 +413,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 +424,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 +434,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 +443,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 +452,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 +495,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 +513,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 +567,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 +585,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 +607,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.6.2.1 --- elephant/tests/testserializer.lisp:1.6 Thu Feb 24 02:06:05 2005 +++ elephant/tests/testserializer.lisp Tue Oct 18 22:41:32 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/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 18 Oct '05

18 Oct '05

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv16451/src Modified Files: Tag: SQL-BACK-END classes.lisp collections.lisp controller.lisp elephant.lisp libsleepycat.c metaclasses.lisp serializer.lisp sleepycat.lisp utils.lisp Log Message: Differences of existing files based on sql-back-end work Date: Tue Oct 18 22:41:27 2005 Author: rread Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.13 elephant/src/classes.lisp:1.13.2.1 --- elephant/src/classes.lisp:1.13 Thu Feb 24 02:07:52 2005 +++ elephant/src/classes.lisp Tue Oct 18 22:41:27 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.11.2.1 --- elephant/src/collections.lisp:1.11 Sat Sep 25 20:57:37 2004 +++ elephant/src/collections.lisp Tue Oct 18 22:41:27 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.12.2.1 --- elephant/src/controller.lisp:1.12 Thu Feb 24 02:06:10 2005 +++ elephant/src/controller.lisp Tue Oct 18 22:41:27 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.2/") + +(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.14.2.1 --- elephant/src/elephant.lisp:1.14 Thu Feb 24 02:07:52 2005 +++ elephant/src/elephant.lisp Tue Oct 18 22:41:27 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.11.2.1 --- elephant/src/libsleepycat.c:1.11 Thu Feb 24 02:04:13 2005 +++ elephant/src/libsleepycat.c Tue Oct 18 22:41:27 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.7.2.1 --- elephant/src/metaclasses.lisp:1.7 Thu Feb 24 02:07:52 2005 +++ elephant/src/metaclasses.lisp Tue Oct 18 22:41:27 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 (: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 list :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.10.2.1 --- elephant/src/serializer.lisp:1.10 Thu Feb 24 02:06:10 2005 +++ elephant/src/serializer.lisp Tue Oct 18 22:41:27 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,21 @@ (let* ((id (buffer-read-fixnum bs)) (maybe-o (gethash id *circularity-hash*))) (if maybe-o maybe-o - (let ((o (make-instance (%deserialize bs)))) + (let ((typedesig (%deserialize bs))) + ;; now, depending on what typedesig is, we might + ;; or might not need to specify the store controller here.. + (let ((o + (if (subtypep typedesig 'persistent) + (make-instance typedesig :sc sc) + (make-instance typedesig) + ) + )) (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)))) + o))))) ((= tag +array+) (let* ((id (buffer-read-fixnum bs)) (maybe-array (gethash id *circularity-hash*))) @@ -464,3 +473,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.13.2.1 --- elephant/src/sleepycat.lisp:1.13 Thu Feb 24 02:06:09 2005 +++ elephant/src/sleepycat.lisp Tue Oct 18 22:41:27 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." Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.8 elephant/src/utils.lisp:1.8.2.1 --- elephant/src/utils.lisp:1.8 Thu Feb 24 02:06:08 2005 +++ elephant/src/utils.lisp Tue Oct 18 22:41:27 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/elephant.texinfo elephant/doc/make-ref.lisp elephant/doc/reference.texinfo
by rread＠common-lisp.net 18 Oct '05

18 Oct '05

Update of /project/elephant/cvsroot/elephant/doc In directory common-lisp.net:/tmp/cvs-serv16451/doc Modified Files: Tag: SQL-BACK-END elephant.texinfo make-ref.lisp reference.texinfo Log Message: Differences of existing files based on sql-back-end work Date: Tue Oct 18 22:41:25 2005 Author: rread Index: elephant/doc/elephant.texinfo diff -u elephant/doc/elephant.texinfo:1.1 elephant/doc/elephant.texinfo:1.1.2.1 --- elephant/doc/elephant.texinfo:1.1 Sun Sep 19 19:44:43 2004 +++ elephant/doc/elephant.texinfo Tue Oct 18 22:41:25 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.1.2.1 --- elephant/doc/make-ref.lisp:1.1 Sun Sep 19 19:44:43 2004 +++ elephant/doc/make-ref.lisp Tue Oct 18 22:41:25 2005 @@ -4,4 +4,4 @@ (defun make-docs () (when (check-complete) - (sb-texinfo:generate-includes #p"includes" (find-package :ele)))) \ No newline at end of file + (sb-texinfo:generate-includes #p"includes" (find-package :ele)))) Index: elephant/doc/reference.texinfo diff -u elephant/doc/reference.texinfo:1.1 elephant/doc/reference.texinfo:1.1.2.1 --- elephant/doc/reference.texinfo:1.1 Sun Sep 19 19:44:42 2004 +++ elephant/doc/reference.texinfo Tue Oct 18 22:41:25 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/Makefile elephant/elephant-tests.asd elephant/elephant.asd
by rread＠common-lisp.net 18 Oct '05

18 Oct '05

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv16451 Modified Files: Tag: SQL-BACK-END Makefile elephant-tests.asd elephant.asd Log Message: Differences of existing files based on sql-back-end work Date: Tue Oct 18 22:41:24 2005 Author: rread Index: elephant/Makefile diff -u elephant/Makefile:1.6 elephant/Makefile:1.6.2.1 --- elephant/Makefile:1.6 Thu Feb 24 02:06:20 2005 +++ elephant/Makefile Tue Oct 18 22:41:24 2005 @@ -7,7 +7,8 @@ SHELL=/bin/sh UNAME:=$(shell uname -s) -DB43DIR=/db/ben/lisp/db43 +# DB43DIR=/db/ben/lisp/db43 +DB43DIR=/usr/local/BerkeleyDB.4.3/ DBLIBDIR=$(DB43DIR)/lib/ DBINCDIR=$(DB43DIR)/include/ @@ -21,6 +22,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/elephant-tests.asd diff -u elephant/elephant-tests.asd:1.3 elephant/elephant-tests.asd:1.3.2.1 --- elephant/elephant-tests.asd:1.3 Thu Feb 24 02:07:55 2005 +++ elephant/elephant-tests.asd Tue Oct 18 22:41:24 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.7.2.1 --- elephant/elephant.asd:1.7 Thu Feb 24 02:07:54 2005 +++ elephant/elephant.asd Tue Oct 18 22:41:24 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/testmigration.lisp
by rread＠common-lisp.net 18 Oct '05

18 Oct '05

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv16315/tests Added Files: Tag: SQL-BACK-END testmigration.lisp Log Message: Initial checkin of the SQL-BACK-END files Date: Tue Oct 18 22:35:54 2005 Author: rread

1 0