From ieslick at common-lisp.net Thu Feb 2 21:48:38 2006 From: ieslick at common-lisp.net (ieslick) Date: Thu, 2 Feb 2006 15:48:38 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060202214838.DF5851C6FF@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv6576 Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN elephant-tests.asd Log Message: There may be a bug or two left, but the major locking problems have been resolved. Interactions due to reconnecting to databases can be problematic (i.e. indexing a new object when a cursor is walking the indices for that object leads to deadlock in the bdb code where the cursor has a read lock on an index that the persistent indexing wanted to write) More tests needed, but the system appears largely stable now. --- /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/01/30 04:54:59 1.4.2.2 +++ /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/02/02 21:48:38 1.4.2.3 @@ -55,9 +55,9 @@ :components ((:file "elephant-tests") (:file "testserializer") + (:file "testsleepycat") (:file "mop-tests") (:file "testcollections") - (:file "testsleepycat") (:file "testindexing") (:file "testmigration") ) From ieslick at common-lisp.net Thu Feb 2 21:48:39 2006 From: ieslick at common-lisp.net (ieslick) Date: Thu, 2 Feb 2006 15:48:39 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060202214839.4533A1C6FF@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv6576/src Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN IAN-TODO classes.lisp controller.lisp index-utils.lisp indexing.lisp Log Message: There may be a bug or two left, but the major locking problems have been resolved. Interactions due to reconnecting to databases can be problematic (i.e. indexing a new object when a cursor is walking the indices for that object leads to deadlock in the bdb code where the cursor has a read lock on an index that the persistent indexing wanted to write) More tests needed, but the system appears largely stable now. --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/30 04:55:00 1.16.2.5 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/02 21:48:38 1.16.2.6 @@ -79,20 +79,30 @@ metaclass.") (:metaclass persistent-metaclass)) -(defmethod initialize-instance ((instance persistent-object) &rest initargs) +;;(defmethod print-object ((obj persistent) stream) + +(defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys) (declare (ignore initargs)) (if (indexed (class-of instance)) - (progn - (inhibit-indexing (oid instance)) - (unwind-protect - (progn - (call-next-method) - (uninhibit-indexing (oid instance)) - (let ((class-index (find-class-index (class-of instance)))) - (with-transaction () - (setf (get-value (oid instance) class-index) instance)))) - (uninhibit-indexing (oid instance)))) - (call-next-method))) + (progn + (let ((oid (oid instance))) + (declare (type fixnum oid)) + (inhibit-indexing oid) + (unwind-protect + (call-next-method) + (uninhibit-indexing oid)) + ;; Inhibit indexing if the object already was defined (ie being created from an oid) + ;; as it should be indexed already. This hack avoids a deadlock situation where we + ;; write the class or index page that we are currently reading via a cursor without + ;; going through the cursor abstraction. There has to be a better way to do this. + (when (not from-oid) + (let ((class-index (find-class-index (class-of instance)))) + (when class-index +;; (format t "Indexing initial instance: ~A :: ~A~%" oid instance) + (with-transaction () + (setf (get-value oid class-index) instance))))))) + ;; else + (call-next-method))) (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/29 04:57:20 1.14.2.2 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/02 21:48:38 1.14.2.3 @@ -56,15 +56,17 @@ ) (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)) - )) + (let ((cached-sc (gethash spec *dbconnection-spec*))) + (if cached-sc cached-sc + (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 () @@ -359,7 +361,7 @@ (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) ;; clean instance cache - (setf (instance-cache sc) (make-cache-table :test 'eql)) + (reset-instance-cache sc) ;; close handles / environment (db-sequence-close (controller-oid-seq sc)) (setf (controller-oid-seq sc) nil) @@ -375,7 +377,10 @@ (setf (controller-db sc) nil) (db-env-close (controller-environment sc)) (setf (controller-environment sc) nil) - nil)) + nil) + ;; Delete connection spec so object ops on cached db info fail + (remhash (controller-path *store-controller*) *dbconnection-spec*)) + ;; Do these things need to take &rest arguments? (defmethod build-btree ((sc bdb-store-controller)) @@ -426,23 +431,25 @@ the controller unconditionally on exit." `(unwind-protect (progn - (let (*store-controller* (open-controller ,sc)) + (let ((*store-controller* (open-controller ,sc))) (declare (special *store-controller*)) , at body)) (close-controller ,sc))) (defun close-store () "Conveniently close the store controller." + (declare (special *store-controller*)) (if *store-controller* - (close-controller *store-controller*))) + (progn + (close-controller *store-controller*) + (setf *store-controller* nil)))) (defmacro with-open-store ((spec) &body body) "Executes the body with an open controller, unconditionally closing the controller on exit." - `(let ((*store-controller* - (get-controller ,spec))) + `(let ((*store-controller* (get-controller ,spec))) (declare (special *store-controller*)) -;; (open-controller *store-controller*) + (open-controller *store-controller*) (unwind-protect (progn , at body) (close-controller *store-controller*)))) From ieslick at common-lisp.net Thu Feb 2 21:48:39 2006 From: ieslick at common-lisp.net (ieslick) Date: Thu, 2 Feb 2006 15:48:39 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060202214839.8AC961C6FF@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv6576/tests Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN elephant-tests.lisp testindexing.lisp Log Message: There may be a bug or two left, but the major locking problems have been resolved. Interactions due to reconnecting to databases can be problematic (i.e. indexing a new object when a cursor is walking the indices for that object leads to deadlock in the bdb code where the cursor has a read lock on an index that the persistent indexing wanted to write) More tests needed, but the system appears largely stable now. --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/01/30 04:55:00 1.7.2.3 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/02 21:48:39 1.7.2.4 @@ -127,10 +127,11 @@ (do-all-tests-spec *testsqlite3-path*) )) -(defun do-all-tests-spec(spec) +(defun do-all-tests-spec (spec) (when spec (with-open-store (spec) (let ((*auto-commit* nil)) + (declare (special *auto-commit*)) (do-tests))))) (defun do-test-spec (testname &optional (spec *testdb-path*)) @@ -141,14 +142,21 @@ (do-test testname))))) (defun do-indexing-tests () - (setf *old-store* *store-controller*) - (open-store *testdb-path*) - (print (do-test 'indexing-basic)) - (print (do-test 'indexing-inherit)) - (print (do-test 'indexing-range)) - (print (do-test 'indexing-reconnect-db)) - (close-store) - (setf *store-controller* *old-store*)) + (declare (special *old-store*)) + (setq *old-store* *store-controller*) + (unwind-protect + (progn + (open-store *testdb-path*) + (print (do-test 'indexing-basic)) + (print (do-test 'indexing-inherit)) + (print (do-test 'indexing-range)) + (print (do-test 'indexing-reconnect-db)) + (print (do-test 'indexing-change-class)) + (print (do-test 'indexing-redef-class)) + (print (do-test 'indexing-explicit-changes)) + (print (do-test 'indexing-timing)) + (close-store)) + (setq *store-controller* *old-store*))) (defun do-crazy-pg-tests() (open-store *testpg-path*) From ieslick at common-lisp.net Fri Feb 3 04:19:44 2006 From: ieslick at common-lisp.net (ieslick) Date: Thu, 2 Feb 2006 22:19:44 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060203041944.886DF3686E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv4342/src Added Files: Tag: ELEPHANT-0-4-1-rc1-IAN index-tutorial.lisp Log Message: Simple persistent log tutorial template in src. From rread at common-lisp.net Sat Feb 4 20:34:04 2006 From: rread at common-lisp.net (rread) Date: Sat, 4 Feb 2006 14:34:04 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests/testsleepycat Message-ID: <20060204203404.42DB82A031@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests/testsleepycat In directory common-lisp:/tmp/cvs-serv18077/testsleepycat Added Files: PLACEHOLDER.txt Log Message: This directory used for some initial tests. --- /project/elephant/cvsroot/elephant/tests/testsleepycat/PLACEHOLDER.txt 2006/02/04 20:34:04 NONE +++ /project/elephant/cvsroot/elephant/tests/testsleepycat/PLACEHOLDER.txt 2006/02/04 20:34:04 1.1 From rread at common-lisp.net Sat Feb 4 20:34:04 2006 From: rread at common-lisp.net (rread) Date: Sat, 4 Feb 2006 14:34:04 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060204203404.662D32A035@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv18077 Modified Files: testcollections.lisp testmigration.lisp Log Message: This directory used for some initial tests. --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/01/25 15:36:32 1.7 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/04 20:34:02 1.8 @@ -713,3 +713,20 @@ ;; (equal (get-value 10 ibt) 4))) ;; ) ;; t) + + + +;; (deftest class-change-deletion +;; (progn +;; (defclass blob-tbc () +;; ((slot1 :accessor slot1 :initarg :slot1) +;; (slot2 :accessor slot2 :initarg :slot2))) +;; (add-to-root "blob" (make-instance 'blob-tbc)) +;; (defclass blob-tbc () +;; ((slot1 :accessor slot1 :initarg :slot1) +;; (slot3 :accessor slot3 :initarg :slot3))) +;; (remove-from-root "blob") +;; (get-from-root "blob") +;; ) +;; nil nil) + --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/01/24 18:25:01 1.3 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/04 20:34:02 1.4 @@ -156,46 +156,38 @@ (progn (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.") t) - (finishes - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t)) - (unwind-protect - (let ((osc (if (subtypep (type-of *store-controller*) 'sql-store-controller) - (open-store *test-path-primary*) - (open-store *test-path-secondary*) - ))) -;; really need to test the an error is thrown when attempting to migrate -;; non-persistent object! - (let* ((f1 (make-instance 'pfoo :sc *store-controller*)) - (f2 (make-instance 'pfoo :slot1 "this is a string" :sc *store-controller*)) - (b1 (make-instance 'pbar :slot2 "another string" :sc *store-controller*)) - ) - (let ((fm1 - (ele::migraten-pobj - osc f1 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) - (fm2 - (ele::migraten-pobj - osc f2 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) - (bm1 (ele::migraten-pobj - osc b1 - #'(lambda (dst src) - (if (slot-boundp src 'slot2) - (setf (slot2 dst) (slot2 src)))))) - ) - (and - (and (not (slot-boundp fm1 'slot1)) - (not (slot-boundp f1 'slot1))) - (equal (slot1 fm2) (slot1 f2)) - (equal (slot2 bm1) (slot2 b1)))))) - (progn - (setq *store-controller* old-store) + (let ((*prev-commit* *auto-commit*)) + (prog2 + (setq *auto-commit* t) + (let ( + (sc1 (open-store *test-path-primary*)) + (sc2 (open-store *test-path-secondary*))) + (let* ((f1 (make-instance 'pfoo :sc sc1)) + (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) + (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) + ) + (let ((fm1 + (ele::migraten-pobj + sc2 f1 + #'(lambda (dst src) + (if (slot-boundp src 'slot1) + (setf (slot1 dst) (slot1 src)))))) + (fm2 + (ele::migraten-pobj + sc2 f2 + #'(lambda (dst src) + (if (slot-boundp src 'slot1) + (setf (slot1 dst) (slot1 src)))))) + (bm1 (ele::migraten-pobj + sc2 b1 + #'(lambda (dst src) + (if (slot-boundp src 'slot2) + (setf (slot2 dst) (slot2 src)))))) + ) + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 bm1) (slot2 b1)))))) (setq *auto-commit* *prev-commit*)))) - )) - t) + t) From rread at common-lisp.net Sat Feb 4 22:25:09 2006 From: rread at common-lisp.net (rread) Date: Sat, 4 Feb 2006 16:25:09 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060204222509.83AFD2A035@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv456 Modified Files: LICENSE TODO ele-bdb.asd ele-clsql.asd elephant.asd Log Message: Mostly changing to LLGPL --- /project/elephant/cvsroot/elephant/LICENSE 2004/09/19 17:37:25 1.3 +++ /project/elephant/cvsroot/elephant/LICENSE 2006/02/04 22:25:09 1.4 @@ -2,380 +2,21 @@ Copyright (c) 2004 by Andrew Blumberg and Ben Lee +Some parts Copyright (c) 2005,2006 Robert L. Read +. -This program is released under the following license -("GPL"). For differenct licensing terms, contact the -copyright holders. +Elephant users are granted the rights to distribute and use this software +as governed by the terms of the Lisp Lesser GNU Public License +(http://opensource.franz.com/preamble.html), also known as the LLGPL. + +This preamble, (which I have not included here, as it is copyrighted +by Franz, Incorporated), references the GNU LESSER GENERAL PUBLIC LICENSE +although the preamble makes certain modifications to it that are often +thought of as particularly appropriate for LISP. + +Version of Elephant before version 0.5.0 where released under GPL. +With the permission of Andrew Blumberg, Ben Lee and Robert L. Read, +the primary contributors of elephant code up until this time, the +0.5.0 release is made under the LLGPL. -Portions of this program (namely the C unicode string -sorter) are derived from IBM's ICU: - -http://oss.software.ibm.com/icu/ - -whose copyright and license follows the GPL below. - -The GNU General Public License (GPL) -Version 2, June 1991 - -Copyright (C) 1989, 1991 Free Software Foundation, Inc. -59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - -Everyone is permitted to copy and distribute verbatim copies -of this license document, but changing it is not allowed. - -Preamble - -The licenses for most software are designed to take away -your freedom to share and change it. By contrast, the GNU -General Public License is intended to guarantee your freedom -to share and change free software--to make sure the software -is free for all its users. This General Public License -applies to most of the Free Software Foundation's software -and to any other program whose authors commit to using -it. (Some other Free Software Foundation software is covered -by the GNU Library General Public License instead.) You can -apply it to your programs, too. - -When we speak of free software, we are referring to freedom, -not price. Our General Public Licenses are designed to make -sure that you have the freedom to distribute copies of free -software (and charge for this service if you wish), that you -receive source code or can get it if you want it, that you -can change the software or use pieces of it in new free -programs; and that you know you can do these things. - -To protect your rights, we need to make restrictions that -forbid anyone to deny you these rights or to ask you to -surrender the rights. These restrictions translate to -certain responsibilities for you if you distribute copies of -the software, or if you modify it. - -For example, if you distribute copies of such a program, -whether gratis or for a fee, you must give the recipients -all the rights that you have. You must make sure that they, -too, receive or can get the source code. And you must show -them these terms so they know their rights. - -We protect your rights with two steps: (1) copyright the -software, and (2) offer you this license which gives you -legal permission to copy, distribute and/or modify the -software. - -Also, for each author's protection and ours, we want to make -certain that everyone understands that there is no warranty -for this free software. If the software is modified by -someone else and passed on, we want its recipients to know -that what they have is not the original, so that any -problems introduced by others will not reflect on the -original authors' reputations. - -Finally, any free program is threatened constantly by -software patents. We wish to avoid the danger that -redistributors of a free program will individually obtain -patent licenses, in effect making the program -proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not -licensed at all. - -The precise terms and conditions for copying, distribution -and modification follow. - -TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - -0. This License applies to any program or other work which -contains a notice placed by the copyright holder saying it -may be distributed under the terms of this General Public -License. The "Program", below, refers to any such program or -work, and a "work based on the Program" means either the -Program or any derivative work under copyright law: that is -to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into -another language. (Hereinafter, translation is included -without limitation in the term "modification".) Each -licensee is addressed as "you". - -Activities other than copying, distribution and modification -are not covered by this License; they are outside its -scope. The act of running the Program is not restricted, and -the output from the Program is covered only if its contents -constitute a work based on the Program (independent of -having been made by running the Program). Whether that is -true depends on what the Program does. - -1. You may copy and distribute verbatim copies of the -Program's source code as you receive it, in any medium, -provided that you conspicuously and appropriately publish on -each copy an appropriate copyright notice and disclaimer of -warranty; keep intact all the notices that refer to this -License and to the absence of any warranty; and give any -other recipients of the Program a copy of this License along -with the Program. - -You may charge a fee for the physical act of transferring a -copy, and you may at your option offer warranty protection -in exchange for a fee. - -2. You may modify your copy or copies of the Program or any -portion of it, thus forming a work based on the Program, and -copy and distribute such modifications or work under the -terms of Section 1 above, provided that you also meet all of -these conditions: - - a) You must cause the modified files to carry prominent -notices stating that you changed the files and the date of -any change. - - b) You must cause any work that you distribute or -publish, that in whole or in part contains or is derived -from the Program or any part thereof, to be licensed as a -whole at no charge to all third parties under the terms of -this License. - - c) If the modified program normally reads commands -interactively when run, you must cause it, when started -running for such interactive use in the most ordinary way, -to print or display an announcement including an appropriate -copyright notice and a notice that there is no warranty (or -else, saying that you provide a warranty) and that users may -redistribute the program under these conditions, and telling -the user how to view a copy of this License. (Exception: if -the Program itself is interactive but does not normally -print such an announcement, your work based on the Program -is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the -Program, and can be reasonably considered independent and -separate works in themselves, then this License, and its -terms, do not apply to those sections when you distribute -them as separate works. But when you distribute the same -sections as part of a whole which is a work based on the -Program, the distribution of the whole must be on the terms -of this License, whose permissions for other licensees -extend to the entire whole, and thus to each and every part -regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights -or contest your rights to work written entirely by you; -rather, the intent is to exercise the right to control the -distribution of derivative or collective works based on the -Program. - -In addition, mere aggregation of another work not based on -the Program with the Program (or with a work based on the -Program) on a volume of a storage or distribution medium -does not bring the other work under the scope of this -License. - -3. You may copy and distribute the Program (or a work based -on it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you -also do one of the following: - - a) Accompany it with the complete corresponding -machine-readable source code, which must be distributed -under the terms of Sections 1 and 2 above on a medium -customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least -three years, to give any third party, for a charge no more -than your cost of physically performing source distribution, -a complete machine-readable copy of the corresponding source -code, to be distributed under the terms of Sections 1 and 2 -above on a medium customarily used for software interchange; -or, - - c) Accompany it with the information you received as to -the offer to distribute corresponding source code. (This -alternative is allowed only for noncommercial distribution -and only if you received the program in object code or -executable form with such an offer, in accord with -Subsection b above.) - -The source code for a work means the preferred form of the -work for making modifications to it. For an executable work, -complete source code means all the source code for all -modules it contains, plus any associated interface -definition files, plus the scripts used to control -compilation and installation of the executable. However, as -a special exception, the source code distributed need not -include anything that is normally distributed (in either -source or binary form) with the major components (compiler, -kernel, and so on) of the operating system on which the -executable runs, unless that component itself accompanies -the executable. - -If distribution of executable or object code is made by -offering access to copy from a designated place, then -offering equivalent access to copy the source code from the -same place counts as distribution of the source code, even -though third parties are not compelled to copy the source -along with the object code. - -4. You may not copy, modify, sublicense, or distribute the -Program except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense or distribute -the Program is void, and will automatically terminate your -rights under this License. However, parties who have -received copies, or rights, from you under this License will -not have their licenses terminated so long as such parties -remain in full compliance. - -5. You are not required to accept this License, since you -have not signed it. However, nothing else grants you -permission to modify or distribute the Program or its -derivative works. These actions are prohibited by law if you -do not accept this License. Therefore, by modifying or -distributing the Program (or any work based on the Program), -you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or -modifying the Program or works based on it. - -6. Each time you redistribute the Program (or any work based -on the Program), the recipient automatically receives a -license from the original licensor to copy, distribute or -modify the Program subject to these terms and -conditions. You may not impose any further restrictions on -the recipients' exercise of the rights granted herein. You -are not responsible for enforcing compliance by third -parties to this License. - -7. If, as a consequence of a court judgment or allegation of -patent infringement or for any other reason (not limited to -patent issues), conditions are imposed on you (whether by -court order, agreement or otherwise) that contradict the -conditions of this License, they do not excuse you from the -conditions of this License. If you cannot distribute so as -to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a -consequence you may not distribute the Program at all. For -example, if a patent license would not permit royalty-free -redistribution of the Program by all those who receive -copies directly or indirectly through you, then the only way -you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or -unenforceable under any particular circumstance, the balance -of the section is intended to apply and the section as a -whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to -infringe any patents or other property right claims or to -contest validity of any such claims; this section has the -sole purpose of protecting the integrity of the free -software distribution system, which is implemented by public -license practices. Many people have made generous -contributions to the wide range of software distributed -through that system in reliance on consistent application of -that system; it is up to the author/donor to decide if he or -she is willing to distribute software through any other -system and a licensee cannot impose that choice. - -This section is intended to make thoroughly clear what is -believed to be a consequence of the rest of this License. - -8. If the distribution and/or use of the Program is -restricted in certain countries either by patents or by -copyrighted interfaces, the original copyright holder who -places the Program under this License may add an explicit -geographical distribution limitation excluding those -countries, so that distribution is permitted only in or -among countries not thus excluded. In such case, this -License incorporates the limitation as if written in the -body of this License. - -9. The Free Software Foundation may publish revised and/or -new versions of the General Public License from time to -time. Such new versions will be similar in spirit to the -present version, but may differ in detail to address new -problems or concerns. - -Each version is given a distinguishing version number. If -the Program specifies a version number of this License which -applies to it and "any later version", you have the option -of following the terms and conditions either of that version -or of any later version published by the Free Software -Foundation. If the Program does not specify a version number -of this License, you may choose any version ever published -by the Free Software Foundation. - -10. If you wish to incorporate parts of the Program into -other free programs whose distribution conditions are -different, write to the author to ask for permission. For -software which is copyrighted by the Free Software -Foundation, write to the Free Software Foundation; we -sometimes make exceptions for this. Our decision will be -guided by the two goals of preserving the free status of all -derivatives of our free software and of promoting the -sharing and reuse of software generally. - -NO WARRANTY - -11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS -NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY -APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE -COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM -"AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR -IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED -WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE -OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE -DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, -REPAIR OR CORRECTION. - -12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED -TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY -WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED -ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, -SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF -THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT -LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR -LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE -PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH -HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF -SUCH DAMAGES. - -END OF TERMS AND CONDITIONS - - - -ICU License - ICU 1.8.1 and later -COPYRIGHT AND PERMISSION NOTICE - -Copyright (c) 1995-2003 International Business Machines -Corporation and others All rights reserved. - -Permission is hereby granted, free of charge, to any person -obtaining a copy of this software and associated -documentation files (the "Software"), to deal in the -Software without restriction, including without limitation -the rights to use, copy, modify, merge, publish, distribute, -and/or sell copies of the Software, and to permit persons to -whom the Software is furnished to do so, provided that the -above copyright notice(s) and this permission notice appear -in all copies of the Software and that both the above -copyright notice(s) and this permission notice appear in -supporting documentation. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY -KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE -WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR -PURPOSE AND NONINFRINGEMENT OF THIRD PARTY RIGHTS. IN NO -EVENT SHALL THE COPYRIGHT HOLDER OR HOLDERS INCLUDED IN THIS -NOTICE BE LIABLE FOR ANY CLAIM, OR ANY SPECIAL INDIRECT OR -CONSEQUENTIAL DAMAGES, OR ANY DAMAGES WHATSOEVER RESULTING -FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF -CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT -OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS -SOFTWARE. - -Except as contained in this notice, the name of a copyright -holder shall not be used in advertising or otherwise to -promote the sale, use or other dealings in this Software -without prior written authorization of the copyright holder. - ------------------------------------------------------------- -All trademarks and registered trademarks mentioned herein -are the property of their respective owners. --- /project/elephant/cvsroot/elephant/TODO 2005/11/23 17:51:31 1.8 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/04 22:25:09 1.9 @@ -1,3 +1,25 @@ +Feb. 4, 2006 + +As of 0.5.0, we have seem to have a stable suite on +ACL, SBCL, and OpenMCL. + +The things I would most like to see improved are: + +1) Robustness around error handling. +2) Ian Eslick has written some great indexing stuff in a branch +that I intend to merge in after this release. +3) The SQL serializer could be made more efficiently very +easily, greatly enhancing the speed of that as a back-end. + + +In general, Elephant is very usable and modestly robust, +but heavier use, better documentation, and a good example +application would help it a lot. + + + + + Merge in the todos from the source and the NOTES! October 19, 2005 --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/01/25 22:18:03 1.3 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/04 22:25:09 1.4 @@ -43,10 +43,10 @@ (defsystem ele-bdb :name "ele-bdb" - :author "Robert L. Read " + :author "Robert L. Read " :version "0.1" - :maintainer "Robert L. Read " - :licence "GPL" + :maintainer "Robert L. Read " + :licence "LLGPL" :description "Berkeley-DB based Object respository for Common Lisp" :long-description "Including this loads the Berkeley-DB code; you may have to edit the pathname!" :components --- /project/elephant/cvsroot/elephant/ele-clsql.asd 2005/11/23 17:51:31 1.2 +++ /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/04 22:25:09 1.3 @@ -46,7 +46,7 @@ :author "Robert L. Read " :version "0.1" :maintainer "Robert L. Read " - :licence "GPL" + :licence "LLGPL" :description "SQL-based Object respository for Common Lisp" :long-description "An experimental CL-SQL based implementation of Elephant" --- /project/elephant/cvsroot/elephant/elephant.asd 2006/01/26 03:17:56 1.10 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/02/04 22:25:09 1.11 @@ -43,9 +43,9 @@ (defsystem elephant :name "elephant" :author "Ben Lee " - :version "0.1" + :version "0.5.0" :maintainer "Ben Lee " - :licence "GPL" + :licence "LLGPL" :description "Object database for Common Lisp" :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro." From rread at common-lisp.net Sat Feb 4 22:25:10 2006 From: rread at common-lisp.net (rread) Date: Sat, 4 Feb 2006 16:25:10 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060204222510.389752A035@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv456/src Modified Files: BerkeleyDB-tests.lisp MigrationTests.lisp RUNTEST.lisp SQLDB-tests.lisp bdb-enable.lisp berkeley-db.lisp classes.lisp cmu-mop-patches.lisp collections.lisp controller.lisp elephant.lisp metaclasses.lisp openmcl-mop-patches.lisp serializer.lisp sleepycat.lisp sql-collections.lisp sql-controller.lisp sql-tutorial.lisp utils.lisp Log Message: Mostly changing to LLGPL --- /project/elephant/cvsroot/elephant/src/BerkeleyDB-tests.lisp 2006/01/25 22:18:03 1.2 +++ /project/elephant/cvsroot/elephant/src/BerkeleyDB-tests.lisp 2006/02/04 22:25:09 1.3 @@ -1,3 +1,10 @@ +;;; Copyright (c) 2006 by Robert L. Read +;;; + +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + (asdf:operate 'asdf:load-op :elephant) (asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :elephant-tests) --- /project/elephant/cvsroot/elephant/src/MigrationTests.lisp 2006/01/24 18:25:00 1.1 +++ /project/elephant/cvsroot/elephant/src/MigrationTests.lisp 2006/02/04 22:25:09 1.2 @@ -1,3 +1,17 @@ +;;; MigrationTests.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2005,2006 by Robert L. Read +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + + ;; This file is an example of how to perform the ;; migration tests. You will have to modify it ;; slightly depending on the systems that want to test... --- /project/elephant/cvsroot/elephant/src/RUNTEST.lisp 2006/01/24 18:25:00 1.4 +++ /project/elephant/cvsroot/elephant/src/RUNTEST.lisp 2006/02/04 22:25:09 1.5 @@ -1,3 +1,18 @@ +;;; RUNTEST.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2005,2006 by Robert L. Read +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + + + ;; This file is now obsolete... ;; Please use SQLDB-test.lisp or BerkeleyDB-tests.lisp --- /project/elephant/cvsroot/elephant/src/SQLDB-tests.lisp 2006/01/24 18:25:00 1.1 +++ /project/elephant/cvsroot/elephant/src/SQLDB-tests.lisp 2006/02/04 22:25:09 1.2 @@ -1,3 +1,16 @@ +;;; SQLDB-tests.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2005,2006 by Robert L. Read +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + (asdf:operate 'asdf:load-op :elephant) (asdf:operate 'asdf:load-op :ele-clsql) (asdf:operate 'asdf:load-op :elephant-tests) --- /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/01/29 01:08:32 1.5 +++ /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/02/04 22:25:09 1.6 @@ -14,32 +14,9 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (defpackage ele-bdb --- /project/elephant/cvsroot/elephant/src/berkeley-db.lisp 2005/02/24 01:06:10 1.3 +++ /project/elephant/cvsroot/elephant/src/berkeley-db.lisp 2006/02/04 22:25:09 1.4 @@ -12,34 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA -;;; - (in-package "SLEEPYCAT") --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/25 14:09:46 1.16 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/04 22:25:09 1.17 @@ -12,35 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA -;;; - - (in-package "ELEPHANT") (defmethod initialize-instance :before ((instance persistent) --- /project/elephant/cvsroot/elephant/src/cmu-mop-patches.lisp 2005/02/24 01:09:24 1.1 +++ /project/elephant/cvsroot/elephant/src/cmu-mop-patches.lisp 2006/02/04 22:25:09 1.2 @@ -1,3 +1,18 @@ +;;; cmu-mop-patches.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;; + + #+cmu (in-package :PCL) @@ -93,4 +108,4 @@ (unless (eq owrapper nwrapper) (update-inline-access class) (update-pv-table-cache-info class) - (maybe-update-standard-class-locations class))))) \ No newline at end of file + (maybe-update-standard-class-locations class))))) --- /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/24 15:42:30 1.13 +++ /project/elephant/cvsroot/elephant/src/collections.lisp 2006/02/04 22:25:09 1.14 @@ -12,32 +12,9 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/24 15:42:30 1.14 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/04 22:25:09 1.15 @@ -12,34 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA -;;; - (in-package "ELEPHANT") @@ -48,7 +24,7 @@ ;; controller from it. (defvar *strategies* '()) -(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant-0.3/") +(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant/") (defun register-strategy (spec-to-controller) (setq *strategies* (delete spec-to-controller *strategies*)) @@ -184,7 +160,6 @@ #-ALLEGRO (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))) --- /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/01/25 16:58:25 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/04 22:25:09 1.19 @@ -12,32 +12,9 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (defpackage elephant --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/24 15:42:30 1.10 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/04 22:25:09 1.11 @@ -11,33 +11,11 @@ ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; +;;; (Some changes by Robert L. Read, 2006) ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") --- /project/elephant/cvsroot/elephant/src/openmcl-mop-patches.lisp 2006/01/27 01:49:36 1.1 +++ /project/elephant/cvsroot/elephant/src/openmcl-mop-patches.lisp 2006/02/04 22:25:09 1.2 @@ -1,3 +1,17 @@ +;;; openmcl-mop-patches.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2006 by Andrew Blumberg +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;; + (in-package :CCL) (let ((*warn-if-redefine-kernel* nil)) @@ -63,4 +77,4 @@ :colon))) (if (and (eql 0 instance-count) (eql 0 shared-count) (eql n shared-end)) (values nil "No Slots" :comment) - (line-n-out-of-range i n))))))))))) \ No newline at end of file + (line-n-out-of-range i n))))))))))) --- /project/elephant/cvsroot/elephant/src/serializer.lisp 2005/12/05 15:08:35 1.12 +++ /project/elephant/cvsroot/elephant/src/serializer.lisp 2006/02/04 22:25:09 1.13 @@ -9,35 +9,9 @@ ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; -;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee -;;; -;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") --- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/01/29 01:08:32 1.17 +++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/04 22:25:09 1.18 @@ -12,34 +12,10 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA -;;; - (defpackage sleepycat (:documentation "A low-level UFFI-based interface to --- /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2005/11/23 17:51:37 1.2 +++ /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2006/02/04 22:25:09 1.3 @@ -10,33 +10,11 @@ ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2005 by Robert L. Read +;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") --- /project/elephant/cvsroot/elephant/src/sql-controller.lisp 2006/01/29 01:08:32 1.4 +++ /project/elephant/cvsroot/elephant/src/sql-controller.lisp 2006/02/04 22:25:09 1.5 @@ -11,32 +11,9 @@ ;;; ;;; Copyright (c) 2005 by Robert L. Read ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") --- /project/elephant/cvsroot/elephant/src/sql-tutorial.lisp 2005/11/23 17:51:38 1.2 +++ /project/elephant/cvsroot/elephant/src/sql-tutorial.lisp 2006/02/04 22:25:09 1.3 @@ -1,3 +1,16 @@ +;;; sql-tutorial.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + + + (asdf:operate 'asdf:load-op :elephant) (asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :elephant-tests) --- /project/elephant/cvsroot/elephant/src/utils.lisp 2005/11/23 17:51:38 1.9 +++ /project/elephant/cvsroot/elephant/src/utils.lisp 2006/02/04 22:25:09 1.10 @@ -12,32 +12,9 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; From rread at common-lisp.net Sat Feb 4 22:25:10 2006 From: rread at common-lisp.net (rread) Date: Sat, 4 Feb 2006 16:25:10 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060204222510.9E4242A035@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv456/tests Modified Files: elephant-tests.lisp mop-tests.lisp testcollections.lisp testmigration.lisp testserializer.lisp testsleepycat.lisp testsorter.lisp Log Message: Mostly changing to LLGPL --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/01/29 01:08:32 1.8 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/04 22:25:10 1.9 @@ -12,33 +12,9 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA -;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defpackage elephant-tests (:nicknames ele-tests :ele-tests) --- /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2005/11/23 17:51:59 1.8 +++ /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2006/02/04 22:25:10 1.9 @@ -1,3 +1,16 @@ +;;; mop-tests.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + (in-package :ele-tests) (deftest non-transient-class-slot-1 --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/04 20:34:02 1.8 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/04 22:25:10 1.9 @@ -1,3 +1,16 @@ +;;; testcollections.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;; (in-package :ele-tests) @@ -717,16 +730,16 @@ ;; (deftest class-change-deletion -;; (progn -;; (defclass blob-tbc () -;; ((slot1 :accessor slot1 :initarg :slot1) -;; (slot2 :accessor slot2 :initarg :slot2))) -;; (add-to-root "blob" (make-instance 'blob-tbc)) -;; (defclass blob-tbc () -;; ((slot1 :accessor slot1 :initarg :slot1) -;; (slot3 :accessor slot3 :initarg :slot3))) -;; (remove-from-root "blob") -;; (get-from-root "blob") -;; ) -;; nil nil) +;; (progn +;; (defclass blob-tbc () +;; ((slot1 :accessor slot1 :initarg :slot1) +;; (slot2 :accessor slot2 :initarg :slot2))) +;; (add-to-root "blob" (make-instance 'blob-tbc)) +;; (defclass blob-tbc () +;; ((slot1 :accessor slot1 :initarg :slot1) +;; (slot3 :accessor slot3 :initarg :slot3))) +;; (remove-from-root "blob") +;; (get-from-root "blob") +;; ) +;; nil nil) --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/04 20:34:02 1.4 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/04 22:25:10 1.5 @@ -1,8 +1,15 @@ -;; This file can really only be used if you -;; have preformed both: -;; (asdf:operate 'asdf:load-op :ele-bdb) -;; and -;; (asdf:operate 'asdf:load-op :ele-clsql) +;;; testmigration.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2005,2006 by Robert L. Read +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package :ele-tests) --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2006/01/29 01:08:32 1.8 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2006/02/04 22:25:10 1.9 @@ -1,3 +1,16 @@ +;;; testserializer.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + (in-package :ele-tests) (defun in-out-value (var) --- /project/elephant/cvsroot/elephant/tests/testsleepycat.lisp 2006/01/25 15:36:32 1.5 +++ /project/elephant/cvsroot/elephant/tests/testsleepycat.lisp 2006/02/04 22:25:10 1.6 @@ -1,7 +1,17 @@ +;;; testsleepycat.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (in-package "ELE-TESTS") -;;(unuse-package "ELE") -;;(use-package "SLEEPYCAT") (defvar env) (defvar db) --- /project/elephant/cvsroot/elephant/tests/testsorter.lisp 2004/09/16 04:29:19 1.1 +++ /project/elephant/cvsroot/elephant/tests/testsorter.lisp 2006/02/04 22:25:10 1.2 @@ -1,3 +1,16 @@ +;;; testsorter.lisp +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; +;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee +;;; +;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + (in-package "ELE") (def-function ("lisp_cmp_test" lisp-compare) @@ -103,4 +116,4 @@ (defconstant lowest-bad-num? 18455751272964294657) - \ No newline at end of file + From ieslick at common-lisp.net Sun Feb 5 23:13:07 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 5 Feb 2006 17:13:07 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060205231307.8FF2A7C001@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv29751 Modified Files: ele-sqlite3.asd Log Message: Minor modifications including a cleanup of the basicpersistence test and fixing two bugs in allegro support for slot-unboundp and makunbound. I also removed a workaround of these bugs in the mop-tests.lisp test suite. This checkin confirms that release candidate 0-5-0-rc1 passes all tests under Allegro 7.0 using the BDB 4.3 and SQLite3 backends. --- /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2005/11/23 17:51:31 1.2 +++ /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/05 23:13:07 1.3 @@ -56,4 +56,4 @@ ( ) :serial t)) - :depends-on (:elephant :clsql :cl-base64 :clsql-sqlite3)) + :depends-on (:ele-clsql :clsql-sqlite3)) From ieslick at common-lisp.net Sun Feb 5 23:13:07 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 5 Feb 2006 17:13:07 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060205231307.DE2487D000@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv29751/src Modified Files: classes.lisp controller.lisp metaclasses.lisp Log Message: Minor modifications including a cleanup of the basicpersistence test and fixing two bugs in allegro support for slot-unboundp and makunbound. I also removed a workaround of these bugs in the mop-tests.lisp test suite. This checkin confirms that release candidate 0-5-0-rc1 passes all tests under Allegro 7.0 using the BDB 4.3 and SQLite3 backends. --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/04 22:25:09 1.17 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/05 23:13:07 1.18 @@ -172,7 +172,7 @@ ;; probably should delete discarded slots, but we'll worry about that later (prog1 (call-next-method) - (format t "persisent-slots ~A~%" (persistent-slots (class-of instance))) +;; (format t "persistent-slots ~A~%" (persistent-slots (class-of instance))) ;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) (let* ((class (class-of instance)) (new-persistent-slots (set-difference (persistent-slots class) @@ -235,10 +235,10 @@ (loop for slot in (class-slots class) for matches-p = (eq (slot-definition-name slot) slot-name) until matches-p - finally (if (and matches-p - (typep slot 'persistent-slot-definition)) - (persistent-slot-boundp instance slot-name) - (call-next-method)))) + finally (return (if (and matches-p + (subtypep (type-of slot) 'persistent-slot-definition)) + (persistent-slot-boundp instance slot-name) + (call-next-method))))) (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." @@ -268,6 +268,6 @@ (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) (loop for slot in (class-slots class) 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)))) + finally (return (if (typep slot 'persistent-slot-definition) + (slot-makunbound-using-class class instance slot) + (call-next-method))))) --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/04 22:25:09 1.15 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/05 23:13:07 1.16 @@ -400,10 +400,9 @@ (defmacro with-open-store ((spec) &body body) "Executes the body with an open controller, unconditionally closing the controller on exit." - `(let ((*store-controller* - (get-controller ,spec))) + `(let ((*store-controller* (get-controller ,spec))) (declare (special *store-controller*)) -;; (open-controller *store-controller*) + (open-controller *store-controller*) (unwind-protect (progn , at body) (close-controller *store-controller*)))) --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/04 22:25:09 1.11 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/05 23:13:07 1.12 @@ -278,7 +278,7 @@ (let ((buf (db-get-key-buffered (controller-db (check-con (:dbcn-spc-pst ,instance))) key-buf value-buf))) - (if buf T nil)))))) + (if buf t nil)))))) #+(or cmu sbcl) (defun make-persistent-slot-boundp (name) From ieslick at common-lisp.net Sun Feb 5 23:13:08 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 5 Feb 2006 17:13:08 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060205231308.373267D001@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv29751/tests Modified Files: mop-tests.lisp testcollections.lisp testmigration.lisp Log Message: Minor modifications including a cleanup of the basicpersistence test and fixing two bugs in allegro support for slot-unboundp and makunbound. I also removed a workaround of these bugs in the mop-tests.lisp test suite. This checkin confirms that release candidate 0-5-0-rc1 passes all tests under Allegro 7.0 using the BDB 4.3 and SQLite3 backends. --- /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2006/02/04 22:25:10 1.9 +++ /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2006/02/05 23:13:08 1.10 @@ -179,17 +179,11 @@ (is-not-null (subtypep 'redef 'persistent-object))) t) -;; i wish i could use slot-makunbound but allegro sux (deftest makunbound (let ((p (make-instance 'p-class :sc *store-controller*))) (with-transaction (:store-controller *store-controller*) (setf (slot1 p) t) - #-allegro - (slot-makunbound p 'slot1) - #+allegro - (slot-makunbound-using-class (find-class 'p-class) p - (find-slot-def 'p-class 'slot1)) - ) + (slot-makunbound p 'slot1)) (signals-condition (slot1 p))) t) --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/04 22:25:10 1.9 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/05 23:13:08 1.10 @@ -15,25 +15,23 @@ (in-package :ele-tests) (deftest basicpersistence - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) + (let ((*prev-commit* *auto-commit*) (*auto-commit* t) (rv nil)) - (unwind-protect - (let ((x (gensym))) - (add-to-root "x" x) - (let ((sc1 (open-store *test-path-primary*))) - (setf rv (equal (format nil "~A" x) - (format nil "~A" (get-from-root "x")))) -;; This line makes the tests fail, though I don't know why! -;; (close-controller *store-controller*) - )) - (progn - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))) + (unwind-protect + (let ((x (gensym))) + (add-to-root "x" x) + ;; Clear instances + (setf (elephant::instance-cache *store-controller*) + (elephant::make-cache-table :test #'eql)) + ;; Are gensyms equal across db instantiations? + ;; This forces a refetch of the object from db + (setq rv (equal (format nil "~A" x) + (format nil "~A" (get-from-root "x"))))) + (progn + (setq *auto-commit* *prev-commit*))) rv) - t -) + t) (deftest testoid (progn --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/04 22:25:10 1.5 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/05 23:13:08 1.6 @@ -194,7 +194,8 @@ (and (and (not (slot-boundp fm1 'slot1)) (not (slot-boundp f1 'slot1))) - (equal (slot1 fm2) (slot1 f2)) - (equal (slot2 bm1) (slot2 b1)))))) +;; (equal (slot1 fm2) (slot1 f2)) +;; (equal (slot2 bm1) (slot2 b1)) + )))) (setq *auto-commit* *prev-commit*)))) t) From rread at common-lisp.net Sun Feb 5 23:44:26 2006 From: rread at common-lisp.net (rread) Date: Sun, 5 Feb 2006 17:44:26 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060205234426.91FAA2A032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv499 Added Files: Tag: ELEPHANT-0-4-1-rc1-IAN RunIndexingTutorial.lisp Log Message: A sample file -- we don't have to keep this, but I didn't want it to get lost. From rread at common-lisp.net Sun Feb 5 23:46:41 2006 From: rread at common-lisp.net (rread) Date: Sun, 5 Feb 2006 17:46:41 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060205234641.DE8E32A032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv1957 Added Files: BerkeleyDB-tests.lisp MigrationTests.lisp RUNTEST.lisp SQLDB-tests.lisp Log Message: Moving these test files into the tests directory for clarity --- /project/elephant/cvsroot/elephant/tests/BerkeleyDB-tests.lisp 2006/02/05 23:46:41 NONE +++ /project/elephant/cvsroot/elephant/tests/BerkeleyDB-tests.lisp 2006/02/05 23:46:41 1.1 ;;; Copyright (c) 2006 by Robert L. Read ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (asdf:operate 'asdf:load-op :elephant) (asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :elephant-tests) (in-package "ELEPHANT-TESTS") ;; The primary and secondary test-paths are ;; use for the migration tests. ;; (setq *test-path-primary* *testdb-path*) (setq *test-path-secondary* nil) (do-all-tests-spec *test-path-primary*) --- /project/elephant/cvsroot/elephant/tests/MigrationTests.lisp 2006/02/05 23:46:41 NONE +++ /project/elephant/cvsroot/elephant/tests/MigrationTests.lisp 2006/02/05 23:46:41 1.1 ;;; MigrationTests.lisp ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2005,2006 by Robert L. Read ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;; This file is an example of how to perform the ;; migration tests. You will have to modify it ;; slightly depending on the systems that want to test... ;; You can test migration even between two BDB respositories if you wish (asdf:operate 'asdf:load-op :elephant) (asdf:operate 'asdf:load-op :ele-clsql) (asdf:operate 'asdf:load-op :clsql-postgresql-socket) (asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :elephant-tests) ;; For sqlite-3.. ;; (asdf:operate 'asdf:load-op :ele-sqlite3) (in-package "ELEPHANT-TESTS") ;; The primary and secondary test-paths are ;; use for the migration tests. ;; This this configuration for testing between BDB and SQL.... (setq *test-path-primary* *testpg-path*) ;; (setq *test-path-primary* *testsqlite3-path*) (setq *test-path-secondary* *testdb-path*) ;; This this configuration for testing from one BDB repository to another... (setq *test-path-primary* *testdb-path*) ;; (setq *test-path-primary* *testsqlite3-path*) (setq *test-path-secondary* *testdb-path2*) (do-migrate-test-spec *test-path-primary*) --- /project/elephant/cvsroot/elephant/tests/RUNTEST.lisp 2006/02/05 23:46:41 NONE +++ /project/elephant/cvsroot/elephant/tests/RUNTEST.lisp 2006/02/05 23:46:41 1.1 ;;; RUNTEST.lisp ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2005,2006 by Robert L. Read ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;; This file is now obsolete... ;; Please use SQLDB-test.lisp or BerkeleyDB-tests.lisp (asdf:operate 'asdf:load-op :elephant) (asdf:operate 'asdf:load-op :ele-clsql) (asdf:oos 'asdf:load-op :clsql-postgresql-socket) (asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :elephant-tests) (asdf:operate 'asdf:load-op :ele-sqlite3) (in-package "ELEPHANT-TESTS") (do-all-tests) (do-all-tests-spec *testpg-path*) (do-migrate-test-spec *testpg-path*) (do-all-tests-spec *testdb-path*) (do-all-tests-spec *testsqlite3-path*) ;; The primary and secondary test-paths are ;; use for the migration tests. (setq *test-path-primary* *testpg-path*) (setq *test-path-primary* *testsqlite3-path*) (setq *test-path-secondary* *testdb-path*) (setq *test-path-primary* *testdb-path*) (setq *test-path-secondary* nil) (do-all-tests-spec *test-path-primary*) (use-package :sb-profile) (profile "CLSQL") (profile "POSTGRESQL-SOCKET") (profile "ELEPHANT") (use-package "SB-PROFILE") (open-store *testpg-path*) (open-store *testdb-path*) (add-to-root "x1" "y1") (get-from-root "x1") (add-to-root "x2" '(a 4 "spud")) (get-from-root "x2") --- /project/elephant/cvsroot/elephant/tests/SQLDB-tests.lisp 2006/02/05 23:46:41 NONE +++ /project/elephant/cvsroot/elephant/tests/SQLDB-tests.lisp 2006/02/05 23:46:41 1.1 ;;; SQLDB-tests.lisp ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2005,2006 by Robert L. Read ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (asdf:operate 'asdf:load-op :elephant) (asdf:operate 'asdf:load-op :ele-clsql) (asdf:operate 'asdf:load-op :elephant-tests) ;; For postgres use this... (asdf:oos 'asdf:load-op :clsql-postgresql-socket) ;; For sqllite3... use this... ;; (asdf:operate 'asdf:load-op :ele-sqlite3) (in-package "ELEPHANT-TESTS") ;; The primary and secondary test-paths are ;; use for the migration tests. ;; You may have to change these from the defaults set in ;; elephant-tests.lisp to point to your database. (setq *test-path-primary* *testpg-path*) ;; This is an alternative ;; (setq *test-path-primary* *testsqlite3-path*) (setq *test-path-secondary* nil) (do-all-tests-spec *test-path-primary*) From rread at common-lisp.net Sun Feb 5 23:47:28 2006 From: rread at common-lisp.net (rread) Date: Sun, 5 Feb 2006 17:47:28 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060205234728.E37BF2A032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv1987 Removed Files: BerkeleyDB-tests.lisp MigrationTests.lisp RUNTEST.lisp SQLDB-tests.lisp Log Message: Moving these files into tests. From ieslick at common-lisp.net Mon Feb 6 17:40:57 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 6 Feb 2006 11:40:57 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060206174057.768054B00D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv6962/src Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN sleepycat.lisp Log Message: Quick patch to solve OpenMCL library building problems reported by Waldo Rubinstein --- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/01/26 04:03:44 1.16.2.1 +++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/06 17:40:56 1.16.2.2 @@ -126,8 +126,8 @@ (eval-when (:compile-toplevel :load-toplevel) (defparameter *c-library-extension* - #+macosx "dylib" - #-macosx "so" )) + #+(or darwin macosx) "dylib" + #-(or darwin macosx) "so" )) (eval-when (:compile-toplevel :load-toplevel) From rread at common-lisp.net Tue Feb 7 23:23:50 2006 From: rread at common-lisp.net (rread) Date: Tue, 7 Feb 2006 17:23:50 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060207232350.DB2E66600E@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv9614 Modified Files: elephant-tests.asd elephant.asd Log Message: Merger from Ian's branch into the main trunk. --- /project/elephant/cvsroot/elephant/elephant-tests.asd 2005/11/23 17:51:31 1.4 +++ /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/02/07 23:23:50 1.5 @@ -55,9 +55,10 @@ :components ((:file "elephant-tests") (:file "testserializer") + (:file "testsleepycat") (:file "mop-tests") (:file "testcollections") - (:file "testsleepycat") + (:file "testindexing") (:file "testmigration") ) :serial t))) --- /project/elephant/cvsroot/elephant/elephant.asd 2006/02/04 22:25:09 1.11 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/02/07 23:23:50 1.12 @@ -64,7 +64,11 @@ (:file "classes") (:file "controller") (:file "collections") - (:file "serializer")) + (:file "serializer") + (:file "index-utils") + (:file "indexing")) + #+openmcl + (:file "openmcl-mop-patches") :serial t)) :depends-on (:uffi)) From rread at common-lisp.net Tue Feb 7 23:23:51 2006 From: rread at common-lisp.net (rread) Date: Tue, 7 Feb 2006 17:23:51 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060207232351.BAF0D6D003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv9614/tests Modified Files: elephant-tests.lisp testcollections.lisp Added Files: RunIndexingTutorial.lisp testindexing.lisp Log Message: Merger from Ian's branch into the main trunk. --- /project/elephant/cvsroot/elephant/tests/RunIndexingTutorial.lisp 2006/02/05 23:44:26 1.1 +++ /project/elephant/cvsroot/elephant/tests/RunIndexingTutorial.lisp 2006/02/07 23:23:51 1.2 @@ -0,0 +1,39 @@ +(asdf:operate 'asdf:load-op :elephant) +(asdf:operate 'asdf:load-op :ele-bdb) +(asdf:operate 'asdf:load-op :elephant-tests) + +(compile-file "indexing.lisp") +(load "index-tutorial.lisp") + +(in-package "ELEPHANT-TUTORIAL") +(defconstant KILO 1000) +(defun test-generate-and-report-big (num name store-spec) + (open-store store-spec) + (generate-events name num 0.0 ) + (report-events name) + (close-store)) + +(defun find-mid-event (name) + (let ((midpoint (floor (/ (+ *start-timestamp* + *end-timestamp*) 2)))) + (report-events-by-time-only name + midpoint + (+ midpoint)) + ) +) + +(defun report-events-by-time-only (user start end) + "A custom reporting function for our logs - pull out a time range. A real + implementation might do it by dates or by dates + times using one of the + lisp time libraries" + (let ((entries1 (time (get-instances-by-range 'url-log 'timestamp start end))) + (entries2 nil)) + (mapc #'(lambda (x) (if (equal (plog-user x) user) (push x entries2))) entries1) + (format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2)) +)) + + +(time (test-generate-and-report-big (* 10 KILO) "bud" ele-tests::*test-path-primary*)) +(open-store ele-tests::*test-path-primary*) +(time (find-mid-event "bud")) +(close-store) --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/04 22:25:10 1.9 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/07 23:23:51 1.10 @@ -92,17 +92,48 @@ (defvar *test-path-primary* *testdb-path* ) + (defvar *test-path-secondary* *testdb-path2* ) - (defun do-all-tests() (progn (do-all-tests-spec *testdb-path*) (do-all-tests-spec *testsqlite3-path*) )) +(defun do-all-tests-spec (spec) + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (declare (special *auto-commit*)) + (do-tests))))) + +(defun do-test-spec (testname &optional (spec *testdb-path*)) + "For easy interactive running of tests while debugging" + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (do-test testname))))) + +(defun do-indexing-tests () + (declare (special *old-store*)) + (setq *old-store* *store-controller*) + (unwind-protect + (progn + (open-store *testdb-path*) + (print (do-test 'indexing-basic)) + (print (do-test 'indexing-inherit)) + (print (do-test 'indexing-range)) + (print (do-test 'indexing-reconnect-db)) + (print (do-test 'indexing-change-class)) + (print (do-test 'indexing-redef-class)) + (print (do-test 'indexing-explicit-changes)) + (print (do-test 'indexing-timing)) + (close-store)) + (setq *store-controller* *old-store*))) + (defun do-crazy-pg-tests() (open-store *testpg-path*) (do-test 'indexed-btree-make) --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/05 23:13:08 1.10 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/07 23:23:51 1.11 @@ -215,6 +215,7 @@ (deftest remove-kv-from-slot1 (finishes (remove-kv 2 index1)) t) + (deftest no-key-nor-indices-slot1 (values (get-value (second keys) indexed) @@ -225,6 +226,7 @@ (deftest remove-kv-from-slot2 (finishes (remove-kv 300 index2)) t) + (deftest no-key-nor-indices-slot2 (values (get-value (third keys) indexed) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/01/29 04:57:21 1.1 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/07 23:23:51 1.2 @@ -0,0 +1,235 @@ + +(in-package :ele-tests) + +(defun setup-testing () + (setf rt::*debug* t) + (setf rt::*catch-errors* nil) +;; (trace elephant::indexed-slot-writer) + (trace ((method initialize-instance :before (persistent)))) + (trace ((method initialize-instance (persistent-object)))) +;; (trace ((method shared-initialize :around (persistent-object t)))) +;; (trace ((method shared-initialize :around (persistent-metaclass t)))) +;; (trace elephant::find-class-index) +;; (trace get-instances-by-class) +;; (trace get-instances-by-value) + (trace enable-class-indexing) + (trace get-instances-by-range) + (trace elephant::cache-instance) + (trace elephant::get-cached-instance) + (trace elephant::get-cache) + (trace elephant::db-transaction-commit) + ) + +;; put list of objects, retrieve on value, range and by class +(deftest indexing-basic + (progn +;; (format t "Global vars:~%") +;; (format t "~%basic store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) +;; (format t "auto-commit: ~A~%" *auto-commit*) + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-one) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + (:metaclass persistent-metaclass)) + + (progn + (with-transaction () + (setq inst1 (make-instance 'idx-one :slot1 1 :sc *store-controller*)) + (setq inst2 (make-instance 'idx-one :slot1 1 :sc *store-controller*)) + (setq inst3 (make-instance 'idx-one :slot1 3 :sc *store-controller*))) + +;; (format t "Starting gathering of instances~%") + (values (length (get-instances-by-class 'idx-one)) + (length (get-instances-by-value 'idx-one 'slot1 1)) + (length (get-instances-by-value 'idx-one 'slot1 3)) + (eq (first (get-instances-by-value 'idx-one 'slot1 3)) inst3) + (length (get-instances-by-range 'idx-one 'slot1 1 3))))) + 3 2 1 t 3) + +;; test inherited slots +(deftest indexing-inherit + (progn +;; (format t "inherit store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil) + (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil) + (setf (find-class 'idx-one) nil) + (setf (find-class 'idx-two) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed t) + (slot3 :initarg :slot3 :initform 3 :accessor slot3) + (slot4 :initarg :slot4 :initform 4 :accessor slot4 :transient t)) + (:metaclass persistent-metaclass)) + + (defclass idx-two (idx-one) + ((slot2 :initarg :slot2 :initform 20 :accessor slot2) + (slot3 :initarg :slot3 :initform 30 :accessor slot3 :indexed t) + (slot4 :initarg :slot4 :initform 40 :accessor slot4 :indexed t)) + (:metaclass persistent-metaclass)) + + (progn + (with-transaction () + (setq inst1 (make-instance 'idx-two :sc *store-controller*))) + + (values (slot1 inst1) + (slot2 inst1) + (slot3 inst1) + (slot4 inst1) + (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-two))) + '(slot1 slot3 slot4))))) + 1 20 30 40 t) + +(deftest indexing-range + (progn +;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil) + (setf (find-class 'idx-one) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + (:metaclass persistent-metaclass)) + + (defun make-idx-one (val) + (make-instance 'idx-one :slot1 val :sc *store-controller*)) + + (with-transaction () + (mapc #'make-idx-one '(1 1 1 2 2 4 5 5 5 6 10))) + + ;; Range should get multiple & single keys inclusive of + ;; start and end + (let ((list (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6)))) + (equal list '(2 2 4 5 5 5 6)))) + t) + +(deftest indexing-reconnect-db + (progn + (disable-class-indexing 'idx-two :errorp nil) + (setf (find-class 'idx-two) nil) +;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + + (defclass idx-two () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2) + (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t)) + (:metaclass persistent-metaclass)) + + (let ((*old-default* *default-indexed-class-synch-policy*) + (*default-indexed-class-synch-policy* :db)) + + (with-transaction () + (make-instance 'idx-two)) + + ;; Wipe out the class so it's not a redefinition + (setf (find-class 'idx-two) nil) + + ;; Assume our db is out of synch with our class def + (defclass idx-two () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed t) + (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t)) + (:metaclass persistent-metaclass)) + + ;; Add an instance of the new class + (with-transaction () + (make-instance 'idx-two)) + + ;; DB should dominate (if set as default) + (values (length (get-instances-by-value 'idx-two 'slot3 3)) + (length (get-instances-by-value 'idx-two 'slot1 1)) + (signals-error (length (get-instances-by-value 'idx-two 'slot2 2)))))) + 2 2 t) + +(deftest indexing-change-class + nil + nil) + +(deftest indexing-redef-class + nil + nil) + +(deftest indexing-explicit-changes + nil + nil) + +;; create 10k objects, write each object's +;; slots + +(defclass stress-normal () + ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed nil) + (stress2 :accessor stress2 :initarg :stress2 :initform nil :indexed nil)) + (:metaclass persistent-metaclass)) + +(defclass stress-index () + ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed t) + (stress2 :accessor stress2 :initarg :stress2 :initform 2 :indexed t) + (stress3 :accessor stress3 :initarg :stress3 :initform 3 :indexed nil)) + (:metaclass persistent-metaclass)) + +(defvar normal-index nil) + +(defun normal-stress-setup (count class-name &rest inst-args) + (setf normal-index (make-btree)) + (dotimes (i count) + (setf (get-value i normal-index) (apply #'make-instance class-name :stress1 i inst-args)))) + +(defun indexed-stress-setup (count class-name &rest inst-args) + (dotimes (i count) + (apply #'make-instance class-name :stress1 i inst-args))) + +(defun normal-range-lookup (count size) + "Given stress1 slot has values between 1 and count, extract a range of size size that starts + at (/ count 2)" + (let* ((objects nil) + (start (/ count 2)) + (end (1- (+ start size)))) + (with-btree-cursor (cur normal-index) + (multiple-value-bind (value? key val) (cursor-next cur) + (declare (ignore key)) + (when (and value? + (>= (stress1 val) start) + (<= (stress1 val) end)) + (push val objects)))) + objects)) + +(defun indexed-range-lookup (class count size) + (let* ((start (/ count 2)) + (end (1- (+ start size)))) + (get-instances-by-range class 'stress1 start end))) + +(defparameter *stress-count* 500) +(defparameter *range-size* 40) + +(deftest indexing-timing + (progn + + (let ((insts (get-instances-by-class 'stress-index))) + (when insts + (drop-instances insts))) + + (format t "~%Stress test normal setup time (~A):~%" *stress-count*) + (with-transaction () + (time (normal-stress-setup *stress-count* 'stress-normal :stress2 10))) + + (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) + (with-transaction () + (time (indexed-stress-setup *stress-count* 'stress-index :stress2 10))) + + (format t "~%Stress test normal lookup time (~A):~%" *range-size*) + (time + (dotimes (i *range-size*) + (declare (ignore i)) + (normal-range-lookup *stress-count* *range-size*))) + + (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) + (time + (dotimes (i *range-size*) + (declare (ignore i)) + (indexed-range-lookup 'stress-index *stress-count* *range-size*))) + t) + t) + + + + From rread at common-lisp.net Tue Feb 7 23:23:51 2006 From: rread at common-lisp.net (rread) Date: Tue, 7 Feb 2006 17:23:51 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060207232351.673D767000@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv9614/src Modified Files: classes.lisp collections.lisp controller.lisp elephant.lisp metaclasses.lisp sleepycat.lisp sql-collections.lisp Added Files: IAN-TODO index-tutorial.lisp index-utils.lisp indexing.lisp Log Message: Merger from Ian's branch into the main trunk. --- /project/elephant/cvsroot/elephant/src/IAN-TODO 2006/01/26 04:03:44 1.1 +++ /project/elephant/cvsroot/elephant/src/IAN-TODO 2006/02/07 23:23:50 1.2 @@ -0,0 +1,102 @@ +TODO: +- Finish adding tests! +- Documentation (Robert) +- Tutorial example (Ian) + +CLEANUP: +- Verify locking behavior in transactions (should timeout with error!) +- validate native string serialization for allegro in sleepycat.lisp (6.2 trial?) + +FUTURE: +- Add compiled query language (0.5.2) +- Changing slots should push default value into new persistent slots (ie name change) + for existing slots in DB when :class is the synch type +- performance validation of allegro native string serialization (0.5.2) +- Fix multi-repository handling (Ian/Richard) (0.5.2) +- Closer to MOP conversion? (Check licensing) (0.5.3) +- Time/Space performance tuning on indexed slots (0.5.4) + - Reclaim storage on secondary index drop? + - Compute dependencies on derived slots to improve performance + - Optimize consistency updating of inverted indices (currently remove/add) + - Custom DB table instead of using primary/secondary? + - Do not store duplicates in inverted index, store a list of + objects instead that can be operated on cheaply? +- Help Robert integrate his in-memory alternative (non-concurrent mode) + (change use of bdb settings & class slot read/write behavior) (0.6.0) + +DOCUMENTATION: + +Defining Indexed Persistent Classes + +Elephant now contains the facility for default class instance indexing and inverted +indicies defined against slots or functions that compute derived parameters. + +Class indexing is enabled whenever an inverted index is specified. Later releases +may allow for class indexing without inverted indices. Indexing can be specified +interactively at runtime or by :indexed t/nil slot initargs in the class definition. +Only persistent slots can be indexed and derived index functions may only depend on +persistent slots (although no error checking is currently performed on derived slots) + +When a slot is declared indexed, each write to an indexed persistent slot results in +an update to a dedicated class indexed-btree. This btree is organized based on the +instance oid->instance. All class instances can be found by walking the primary +indexed btree. Inverted indices are managed through secondary indices which are +automatically updated by writes to the primary index. Each slot index and derived +index has a secondary (btree-index) btree dedicate to it. This functionality is +similar to that defined for the Symbolics Statice database. + +Writes to classes with an inverted index on the written slot are more expensive than +standard writes. They involves, at least, three additional reads to verify that the +primary index key-value and secondary index key-value are the same. To validate +the secondary key-value pair the persistent value is read again by the key-function +defined on the secondary index. This is very appropriate for read heavy, interactive +systems that will be using the indexes alot, but less so for write-dominated archives +such as log files. Log files that are infrequently read are better off stored without +indexing using a linked list with a market index that taps into the linked list at +various points according to date, sequence number, etc. Systems that care little about +throughput can be agnostic to the performance impact as read/writes are likely to be +a very small part of the total runtime. (Can I justify this statement empirically?) + +Interactive manipulation of indexing is allowed through an API defined in indexing.lisp. +Classes can have indexing enabled/disabled. Individual slots can be registered and +unregistered as indexed slots and derived slots can be added only via the interactive +functions. + +There are some touchy issues in reconnecting to an existing indexed slot database. +Elephant does not yet support persistent classes and so interactive changes to indexing +may clash with the initargs in the original defclass. If this is the case, the system +will adapt the defined class to the persistent state and warn the user that the text +is out of date with the persistent indexing state. It is a good idea to change slot +indexing behavior using change-class or by re-evaluating a changed class definition. +In the lisp tradition, we'll assume you know what you're doing when you interactively +change things so we'll maintain derived indices. If they have slot dependencies that +are lost under a change-class operation then there will be an error issued by the +derived function at runtime and you'll have to drop and restart that index. We may +add some more sophistication here at a later date (such as allowing specification of +the slots a derived index depends on so we can automatically drop and compute updates. + +Database Queries for Indexed Instances + +All the above functionality leaves us with a set of indexed instances. The indexing +functionality provides three APIs for leveraging this infrastructure in your programs. + +1) Simplified cursor interface. You can use the underlying btree cursors directly if +you want to do sophisticated operations over the indices. Be sure to wrap side effects +to the store in with-transaction statements and to close your indices when done. + +2) Instance set retrieval. You can retrieve sets of instances using simple interfaces +that retrieve instances by slot value, a range of slot values (range is determined +using the built-in elephant key order routine) or all class instances. This API also +allows mapping over ranges, sets of values or all class instances. + +3) Query language. This is relatively primitive for now, it allows you to do joins +over multiple slot or derived indices to pick a subset of classes that satisfy a given +relation. Later we hope to allow for more complex class instance inter-dependencies, +for example persistent graphs where subgraphs are deferentiated by class-type or slot +values. + +See the API reference for + + + + --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/05 23:13:07 1.18 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/07 23:23:50 1.19 @@ -54,6 +54,31 @@ metaclass.") (:metaclass persistent-metaclass)) +;;(defmethod print-object ((obj persistent) stream) + +(defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys) + (declare (ignore initargs)) + (if (indexed (class-of instance)) + (progn + (let ((oid (oid instance))) + (declare (type fixnum oid)) + (inhibit-indexing oid) + (unwind-protect + (call-next-method) + (uninhibit-indexing oid)) + ;; Inhibit indexing if the object already was defined (ie being created from an oid) + ;; as it should be indexed already. This hack avoids a deadlock situation where we + ;; write the class or index page that we are currently reading via a cursor without + ;; going through the cursor abstraction. There has to be a better way to do this. + (when (not from-oid) + (let ((class-index (find-class-index (class-of instance)))) + (when class-index +;; (format t "Indexing initial instance: ~A :: ~A~%" oid instance) + (with-transaction () + (setf (get-value oid class-index) instance))))))) + ;; else + (call-next-method))) + (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) @@ -89,10 +114,13 @@ #+allegro (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) (loop with persistent-slots = (persistent-slots instance) for slot-def in (class-direct-slots instance) when (member (slot-definition-name slot-def) persistent-slots) @@ -101,19 +129,24 @@ #+(or cmu sbcl openmcl) (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) (make-instances-obsolete instance)))) ;; #+allegro (defmethod finalize-inheritance :around ((instance persistent-metaclass)) (prog1 (call-next-method) - (if (not (slot-boundp instance '%persistent-slots)) + (when (not (slot-boundp instance '%persistent-slots)) (setf (%persistent-slots instance) - (cons (persistent-slot-names instance) nil))))) + (cons (persistent-slot-names instance) nil))) + (when (not (slot-boundp instance '%indexed-slots)) + (update-indexed-record instance (indexed-slot-names-from-defs instance))))) ;; #+(or cmu sbcl) ;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) @@ -169,17 +202,16 @@ (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 + ;; NOTE: probably should delete discarded slots, but we'll worry about that later + (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) -;; (format t "persistent-slots ~A~%" (persistent-slots (class-of instance))) -;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) (let* ((class (class-of instance)) (new-persistent-slots (set-difference (persistent-slots class) (old-persistent-slots class)))) - + ;; Update new persistent slots, the others we get for free (same oid!) + ;; Isn't this done by the default call-next-method? (apply #'shared-initialize instance new-persistent-slots initargs)) -;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) ) ) @@ -200,7 +232,9 @@ when (not (persistent-slot-boundp previous slot-name)) collect slot-name)) (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) + ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) + ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) (loop for slot-def in (class-slots new-class) when (member (slot-definition-name slot-def) retained-persistent-slots) do (setf (slot-value-using-class new-class @@ -209,6 +243,9 @@ (slot-value-using-class old-class previous (find-slot-def-by-name old-class (slot-definition-name slot-def))))) + ;; Delete this instance from its old class index, if exists + (when (indexed old-class) + (remove-kv (oid previous) (find-class-index old-class))) (call-next-method))) (defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) @@ -217,11 +254,21 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-reader instance name))) +;; ORIGINAL METHOD +;; (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) +;; "Set the slot value in the database." +;; (declare (optimize (speed 3))) +;; (let ((name (slot-definition-name slot-def))) +;; (persistent-slot-writer new-value instance name))) + +;; SUPPORT FOR INVERTED INDEXES (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (declare (optimize (speed 3))) - (let ((name (slot-definition-name slot-def))) - (persistent-slot-writer new-value instance name))) + (if (indexed class) + (indexed-slot-writer class instance slot-def new-value) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-writer new-value instance name)))) (defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." @@ -242,19 +289,21 @@ (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)) - (ignore class)) - (if (sql-store-spec-p (:dbcn-spc-pst instance)) - (progn + (declare (optimize (speed 3))) + ;; NOTE: call remove-indexed-slot here instead? + (when (indexed slot-def) + (unregister-indexed-slot class (slot-definition-name slot-def))) + (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) + (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 --- /project/elephant/cvsroot/elephant/src/collections.lisp 2006/02/04 22:25:09 1.14 +++ /project/elephant/cvsroot/elephant/src/collections.lisp 2006/02/07 23:23:50 1.15 @@ -121,11 +121,9 @@ (defclass bdb-indexed-btree (indexed-btree bdb-btree ) ( - (indices :accessor indices :initform (make-hash-table) - ) + (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 BDB-based BTree supports secondary indices.")) @@ -276,6 +274,7 @@ (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? + ;; Manually write value into secondary index (buffer-write-int (oid index) secondary-buf) (serialize secondary-key secondary-buf) ;; should silently do nothing if the key/value already @@ -355,7 +354,7 @@ "Puts are not allowed on secondary indices. Try adding to the primary." (declare (ignore value key) - (ignorable bt)) + (ignorable bt)) (error "Puts are forbidden on secondary indices. Try adding to the primary.")) (defgeneric get-primary-key (key bt) --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/05 23:13:07 1.16 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/07 23:23:50 1.17 @@ -32,15 +32,17 @@ ) (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)) - )) + (let ((cached-sc (gethash spec *dbconnection-spec*))) + (if cached-sc cached-sc + (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 () @@ -50,6 +52,7 @@ :accessor controller-path :initarg :path) (root :reader controller-root) + (class-root :reader controller-class-root) (db :type (or null pointer-void) :accessor controller-db :initform '()) (environment :type (or null pointer-void) :accessor controller-environment) @@ -74,7 +77,7 @@ creation, counters, locks, the root (for garbage collection,) et cetera.")) -;; Without somemore sophistication, these functions +;; Without some more 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) @@ -105,6 +108,10 @@ "Close the db handles and environment. Tries to wipe out references to the db handles.")) +(defgeneric reset-instance-cache (sc) + (:documentation + "Creates an empty object cache by replacing the existing cache.")) + (defgeneric build-btree (sc) (:documentation "Construct a btree of the appropriate type corresponding to this store-controller.")) @@ -313,14 +320,23 @@ (let ((root (make-instance 'bdb-btree :from-oid -1 :sc sc))) (setf (slot-value sc 'root) root)) + + (setf (slot-value sc 'class-root) + (make-instance 'bdb-btree :from-oid -2 :sc sc)) + sc))) +(defmethod reset-instance-cache ((sc store-controller)) + (setf (instance-cache sc) + (make-cache-table :test 'eql))) + (defmethod close-controller ((sc bdb-store-controller)) (when (slot-value sc 'root) ;; no root + (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) ;; clean instance cache - (setf (instance-cache sc) (make-cache-table :test 'eql)) + (reset-instance-cache sc) ;; close handles / environment (db-sequence-close (controller-oid-seq sc)) (setf (controller-oid-seq sc) nil) @@ -336,7 +352,10 @@ (setf (controller-db sc) nil) (db-env-close (controller-environment sc)) (setf (controller-environment sc) nil) - nil)) + nil) + ;; Delete connection spec so object ops on cached db info fail + (remhash (controller-path *store-controller*) *dbconnection-spec*)) + ;; Do these things need to take &rest arguments? (defmethod build-btree ((sc bdb-store-controller)) @@ -387,15 +406,18 @@ the controller unconditionally on exit." `(unwind-protect (progn - (let (*store-controller* (open-controller ,sc)) + (let ((*store-controller* (open-controller ,sc))) (declare (special *store-controller*)) , at body)) (close-controller ,sc))) (defun close-store () "Conveniently close the store controller." + (declare (special *store-controller*)) (if *store-controller* - (close-controller *store-controller*))) + (progn + (close-controller *store-controller*) + (setf *store-controller* nil)))) (defmacro with-open-store ((spec) &body body) "Executes the body with an open controller, --- /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/04 22:25:09 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/07 23:23:50 1.20 @@ -90,6 +90,24 @@ #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-flags #:db-env-get-flags #:run-elephant-thread + + ;; Class indexing management API + #:*default-indexed-class-synch-policy* + #:find-class-index #:find-inverted-index + #:enable-class-indexing #:disable-class-indexing + #:add-class-slot-index #:remove-class-slot-index + #:add-class-derived-index #:remove-class-derived-index + #:describe-db-class-index + + ;; Low level cursor API + #:make-inverted-cursor #:make-class-cursor + #:with-inverted-cursor #:with-class-cursor + + ;; Instance query API + #:get-instances-by-class + #:get-instances-by-value + #:get-instances-by-range + #:drop-instances ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/03 04:19:44 1.1 +++ /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,94 @@ + +(defpackage elephant-tutorial + (:use :cl :elephant)) + +(in-package :elephant-tutorial) + +(defclass simple-plog () + ((timestamp :accessor plog-timestamp :initarg :timestamp :indexed t) + (type :accessor plog-type :initarg :type :indexed t) + (data :accessor plog-data :initarg :data) + (user :accessor plog-user :initarg :user :indexed t)) + (:metaclass persistent-metaclass) + (:documentation "Simple persistent log")) + +(defclass url-record () + ((url :accessor url-record-url :initarg :url :initform "") + (fetched :accessor url-record-fetched :initarg :fetched :initform nil) + (analyzed :accessor url-record-analyzed :initarg :analyzed :initform nil)) + (:documentation "An application object, declared persistent but not indexed")) + +(defmethod print-object ((obj url-record) stream) + "Pretty print program objects so they're easy to inspect" + (format stream "" (url-record-url obj) (url-record-fetched obj) (url-record-analyzed obj))) + +(defclass url-log (simple-plog) () + (:metaclass persistent-metaclass) + (:documentation "This class tracks events that transform our program object state")) + +(defmethod print-object ((obj url-log) stream) + "Structured printing of log entries so they're easy to inspect at the repl" + (format stream "#plog[~A :: ~A]" (plog-type obj) (plog-data obj))) + +(defun log-event (user type data) + "A helper function to generically log various events by user" + (make-instance 'url-log + :timestamp (get-universal-time) + :type type + :data data + :user user)) + +(defun report-events-by-time (user start end) + "A custom reporting function for our logs - pull out a time range. A real + implementation might do it by dates or by dates + times using one of the + lisp time libraries" + (let ((entries1 (get-instances-by-range 'url-log 'timestamp start end)) + (entries2 (get-instances-by-value 'url-log 'user user))) + (format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2)) + (format t "~{~A~%~}" (nreverse (intersection entries1 entries2))))) + +;; +;; This code is the skeleton of a program +;; + +(defvar *start-timestamp* nil) +(defvar *end-timestamp* nil) + +(defun generate-events (user count &optional delay) + (setf *start-timestamp* (get-universal-time)) + (loop for i from 1 upto count do + (let ((url (get-a-url user i))) + (sleep delay) + (fetch-url url user) + (sleep delay) + (analyze-url url user) + (sleep delay))) + (setf *end-timestamp* (get-universal-time))) + +(defun get-a-url (user seq) + (let ((url (make-instance 'url-record :url (format nil "http://www.common-lisp.net/~A/" seq)))) + (log-event user :received-url url) + url)) + +(defun fetch-url (url user) + (setf (url-record-fetched url) t) + (log-event user :fetched-url url)) + +(defun analyze-url (url user) + (setf (url-record-analyzed url) t) + (log-event user :analyzed-url url)) + +;; Top Level Test Code + +(defun test-generate-and-report (name store-spec) + (open-store store-spec) + (generate-events name 10 0.2) + (report-events name) + (close-store)) + +(defun report-events (name) + (let ((first-third-start *start-timestamp*) + (first-third-end (+ *start-timestamp* + (/ (- *end-timestamp* *start-timestamp*) 3)))) + (report-events-by-time name first-third-start first-third-end))) + --- /project/elephant/cvsroot/elephant/src/index-utils.lisp 2006/01/30 05:09:12 1.1 +++ /project/elephant/cvsroot/elephant/src/index-utils.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,128 @@ + + +(in-package :elephant) + +;; +;; Simple utilities for managing synchronization between class +;; definitions and database state +;; + +(defmethod class-index-cached? ((class persistent-metaclass)) + (and (slot-boundp class '%index-cache) + (subtypep (type-of (%index-cache class)) 'btree))) + +(defmethod determine-synch-method ((class persistent-metaclass)) + "This method should be called on the class if the %index-cache slot is + not a subtype of class btree to determine what synch method to call + on the current database btree. If DB doesn't exist, then you can ignore this" + (cond ((not (slot-boundp class '%index-cache)) + *default-indexed-class-synch-policy*) + ((member (%index-cache class) '(:class :union :db)) + (%index-cache class)) + (t *default-indexed-class-synch-policy*))) + +(defmethod set-db-synch ((class persistent-metaclass) method) + "Tell the class the synch method to use to synchronize the class indices + and the current class definition" + (assert (member method '(:class :db :union))) + (setf (%index-cache class) method)) + +;; +;; Differentiate derived indices from slot-based ones +;; + +(defparameter *derived-index-marker* "%%derived%%-") + +(defun make-derived-name (name) + (intern (format nil "~A~A" *derived-index-marker* name))) + +(defun derived-name? (name) + (when (symbolp name) (setf name (symbol-name name))) + (string= (subseq name 0 (min (length name) + (length *derived-index-marker*))) + *derived-index-marker*)) + +(defun get-derived-name-root (dname) + (when (symbolp dname) (symbol-name dname)) + (intern (subseq dname (length *derived-index-marker*)))) + +;; +;; Interface fn for slot key forms +;; + +(defun make-slot-key-form (class name) + (assert (member name (car (%persistent-slots class)))) + `(lambda (slot-index primary instance) + (declare (ignore slot-index primary)) + (read-slot-for-index ',(class-name class) ',name instance))) + +(defun read-slot-for-index (class-name slot-name instance) + (let ((class (find-class class-name))) + (multiple-value-bind (found? slot-def) (find-effective-slot-def class slot-name) + (when (and found? + (slot-boundp-using-class class instance slot-def)) + (values t (persistent-slot-reader instance slot-name)))))) + +(defun find-effective-slot-def (class slot-name) + (loop for slot in (class-slots class) do + (when (eq (slot-definition-name slot) slot-name) + (return (values t slot))))) + + +;; +;; Simplify the computations for derived parameters +;; + +(defun make-derived-key-form (dform) + "Change the index function interface for derived class slotsw + to better handle the various use cases. The provided function + accepts a single argument, the class instance to comput a + dervied parameter against. Dervied indices can + specify that the result should not be indexed by returning + two values (values nil t) the second of which is an ignore + specifier. Normal functions just return the value which is + an implicit index command. Accessors that compute against + unbound slots are silently ignored (ie initialization) and + errors of other types produce warnings and are ignored. This + handles both named functions and anonymous lambdas." + `(lambda (slot-index primary instance) + (declare (ignore slot-index primary)) + (compute-derived-key-result instance #',dform))) + +(defun compute-derived-key-result (instance fn) + (handler-case + (multiple-value-bind (val ignore) + (funcall fn instance) + (if ignore + (values nil nil) + (values t val))) + (unbound-slot () + (values nil nil)) + (error (e) + (warn "Error ~A computing derived index for on instance ~A" e instance) + (values nil nil)))) + +;; +;; This has turned out to be useful for debugging +;; + + +(defun describe-db-class-index (class-name &key (sc *store-controller*)) + (let ((class-idx (find-class-index class-name :sc sc))) + (if class-idx + (let ((names nil)) + (maphash (lambda (k v) + (declare (ignore v)) + (push k names)) + (indices-cache class-idx)) + (format t "Class Index: ~A~%" class-name) + (format t "~{~A~%~}" (nreverse names))) + (format t "No persistent index for class ~A.~%" class-name)))) + +(defun wipe-indexed-class (name) + (ignore-errors + (disable-class-indexing name) + (reset-instance-cache *store-controller*) + (setf (find-class name) nil))) + + --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/01/26 04:03:44 1.1 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,548 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; slot-index.lisp -- use btree collections to track objects by slot values +;;; via metaclass options or accessor :after methods +;;; +;;; Initial version 1/24/2006 Ian Eslick +;;; eslick at alum mit edu +;;; +;;; License: Lisp Limited General Public License +;;; http://www.franz.com/preamble.html +;;; + +(in-package "ELEPHANT") + +;; +;; User level class indexing control protocol +;; +;; Operates against the current *store-controller* +;; but many accept a :sc keyword to change the controller +;; The specific indices created can be specialized on the +;; controller type. See the internal implementor protocol +;; below. + +(defparameter *default-indexed-class-synch-policy* :class + "[:union | :db | :class] determines which reference defines + the indexing structure after a reconnect to a persistent + store. If the class is redefined, the default is that the + class dominates. Changing this parameter alters the + default behavior to :union (merge indexed slots from database + and class definition) or :db which changes the indexing of + the class to match the db. This can fail in several ways: + a) the class does not have a persistent slot defined for + a slot index (will be treated as derived & fail on write) + b) A slot has been added with the name of a derived index + this will be confusing + c) The key-slot function definitions (if not an anoymous + lambda) may have changed leading to unexpected indexing") + +(defgeneric find-class-index (persistent-metaclass &rest rest) + (:documentation "This method is the way to access the class index via + the class object. We can always fetch it or we can cache it in + the class itself. It returns an indexed-btree.")) + +(defgeneric find-inverted-index (persistent-metaclass index-name &key null-on-fail) + (:documentation "This method finds an inverted index defined on + the class described by persistent-metaclass.")) + +(defgeneric enable-class-indexing (persistent-metaclass slot-names &rest rest) + (:documentation "Enable a class instance index for this object. It's + an expensive thing to support on writes so know that you need it + before you do it.")) + +(defgeneric disable-class-indexing (persistent-metaclass &rest rest) + (:documentation "Delete and remove class instance indexing and any + secondary indices defined against it")) + +(defgeneric add-class-slot-index (persistent-metaclass slot-name &rest rest) + (:documentation "Add a per-slot class index option to the class + index based on the class accessor method")) + +(defgeneric remove-class-slot-index (persistent-metaclass slot-name &key sc) + (:documentation "Remove the per-slot index from the db")) + +(defgeneric add-class-derived-index (persistent-metaclass name derived-defun &rest rest) + (:documentation "Add a simple secondary index to this class based on + a function that computes a derived parameter. WARNING: derived + parameters are only valid on persistent slots. An arbitrary function + here will fail to provide consistency on transient slots or global + data that is not stored in the persistent store. Derived indexes are + deleted and rebuilt when a class is redefined")) + +(defgeneric remove-class-derived-index (persistent-metaclass name &rest rest) + (:documentation "Remove a derived index by providing the derived name + used to name the derived index")) + + +;; =========================== +;; INDEX UPDATE ROUTINE +;; =========================== + +(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) + "Anything that side effects a persistent-object slot should call this to keep + the dependant indices in synch. Only classes with derived indices need to + update on writes to non-indexed slots." + (let ((slot-name (slot-definition-name slot-def)) + (oid (oid instance))) + (declare (type fixnum oid)) + (if (no-indexing-needed? class instance slot-def oid) + (with-transaction () + (persistent-slot-writer new-value instance slot-name)) + (let ((class-idx (find-class-index class)) + (*auto-commit* nil)) +;; (format t "Indexing object: ~A oid: ~A~%" instance oid) + (with-transaction () + ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement + (when (get-value oid class-idx) + (remove-kv oid class-idx)) + (persistent-slot-writer new-value instance slot-name) + (setf (get-value oid class-idx) instance)))))) + + +(defun no-indexing-needed? (class instance slot-def oid) + (or (and (not (indexed slot-def)) ;; not indexed + (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes + (member oid *inhibit-indexing-list*))) ;; currently inhibited + +;; =========================== +;; CLASS INDEX INTERFACE +;; =========================== + +(defmethod find-class-index ((class-name symbol) &key (sc *store-controller*)) + (find-class-index (find-class class-name) :sc sc)) + +(defmethod find-class-index ((class persistent-metaclass) &key (sc *store-controller*)) + (ensure-finalized class) + (if (class-index-cached? class) + ;; we've got a cached reference, just return it + (%index-cache class) + (multiple-value-bind (btree found) + (get-value (class-name class) (controller-class-root sc)) + (if found + (cache-existing-class-index class btree sc) + (cache-new-class-index class sc))))) + +(defun ensure-finalized (class) + (when (not (class-finalized-p class)) + (warn "Manually finalizing class ~A" (class-name class)) + (finalize-inheritance class))) + +(defun cache-existing-class-index (class btree sc) + "If we have a persistent index already, assign, synchronize & return it" + (let ((method (determine-synch-method class))) + (setf (%index-cache class) btree) + (synchronize-class-to-store class :sc sc :method method) + btree)) + +(define-condition persistent-class-not-indexed (error) + ((class-obj :initarg :class :initarg nil :reader :unindexed-class-obj))) + +(defun cache-new-class-index (class sc) + "If not cached or persistent then this is a new class, make the new index" + (if (indexed class) + (enable-class-indexing class (indexing-record-slots (indexed-record class)) :sc sc) + (signal 'persistent-class-not-indexed + :class class + :format-control "Class ~A is not enabled for indexing" + :format-arguments (list (class-name class))))) + + +(defmethod find-inverted-index ((class symbol) slot &key (null-on-fail nil)) + (find-inverted-index (find-class class) slot :null-on-fail null-on-fail)) + +(defmethod find-inverted-index ((class persistent-metaclass) slot &key (null-on-fail nil)) + (let* ((cidx (find-class-index class)) + (dslot (make-derived-name slot)) + (idx (or (get-index cidx slot) + (get-index cidx dslot)))) + (if idx + idx + (if null-on-fail + nil + (error "Inverted index ~A not found for class ~A with + persistent slots: ~A" slot (class-name class) (car (%persistent-slots class))))))) + +(defmethod find-inverted-index-names ((class persistent-metaclass)) + (let ((names nil)) + (maphash (lambda (name idx) + (declare (ignore idx)) + (push name names)) + (indices (find-class-index class))) + names)) + +;; ============================= +;; INDEXING INTERFACE +;; ============================= + +(defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*)) + (let ((croot (controller-class-root sc))) + (multiple-value-bind (btree found) + (get-value (class-name class) croot) + (declare (ignore btree)) + (when found (error "Class is already enabled for indexing! Run disable class indexing to clean up."))) + ;; Put class instance index into the class root & cache it in the class object + (with-transaction (:store-controller sc) + (let ((class-idx (build-indexed-btree sc))) + (setf (get-value (class-name class) croot) class-idx) + (setf (%index-cache class) class-idx) + ;; Add all the indexes + (loop for slot in indexed-slot-names do + (add-class-slot-index class slot :populate nil :sc sc)) + ;; Sanity check + (let ((record (indexed-record class))) + (declare (ignorable record)) + (assert (indexed class))) + class-idx)))) + +(defmethod disable-class-indexing ((class-name symbol) &key (errorp t) (sc *store-controller*)) + (let ((class (find-class class-name errorp))) + (when class + (disable-class-indexing class :sc sc)))) + +(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp t)) + (let ((class-idx (find-class-index class :sc sc))) + (unless class-idx (return-from disable-class-indexing nil)) + ;; Remove all instance key/value data from the class index (& secondary indices) + (with-transaction (:store-controller sc) + (with-btree-cursor (cur class-idx) + (when (cursor-first cur) + (loop while (cursor-delete cur))))) + ;; Get the names of all indices & remove them + (let ((names nil)) + (maphash (lambda (name secondary-index) + (declare (ignore secondary-index)) + (push name names)) + (indices-cache class-idx)) + (dolist (name names) + (if (member name (class-slots class)) + (remove-class-slot-index class name) + (with-transaction (:store-controller sc) + (remove-index class-idx name))))) + ;; Drop the class instance index from the class root + (with-transaction (:store-controller sc) + (remove-kv (class-name class) (controller-class-root sc))) + (setf (%index-cache class) nil) + ;; Clear out the current class + (update-indexed-record class nil) + )) + +(defmethod add-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) + (add-class-slot-index (find-class class) slot-name :sc sc)) + +(defmethod add-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (populate t) (update-class t)) + (if (find-inverted-index class slot-name :null-on-fail t) + (warn "Duplicate slot index named ~A requested for class ~A. Ignoring." + slot-name (class-name class)) + (progn + (when update-class (register-indexed-slot class slot-name)) + (with-transaction (:store-controller sc) + (add-index (find-class-index class :sc sc) + :index-name slot-name + :key-form (make-slot-key-form class slot-name) + :populate populate)) + t))) + +(defmethod remove-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) + (remove-class-slot-index (find-class class) slot-name :sc sc)) + +(defmethod remove-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (update-class t)) + ;; NOTE: Write routines to recover BDB storage when you've wiped an index... + ;; NOTE: If the transaction aborts we should not update class slots? + (if (find-inverted-index class slot-name :null-on-fail t) + (progn + (when update-class (unregister-indexed-slot class slot-name)) + (with-transaction (:store-controller sc) + (remove-index (find-class-index class :sc sc) slot-name)) + t) + (progn + (warn "Slot index ~A not found for class ~A" slot-name (class-name class)) + nil))) + +(defmethod add-class-derived-index ((class symbol) name derived-defun &key (sc *store-controller*) (populate t)) + (add-class-derived-index (find-class class) name derived-defun :sc sc :populate populate)) + +(defmethod add-class-derived-index ((class persistent-metaclass) name derived-defun &key (populate t) (sc *store-controller*) (update-class t)) + (let ((class-idx (find-class-index class :sc sc))) + (if (find-inverted-index class (make-derived-name name) :null-on-fail t) + (error "Duplicate derived index requested named ~A on class ~A" name (class-name class)) + (progn + (when update-class (register-derived-index class name)) + (with-transaction (:store-controller sc) + (add-index class-idx + :index-name name + :key-form (make-derived-key-form derived-defun) + :populate populate)))))) + +(defmethod remove-class-derived-index ((class symbol) name &key (sc *store-controller*)) + (remove-class-derived-index (find-class class) name :sc sc)) + +(defmethod remove-class-derived-index ((class persistent-metaclass) name &key (sc *store-controller*) (update-class t)) + (if (find-inverted-index class name :null-on-fail t) + (progn + (when update-class (unregister-derived-index class name)) + (with-transaction (:store-controller sc) + (remove-index (find-class-index class :sc sc) name)) + t) + (progn + (warn "Derived index ~A does not exist in ~A" name (class-name class)) + nil))) + +;; ========================= +;; Low level cursor API +;; ========================= + +(defgeneric make-inverted-cursor (persistent-metaclass name) + (:documentation "Define a cursor on the inverted (slot or derived) index")) + +(defgeneric make-class-cursor (persistent-metaclass) + (:documentation "Define a cursor over all class instances")) + +;; TODO! +;;(defgeneric make-join-cursor ((class persistent-metaclass) &rest specification) +;; (:documentation "Make a join cursor using the slot-value pairs in +;; the specification assoc-list. Support for complex queries +;; requiring new access to db-functions and a new cursor type")) + +;; implementation +(defmethod make-inverted-cursor ((class persistent-metaclass) name) + (make-cursor (find-inverted-index class name))) + +(defmacro with-inverted-cursor ((var class name) &body body) + `(let ((,var (make-inverted-cursor ,class ,name))) + (unwind-protect (progn , at body) + (cursor-close ,var)))) + +(defmethod make-class-cursor ((class persistent-metaclass)) + (make-cursor (find-class-index class))) + +(defmacro with-class-cursor ((var class) &body body) + `(let ((,var (make-class-cursor ,class))) + (unwind-protect (progn , at body) + (cursor-close ,var)))) + + +;; ========================= +;; User-level lisp API +;; ========================= + +(defgeneric get-instances-by-class (persistent-metaclass)) +(defgeneric get-instances-by-value (persistent-metaclass slot-name value)) +(defgeneric get-instances-by-range (persistent-metaclass slot-name start end)) + +;; map instances +;; iterate over instances + +(defmethod get-instances-by-class ((class symbol)) + (get-instances-by-class (find-class class))) + +(defmethod get-instances-by-class ((class persistent-metaclass)) + (let ((instances nil) + (cidx (find-class-index class))) + (with-btree-cursor (cur cidx) + (multiple-value-bind (exists? key val) (cursor-first cur) + (declare (ignore key)) + (when exists? + (push val instances) + (loop + (multiple-value-bind (exists? key val) (cursor-next cur) + (declare (ignore key)) + (if exists? + (push val instances) + (return-from get-instances-by-class instances))))))))) + +(defmethod get-instances-by-value ((class symbol) slot-name value) + (get-instances-by-value (find-class class) slot-name value)) + +(defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) + (let ((instances nil)) + (with-btree-cursor (cur (find-inverted-index class slot-name)) + (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) + (declare (ignore skey pkey)) + (when exists? + (push val instances) + (loop + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (declare (ignorable skey pkey)) + (if exists? + (push val instances) + (return-from get-instances-by-value instances))))))))) + +(defmethod get-instances-by-range ((class symbol) slot-name start end) + (get-instances-by-range (find-class class) slot-name start end)) + +(defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) + (with-inverted-cursor (cur class idx-name) + (labels ((next-range (instances) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) + (declare (ignore pkey)) + (if (and exists? (<= skey end)) + (next-in-range skey (cons val instances)) + (nreverse instances)))) + (next-in-range (key instances) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (declare (ignore pkey skey)) + (if exists? + (next-in-range key (cons val instances)) + (progn + (cursor-pset-range cur key) + (next-range instances)))))) + (multiple-value-bind (exists? skey val pkey) (cursor-pset-range cur start) + (declare (ignore pkey)) + (if (and exists? (<= skey end)) + (next-in-range skey (cons val nil)) + nil))))) + +(defun drop-instances (instances &key (sc *store-controller*)) + (assert (consp instances)) + (with-transaction (:store-controller sc) [151 lines skipped] --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/05 23:13:07 1.12 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/07 23:23:51 1.13 @@ -24,6 +24,7 @@ (make-hash-table :test 'equal)) (defun connection-is-indeed-open (con) + (declare (ignore con)) t ;; I don't yet know how to implement this ) @@ -65,17 +66,23 @@ to user-defined classes and collections.)")) (defclass persistent-metaclass (standard-class) - ((%persistent-slots :accessor %persistent-slots)) + ((%persistent-slots :accessor %persistent-slots) + (%indexed-slots :accessor %indexed-slots) + (%index-cache :accessor %index-cache)) (:documentation "Metaclass for persistent classes. Use this metaclass to define persistent classes. All slots are persistent by -default; use the :transient flag otherwise.")) +default; use the :transient flag otherwise. Slots can also +be indexed for by-value retrieval.")) + +;; +;; Persistent slot maintenance +;; (defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) (car (%persistent-slots class)) - nil) - (car (%persistent-slots class))) + nil)) (defmethod persistent-slots ((class standard-class)) nil) @@ -91,8 +98,9 @@ nil) ))) + (defclass persistent-slot-definition (standard-slot-definition) - ()) + ((indexed :accessor indexed :initarg :indexed :initform nil :allocation :instance))) (defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ()) @@ -117,6 +125,115 @@ (defmethod transient ((slot persistent-direct-slot-definition)) nil) +;; +;; Indexed slots maintenance +;; + +;; This just encapsulates record keeping a bit +(defclass indexing-record () + ((slots :accessor indexing-record-slots :initarg :slots :initform nil) + (derived-count :accessor indexing-record-derived :initarg :derived :initform 0))) + +(defmethod print-object ((obj indexing-record) stream) + (format stream "#INDEXING-RECORD" + (length (indexing-record-slots obj)) + (length (indexing-record-derived obj)))) + +(defmethod indexed-record ((class standard-class)) + nil) +(defmethod indexed-record ((class persistent-metaclass)) + (car (%indexed-slots class))) + +(defmethod old-indexed-record ((class persistent-metaclass)) + (cdr (%indexed-slots class))) + +(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list) + (let ((oldrec (if (slot-boundp class '%indexed-slots) + (indexed-record class) + nil))) + (setf (%indexed-slots class) + (cons (make-instance 'indexing-record + :slots new-slot-list + :derived (when oldrec (indexing-record-derived oldrec))) + (if oldrec oldrec nil))))) + +(defun indexed-slot-names-from-defs (class) + (let ((slot-definitions (class-slots class))) + (loop for slot-definition in slot-definitions + when (and (subtypep (type-of slot-definition) 'persistent-slot-definition) + (indexed slot-definition)) + collect (slot-definition-name slot-definition)))) + +(defmethod register-indexed-slot ((class persistent-metaclass) slot) + "This method allows for post-definition update of indexed status of + class slots. It changes the effective method so we can rely on + generic function dispatch for differentated behavior" + ;; update record + (let ((record (indexed-record class))) + (unless (member slot (car (%persistent-slots class))) + (error "Tried to register slot ~A as index which isn't a persistent slot" slot)) + (unless (member slot (indexing-record-slots record)) +;; This is a normal startup case, but during other cases we'd like +;; the duplicate warning +;; (warn "Tried to index slot ~A which is already indexed" slot)) + (push slot (indexing-record-slots record)))) + ;; change effective slot def + (let ((slot-def (find-slot-def-by-name class slot))) + (unless slot-def + (error "Slot definition for slot ~A not found, inconsistent state in + class ~A" slot (class-name class))) + (setf (slot-value slot-def 'indexed) t))) + +(defmethod unregister-indexed-slot (class slot) + "Revert an indexed slot to it's original state" + ;; update record + (let ((record (indexed-record class))) + (unless (member slot (indexing-record-slots record)) + (error "Tried to unregister slot ~A which is not indexed" slot)) + (setf (indexing-record-slots record) (remove slot (indexing-record-slots record)))) + ;; change effective slot def status + (let ((slot-def (find-slot-def-by-name class slot))) + (unless slot-def + (error "Slot definition for slot ~A not found, inconsistent state in + class ~A" slot (class-name class))) + (setf (slot-value slot-def 'indexed) nil))) + +(defmethod register-derived-index (class name) + "Tell the class that it has derived indices defined against it + and keep a reference count" + (let ((record (indexed-record class))) + (push name (indexing-record-derived record)))) + +(defmethod unregister-derived-index (class name) + (let ((record (indexed-record class))) + (setf (indexing-record-derived record) (remove name (indexing-record-derived record))))) + +(defmethod indexed ((class persistent-metaclass)) + (and (slot-boundp class '%indexed-slots ) + (or (indexing-record-slots (indexed-record class)) + (indexing-record-derived (indexed-record class))))) + +(defmethod indexed ((slot standard-slot-definition)) nil) +(defmethod indexed ((class standard-class)) nil) + +(defvar *inhibit-indexing-list* nil + "Use this to avoid updating an index inside + low-level functions that update groups of + slots at once. We may need to rethink this + if we go to a cheaper form of update that + doesn't batch update all indices") + +(defun inhibit-indexing (uid) + (pushnew uid *inhibit-indexing-list*)) + +(defun uninhibit-indexing (uid) + (setf *inhibit-indexing-list* + (delete uid *inhibit-indexing-list*))) + +;; +;; Original support for persistent slot protocol +;; + #+allegro (defmethod excl::valid-slot-allocation-list ((class persistent-metaclass)) '(:instance :class :database)) @@ -128,12 +245,16 @@ "Checks for the transient tag (and the allocation type) and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) - (transient-p (getf initargs :transient))) + (transient-p (getf initargs :transient)) + (indexed-p (getf initargs :indexed))) (when (consp transient-p) (setq transient-p (car transient-p))) + (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and (eq allocation-key :class) transient-p) (find-class 'transient-direct-slot-definition)) ((and (eq allocation-key :class) (not transient-p)) (error "Persistent class slots are not supported, try :transient t.")) + ((and indexed-p transient-p) + (error "Cannot declare slots to be both transient and indexed")) (transient-p (find-class 'transient-direct-slot-definition)) (t @@ -161,9 +282,13 @@ (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) "Chooses the persistent or transient effective slot definition class depending on the keyword." - (let ((transient-p (getf initargs :transient))) + (let ((transient-p (getf initargs :transient)) + (indexed-p (getf initargs :indexed))) (when (consp transient-p) (setq transient-p (car transient-p))) - (cond (transient-p + (when (consp indexed-p) (setq indexed-p (car indexed-p))) + (cond ((and indexed-p transient-p) + (error "Cannot declare a slot to be both indexed and transient")) + (transient-p (find-class 'transient-effective-slot-definition)) (t (find-class 'persistent-effective-slot-definition))))) @@ -213,11 +338,13 @@ (defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions) (let ((initargs (call-next-method))) (if (ensure-transient-chain slot-definitions initargs) - (append initargs '(:transient t)) - (progn - (setf (getf initargs :allocation) :database) - initargs)))) - + (setf initargs (append initargs '(:transient t))) + (setf (getf initargs :allocation) :database)) + ;; Effective slots are indexed only if the most recent slot definition + ;; is indexed. NOTE: Need to think more about inherited indexed slots + (if (indexed (first slot-definitions)) + (append initargs '(:indexed t)) + initargs))) (defmacro persistent-slot-reader (instance name) `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance))) @@ -229,7 +356,7 @@ (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))) + (if buf (deserialize buf :sc (check-con (:dbcn-spc-pst ,instance))) #+cmu (error 'unbound-slot :instance ,instance :slot ,name) #-cmu @@ -301,7 +428,7 @@ (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)) + when (subtypep (type-of slot-definition) 'persistent-effective-slot-definition) collect (slot-definition-name slot-definition)))) (defun transient-slot-names (class) --- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/04 22:25:09 1.18 +++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/07 23:23:51 1.19 @@ -102,8 +102,8 @@ (eval-when (:compile-toplevel :load-toplevel) (defparameter *c-library-extension* - #+macosx "dylib" - #-macosx "so" )) + #+(or darwin macosx) "dylib" + #-(or darwin macosx) "so" )) (eval-when (:compile-toplevel :load-toplevel) --- /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2006/02/04 22:25:09 1.3 +++ /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2006/02/07 23:23:51 1.4 @@ -25,7 +25,6 @@ (:metaclass persistent-metaclass) (:documentation "A SQL-based BTree supports secondary indices.")) - (defmethod get-value (key (bt sql-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3))) From ieslick at common-lisp.net Wed Feb 8 03:23:12 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 7 Feb 2006 21:23:12 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060208032312.7C6346000C@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv713 Modified Files: TODO Log Message: Minor cleanup of indexing tests, declarations and rule-based code. 100% of tests pass under allegro 7.0 and Mac OS X. --- /project/elephant/cvsroot/elephant/TODO 2006/02/04 22:25:09 1.9 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/08 03:23:12 1.10 @@ -1,3 +1,73 @@ +Feb 6, 2006 + +Release plan in-discussion with Robert and Ian + +Upcoming release ideas. + +0.6.0 - Adding default class/slot indexing +- Finish indexing tests (Ian) +- Documentation update (Robert) +- Tutorial example rethink: update the blog tutorial using indexed + objects to create different views as well as integrating something + like logging for admin or version control purposes. (Both?) + +0.6.1 - performance, safety and portability + +Stability: +- Add clsql like support for building .so/.dylib from asdf loader on most systems +- Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) +- Cleanup multi-repository operation (a simple registry of open stores, + clear object-repository associations) (Both) +- Think through default vs. explicit store referencing all over the APIs (Both) +- Cleaner failure modes if operations are performed without repository (Both) +- Add asserts if *auto-index* is false and we're not in a transaction + to help users avoid lockups in bdb? Should be able to turn off for + performance but it will help catch missing with-transaction statemetns + in user code. (Both) +- BDB: determine how to detect deadlock conditions as an optional run-safe mode? (?) + Does BDB have timeouts enabled on select? (Ian) +- (From Ben's e-mail) We are storing persistent objects incorrectly. They should be + stored only as OIDs, and we should have a separate OID->class table. This way + change-class can be handled correctly (Ian) + +Performance: +- Metering and understanding locking issues. Large transactions seem + to use a lot of locks. In general understanding how to use Sleepycat + efficiently seems like a good thing. (Both) +- Add dependency information into secondary index callback functions so that + we can more easily compute which indices need to be updated to avoid the + global remove/add in order to maintain consistency (Ian) +- Reclaim table storage on index drop (Ian) +- Higher performance fix for allegro unicode serialization workaround than + my current one (Ian) + +Indexing features: +- Add a class-indexing class option to the metaclass so we can maintain class instances + index without any secondary indices or indexed slots (Ian) +- on class change, new slots should have their initform values pushed + into the slot value as if the slot was being created the first time + (currently this doesn't happen) (Ian) + +Bugs: +- anything else reported against 0.5.0/0.6.0 + +0.6.2 - New operating modes + - simple object query language (Ian - orthogonal, on main branch) + - integrate support for your in-memory database (on a separate branch) + - repository browser (Ian - orthogonal, on main branch) + (a simple REPL tool to see what classes are in a repository and + what state they're in...useful for long-lived repositories) + +0.6.3 - Query expansion + - Add needed support (if any) for persistent graph structures & +queries (Ian on a branch) + + + + + + + Feb. 4, 2006 As of 0.5.0, we have seem to have a stable suite on From ieslick at common-lisp.net Wed Feb 8 03:23:12 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 7 Feb 2006 21:23:12 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060208032312.BCEA563002@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv713/src Modified Files: indexing.lisp Log Message: Minor cleanup of indexing tests, declarations and rule-based code. 100% of tests pass under allegro 7.0 and Mac OS X. --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/07 23:23:50 1.2 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/08 03:23:12 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; slot-index.lisp -- use btree collections to track objects by slot values -;;; via metaclass options or accessor :after methods +;;; indexing.lisp -- use btree collections to track objects by slot values +;;; via metaclass options or accessor :after methods ;;; ;;; Initial version 1/24/2006 Ian Eslick ;;; eslick at alum mit edu @@ -100,6 +100,7 @@ (defun no-indexing-needed? (class instance slot-def oid) + (declare (ignore instance)) (or (and (not (indexed slot-def)) ;; not indexed (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes (member oid *inhibit-indexing-list*))) ;; currently inhibited @@ -199,7 +200,7 @@ (when class (disable-class-indexing class :sc sc)))) -(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp t)) +(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*)) (let ((class-idx (find-class-index class :sc sc))) (unless class-idx (return-from disable-class-indexing nil)) ;; Remove all instance key/value data from the class index (& secondary indices) @@ -354,6 +355,8 @@ (get-instances-by-value (find-class class) slot-name value)) (defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) + (declare (optimize (speed 3) (safety 1) (space 1)) + (type (or string symbol) slot-name)) (let ((instances nil)) (with-btree-cursor (cur (find-inverted-index class slot-name)) (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) @@ -371,6 +374,9 @@ (get-instances-by-range (find-class class) slot-name start end)) (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) + (declare (optimize speed (safety 1) (space 1)) + (type fixnum start end) + (type string idx-name)) (with-inverted-cursor (cur class idx-name) (labels ((next-range (instances) (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) @@ -406,16 +412,21 @@ ;; TO READER: I got really tired of trying to figure out all ;; the messy conditionals and I figure default behaviors are something -;; others might want to modify, so here's what determines the -;; rule behavior. - -;; Rules match on the following state of the metaclass and -;; the current class-index in the database for a given slotname: +;; others might want to modify, so here's what determines the rule +;; behavior. +;; +;; Rules match on the following states of the metaclass and current +;; database class-index for each slotname currently in either of +;; those sources. Actions are taken, typically when a slot exists +;; in one but not the other or features like indexed/persistent +;; differ between the slots +;; ;; class state: ;; class-indexed - the slot is marked as indexed ;; class-persistent - the slot is marked as persistent (not indexed) ;; class-transient - the slot is marked transient ;; class-derived - the slot is in the derived list of the class +;; ;; database ;; db-slot - the database has a slot index ;; db-derived - the database has a derived index @@ -424,10 +435,12 @@ ;; (not indexed-slot) for example, to cover more than one feature ;; combination ;; -;; Each rule should apply uniquely to a given feature set -;; Actions taken include: -;; add-slot-index - add a new index to the db -;; remove-slot-index - remove a slot from the db +;; Each rule should apply uniquely to a given feature set. +;; +;; Actions taken when rules match can include: +;; +;; add-slot-index - add a new index with the slotname to the db +;; remove-slot-index - remove a slot with the slotname from the db ;; add-derived-index - xxx this makes no sense! xxx ;; remove-derived-index - remove a derived index from the db ;; unregister-indexed-slot - remove an indexed slot from the class metaobject @@ -436,6 +449,8 @@ ;; register-derived-index - register a derived index with the class metaobject ;; +;; DEFINE THE SYNCHRONIZATION RULES + (eval-when (:compile-toplevel) (defclass synch-rule () ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil) @@ -461,10 +476,8 @@ (db-derived class-persistent => remove-derived-index warn)) ;; NOTE: What about cases where we need to remove things as below? (:db ;; db changes class - ((not db-slot) class-indexed => - unregister-indexed-slot) - ((not db-derived) class-derived => - unregister-derived-index) + ((not db-slot) class-indexed => unregister-indexed-slot) + ((not db-derived) class-derived => unregister-derived-index) (db-slot class-persistent => register-indexed-slot) (db-slot class-transient => remove-indexed-slot) (db-derived class-transient => remove-derived-index warn) @@ -474,22 +487,34 @@ (not class-persistent) (not class-transient) => register-derived-slot))))) ) - + +;; TOP LEVEL METHOD + +(defun synchronize-class-to-store (class &key (sc *store-controller*) + (method *default-indexed-class-synch-policy*)) + (let ((slot-records (compute-class-and-ele-status class sc)) + (rule-set (cdr (assoc method *synchronize-rules*)))) + (apply-synch-rules class slot-records rule-set))) + +;; COMPUTING RULE APPLICABILITY AND FIRING (defun synch-rule-applicable? (rule features) (simple-match-set (synch-rule-lhs rule) features)) (defun simple-match-set (a b) + (declare (optimize (speed 3) (safety 1))) (cond ((null a) t) ((and (not (null a)) (null b)) nil) ((member (first a) b :test #'equal) (simple-match-set (cdr a) (remove (first a) b :test #'equal))) (t nil))) +(defparameter *print-synch-messages* nil) + (defun apply-synch-rule (rule class name) - (format t "Class/DB Synch: converting state ~A using ~A for ~A~%" - (synch-rule-lhs rule) (synch-rule-rhs rule) name) -;; (return-from apply-synch-rule nil) + (when *print-synch-messages* + (format t "Class/DB Synch: converting state ~A using ~A for ~A~%" + (synch-rule-lhs rule) (synch-rule-rhs rule) name)) (loop for action in (synch-rule-rhs rule) do (case action (add-slot-index (add-class-slot-index class name :update-class nil)) @@ -502,9 +527,20 @@ (register-derived-index (register-derived-index class name)) (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule)))))) -(defun synchronize-class-to-store (class &key (sc *store-controller*) - (method *default-indexed-class-synch-policy*)) - (let* ((*store-controller* sc) +(defun apply-synch-rules (class records rule-set) + (declare (optimize (speed 3) (safety 1))) + (labels ((slotname (rec) (car rec)) + (feature-set (rec) (cdr rec))) + (loop for record in records do + (loop for rule in rule-set + when (synch-rule-applicable? rule (feature-set record)) + do + (apply-synch-rule rule class (slotname record)))))) + +;; COMPUTE CURRENT STATE OF CLASS OBJECT AND DATABASE AFTER CHANGES + +(defun compute-class-and-ele-status (class &optional (store-controller *store-controller*)) + (let* ((*store-controller* store-controller) ;; db info (db-indices (find-inverted-index-names class)) (db-derived (mapcar #'get-derived-name-root @@ -525,24 +561,16 @@ (class-transient . ,other-slots) (db-slot . ,db-slot) (db-derived . ,db-derived)))) - (labels ((compute-feature (name set label) - (if (member name set) - label - `(not ,label))) - (compute-features (slotname) + (labels ((compute-features (slotname) (let ((features nil)) (loop for set in all-sets do (push (compute-feature slotname (cdr set) (car set)) features)) (cons slotname features))) - (slotname (rec) (car rec)) - (feature-set (rec) (cdr rec))) - (let ((rule-set (cdr (assoc method *synchronize-rules*))) - (slot-records (mapcar #'compute-features all-names))) - (loop for record in slot-records do - (loop - for rule in rule-set - when (synch-rule-applicable? rule (feature-set record)) - do - (apply-synch-rule rule class (slotname record)))))))) + (compute-feature (name set label) + (if (member name set) + label + `(not ,label)))) + (mapcar #'compute-features all-names)))) + From ieslick at common-lisp.net Wed Feb 8 03:23:13 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 7 Feb 2006 21:23:13 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060208032313.10D8E64002@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv713/tests Modified Files: testindexing.lisp Log Message: Minor cleanup of indexing tests, declarations and rule-based code. 100% of tests pass under allegro 7.0 and Mac OS X. --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/07 23:23:51 1.2 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/08 03:23:12 1.3 @@ -153,8 +153,7 @@ nil nil) -;; create 10k objects, write each object's -;; slots +;; create 10k objects, write each object's slots (defclass stress-normal () ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed nil) @@ -185,13 +184,18 @@ (start (/ count 2)) (end (1- (+ start size)))) (with-btree-cursor (cur normal-index) - (multiple-value-bind (value? key val) (cursor-next cur) - (declare (ignore key)) - (when (and value? - (>= (stress1 val) start) - (<= (stress1 val) end)) - (push val objects)))) - objects)) + (loop + (multiple-value-bind (value? key val) (cursor-next cur) + (declare (ignore key)) + (cond ((or (not value?) + (and value? + (>= (stress1 val) end))) + (return-from normal-range-lookup objects)) + ((and value? + (>= (stress1 val) start) + (<= (stress1 val) end)) + (push val objects))))) + objects))) (defun indexed-range-lookup (class count size) (let* ((start (/ count 2)) @@ -223,10 +227,11 @@ (normal-range-lookup *stress-count* *range-size*))) (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) + (prof:with-profiling (:type :time) (time (dotimes (i *range-size*) (declare (ignore i)) - (indexed-range-lookup 'stress-index *stress-count* *range-size*))) + (indexed-range-lookup 'stress-index *stress-count* *range-size*)))) t) t) From ieslick at common-lisp.net Fri Feb 10 01:39:13 2006 From: ieslick at common-lisp.net (ieslick) Date: Thu, 9 Feb 2006 19:39:13 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060210013913.2270A46012@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv5850 Modified Files: TODO Log Message: Added :index vs. :indexed slot option Improved tests and added some more Some minor cleanup --- /project/elephant/cvsroot/elephant/TODO 2006/02/08 03:23:12 1.10 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/10 01:39:12 1.11 @@ -7,20 +7,22 @@ 0.6.0 - Adding default class/slot indexing - Finish indexing tests (Ian) - Documentation update (Robert) -- Tutorial example rethink: update the blog tutorial using indexed - objects to create different views as well as integrating something - like logging for admin or version control purposes. (Both?) +- Add a class-indexing class option to the metaclass so we can maintain class instances + index without any secondary indices or indexed slots (Ian) +- Add :inverse-reader to slot options to create a named method that indexes into objects + based on slot values. Is this a GF or defun? Do we dispatch on class name or bake it in? 0.6.1 - performance, safety and portability Stability: - Add clsql like support for building .so/.dylib from asdf loader on most systems - Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) -- Cleanup multi-repository operation (a simple registry of open stores, - clear object-repository associations) (Both) +- Cleanup multi-repository operation (ensure that conflicts between an object's + registry and *store-controller* does not leed to lockup, especially with BDB (Both) - Think through default vs. explicit store referencing all over the APIs (Both) -- Cleaner failure modes if operations are performed without repository (Both) -- Add asserts if *auto-index* is false and we're not in a transaction +- Cleaner failure modes if operations are performed without repository or without + transaction or auto-commit (Both) + Add asserts if *auto-index* is false and we're not in a transaction to help users avoid lockups in bdb? Should be able to turn off for performance but it will help catch missing with-transaction statemetns in user code. (Both) @@ -34,36 +36,57 @@ - Metering and understanding locking issues. Large transactions seem to use a lot of locks. In general understanding how to use Sleepycat efficiently seems like a good thing. (Both) -- Add dependency information into secondary index callback functions so that - we can more easily compute which indices need to be updated to avoid the - global remove/add in order to maintain consistency (Ian) - Reclaim table storage on index drop (Ian) - Higher performance fix for allegro unicode serialization workaround than my current one (Ian) Indexing features: -- Add a class-indexing class option to the metaclass so we can maintain class instances - index without any secondary indices or indexed slots (Ian) -- on class change, new slots should have their initform values pushed +- On class change, new slots should have their initform values pushed into the slot value as if the slot was being created the first time (currently this doesn't happen) (Ian) Bugs: - anything else reported against 0.5.0/0.6.0 -0.6.2 - New operating modes +0.6.3 - Query & indexing expansion - simple object query language (Ian - orthogonal, on main branch) - - integrate support for your in-memory database (on a separate branch) - - repository browser (Ian - orthogonal, on main branch) + - Add dependency information into secondary index callback functions so that + we can more easily compute which indices need to be updated to avoid the + global remove/add in order to maintain consistency (Ian) + - Add needed support (if any) for persistent graph structures & queries (Ian on a branch) + +0.6.4 - Compliance & Documentation + - Update to support BDB 4.4 + - Tutorial example rethink: update the blog tutorial using indexed + objects to create different views as well as integrating something + like logging for admin or version control purposes. + - Finish serious update and review of users manual (building on 0.6.0 update) + - A guide to dealing with transactions + - A guide to dealing with multiple open stores + - A guide to performance + - An overview of licensing issues... + - Repository browser (Ian - orthogonal, on main branch) (a simple REPL tool to see what classes are in a repository and what state they're in...useful for long-lived repositories) -0.6.3 - Query expansion - - Add needed support (if any) for persistent graph structures & -queries (Ian on a branch) +0.6.4 - Additional datastructures? + - Support for cheap persistent sets (ala ACache) +Some placeholders & dreams features below... :) +0.7+: Major features + - A backend controller for AllegroCache (Ian) + - Prevalence-like in-memory database system (Robert?) + - Richer controller modes: + - Single-user mode (cache values in instance slots for fast reads, write-through) + - Prevalence mode (read/write to normal slots except on object creation or synch) + (in-memory slot indexing, on disk class) + (works for any backend) + - Concurrent mode (for backends that allow multiple processes to connect, current default) + - Controller 'switches' + - NoSynch - allow transactions to be lost on failure but maintains consistency instead of performance +0.8 - Lisp Backend? From ieslick at common-lisp.net Fri Feb 10 01:39:13 2006 From: ieslick at common-lisp.net (ieslick) Date: Thu, 9 Feb 2006 19:39:13 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060210013913.7D0894700A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv5850/src Modified Files: classes.lisp controller.lisp elephant.lisp index-tutorial.lisp metaclasses.lisp Log Message: Added :index vs. :indexed slot option Improved tests and added some more Some minor cleanup --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/07 23:23:50 1.19 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/10 01:39:13 1.20 @@ -98,9 +98,13 @@ #+allegro (defun make-persistent-writer (name slot-definition class class-name) - (eval `(defmethod (setf ,name) ((instance ,class-name) value) - (setf (slot-value-using-class ,class instance ,slot-definition) - value)))) + (let ((name (if (and (consp name) + (eq (car name) 'setf)) + name + `(setf ,name)))) + (eval `(defmethod ,name ((instance ,class-name) value) + (setf (slot-value-using-class ,class instance ,slot-definition) + value))))) #+allegro (defmethod initialize-accessors ((slot-definition persistent-slot-definition) class) --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/07 23:23:50 1.17 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/10 01:39:13 1.18 @@ -268,7 +268,7 @@ :auto-commit t :txn-nosync t)) ;; Open/close -(defmethod open-controller ((sc bdb-store-controller) &key (recover nil) +(defmethod open-controller ((sc bdb-store-controller) &key (recover t) (recover-fatal nil) (thread t)) (let ((env (db-env-create))) ;; thread stuff? --- /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/07 23:23:50 1.20 +++ /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/10 01:39:13 1.21 @@ -55,6 +55,7 @@ #:persistent #:persistent-object #:persistent-metaclass + #:defpclass #:persistent-collection #:btree #:bdb-btree #:sql-btree --- /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/07 23:23:50 1.2 +++ /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/10 01:39:13 1.3 @@ -5,10 +5,10 @@ (in-package :elephant-tutorial) (defclass simple-plog () - ((timestamp :accessor plog-timestamp :initarg :timestamp :indexed t) - (type :accessor plog-type :initarg :type :indexed t) + ((timestamp :accessor plog-timestamp :initarg :timestamp :index t) + (type :accessor plog-type :initarg :type :index t) (data :accessor plog-data :initarg :data) - (user :accessor plog-user :initarg :user :indexed t)) + (user :accessor plog-user :initarg :user :index t)) (:metaclass persistent-metaclass) (:documentation "Simple persistent log")) --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/07 23:23:51 1.13 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/10 01:39:13 1.14 @@ -76,6 +76,20 @@ be indexed for by-value retrieval.")) ;; +;; Top level defclass form - hide metaclass option +;; + +(defmacro defpclass (cname parents slot-defs &optional class-opts) + `(defclass ,cname ,parents + ,slot-defs + ,(add-persistent-metaclass class-opts))) + +(defun add-persistent-metaclass (class-opts) + (when (assoc :metaclass class-opts) + (error "User metaclass specification not allowed in defpclass")) + (append (list :metaclass 'persistent-metaclass) class-opts)) + +;; ;; Persistent slot maintenance ;; @@ -98,9 +112,8 @@ nil) ))) - (defclass persistent-slot-definition (standard-slot-definition) - ((indexed :accessor indexed :initarg :indexed :initform nil :allocation :instance))) + ((indexed :accessor indexed :initarg :index :initform nil :allocation :instance))) (defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ()) @@ -246,7 +259,7 @@ and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient)) - (indexed-p (getf initargs :indexed))) + (indexed-p (getf initargs :index))) (when (consp transient-p) (setq transient-p (car transient-p))) (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and (eq allocation-key :class) transient-p) @@ -283,7 +296,7 @@ "Chooses the persistent or transient effective slot definition class depending on the keyword." (let ((transient-p (getf initargs :transient)) - (indexed-p (getf initargs :indexed))) + (indexed-p (getf initargs :index))) (when (consp transient-p) (setq transient-p (car transient-p))) (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and indexed-p transient-p) @@ -343,7 +356,7 @@ ;; Effective slots are indexed only if the most recent slot definition ;; is indexed. NOTE: Need to think more about inherited indexed slots (if (indexed (first slot-definitions)) - (append initargs '(:indexed t)) + (append initargs '(:index t)) initargs))) (defmacro persistent-slot-reader (instance name) From ieslick at common-lisp.net Fri Feb 10 01:39:13 2006 From: ieslick at common-lisp.net (ieslick) Date: Thu, 9 Feb 2006 19:39:13 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060210013913.C66E14700B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv5850/tests Modified Files: elephant-tests.lisp testindexing.lisp Log Message: Added :index vs. :indexed slot option Improved tests and added some more Some minor cleanup --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/07 23:23:51 1.10 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/10 01:39:13 1.11 @@ -122,16 +122,19 @@ (setq *old-store* *store-controller*) (unwind-protect (progn - (open-store *testdb-path*) - (print (do-test 'indexing-basic)) - (print (do-test 'indexing-inherit)) - (print (do-test 'indexing-range)) - (print (do-test 'indexing-reconnect-db)) - (print (do-test 'indexing-change-class)) - (print (do-test 'indexing-redef-class)) - (print (do-test 'indexing-explicit-changes)) - (print (do-test 'indexing-timing)) - (close-store)) + (let ((*auto-commit* nil)) + (declare (special *auto-commit*) + (dynamic-extent *auto-commit*)) + (open-store *testdb-path*) + (print (do-test 'indexing-basic)) + (print (do-test 'indexing-inherit)) + (print (do-test 'indexing-range)) + (print (do-test 'indexing-reconnect-db)) + (print (do-test 'indexing-change-class)) + (print (do-test 'indexing-redef-class)) + (print (do-test 'indexing-explicit-changes)) + (print (do-test 'indexing-timing)) + (close-store))) (setq *store-controller* *old-store*))) (defun do-crazy-pg-tests() @@ -161,6 +164,8 @@ (when spec (with-open-store (spec) (let ((*auto-commit* nil)) + (declare (special *auto-commit*) + (dynamic-extent *auto-commit*)) (do-tests))))) (defun find-slot-def (class-name slot-name) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/08 03:23:12 1.3 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/10 01:39:13 1.4 @@ -30,11 +30,11 @@ (setf (find-class 'idx-one) nil) (defclass idx-one () - ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) (:metaclass persistent-metaclass)) (progn - (with-transaction () + (with-transaction (:store-controller *store-controller*) (setq inst1 (make-instance 'idx-one :slot1 1 :sc *store-controller*)) (setq inst2 (make-instance 'idx-one :slot1 1 :sc *store-controller*)) (setq inst3 (make-instance 'idx-one :slot1 3 :sc *store-controller*))) @@ -57,51 +57,64 @@ (setf (find-class 'idx-two) nil) (defclass idx-one () - ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) - (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed t) + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t) (slot3 :initarg :slot3 :initform 3 :accessor slot3) (slot4 :initarg :slot4 :initform 4 :accessor slot4 :transient t)) (:metaclass persistent-metaclass)) (defclass idx-two (idx-one) ((slot2 :initarg :slot2 :initform 20 :accessor slot2) - (slot3 :initarg :slot3 :initform 30 :accessor slot3 :indexed t) - (slot4 :initarg :slot4 :initform 40 :accessor slot4 :indexed t)) + (slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t) + (slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t)) (:metaclass persistent-metaclass)) (progn (with-transaction () - (setq inst1 (make-instance 'idx-two :sc *store-controller*))) + (setq inst1 (make-instance 'idx-one :sc *store-controller*)) + (setq inst2 (make-instance 'idx-two :sc *store-controller*))) (values (slot1 inst1) (slot2 inst1) (slot3 inst1) (slot4 inst1) + (slot1 inst2) + (slot2 inst2) + (slot3 inst2) + (slot4 inst2) + (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-one))) + '(slot1 slot2)) (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-two))) '(slot1 slot3 slot4))))) - 1 20 30 40 t) + 1 2 3 4 1 20 30 40 t t) (deftest indexing-range (progn ;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) - (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil) + (disable-class-indexing 'idx-two :errorp nil) + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-two) nil) (setf (find-class 'idx-one) nil) (defclass idx-one () - ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) (:metaclass persistent-metaclass)) (defun make-idx-one (val) - (make-instance 'idx-one :slot1 val :sc *store-controller*)) + (make-instance 'idx-one :slot1 val)) (with-transaction () (mapc #'make-idx-one '(1 1 1 2 2 4 5 5 5 6 10))) ;; Range should get multiple & single keys inclusive of ;; start and end - (let ((list (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6)))) - (equal list '(2 2 4 5 5 5 6)))) - t) + (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6)) + '(2 2 4 5 5 5 6)) ;; interior range + (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 0 2)) + '(1 1 1 2 2)) + (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 6 15)) + '(6 10)))) + t t t) (deftest indexing-reconnect-db (progn @@ -110,9 +123,9 @@ ;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) (defclass idx-two () - ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) (slot2 :initarg :slot2 :initform 2 :accessor slot2) - (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t)) + (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) (:metaclass persistent-metaclass)) (let ((*old-default* *default-indexed-class-synch-policy*) @@ -127,8 +140,8 @@ ;; Assume our db is out of synch with our class def (defclass idx-two () ((slot1 :initarg :slot1 :initform 1 :accessor slot1) - (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed t) - (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t)) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t) + (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) (:metaclass persistent-metaclass)) ;; Add an instance of the new class @@ -142,8 +155,52 @@ 2 2 t) (deftest indexing-change-class - nil - nil) + (progn + (disable-class-indexing 'idx-one :errorp nil) + (disable-class-indexing 'idx-two :errorp nil) + (setf (find-class 'idx-one) nil) + (setf (find-class 'idx-two) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t)) + (:metaclass persistent-metaclass)) + + (defclass idx-two () + ((slot1 :initarg :slot1 :initform 10 :accessor slot1 :index nil) + (slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t) + (slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t)) + (:metaclass persistent-metaclass)) + + (defmethod update-instance-for-different-class :before ((old idx-one) + (new idx-two) + &key) + (setf (slot3 new) (slot2 old))) + + (let ((*auto-commit* t) + (foo nil)) + (declare (special *auto-commit*) + (dynamic-extent *auto-commit*)) + (setf foo (make-instance 'idx-one)) + (change-class foo 'idx-two) + + (values + ;; shared data from original slot + (slot1 foo) + ;; verify old instance access fails + (signals-error (slot2 foo)) + ;; verify new instance is there + (slot3 foo) + (slot4 foo) + ;; verify proper indexing changes (none should lookup a value) + (get-instances-by-class 'idx-one) + (get-instances-by-value 'idx-one 'slot1 1) + (get-instances-by-value 'idx-one 'slot2 2) + ;; new indexes + (length (get-instances-by-class 'idx-two)) + (length (get-instances-by-value 'idx-two 'slot3 2)) + ))) + 1 t 2 40 nil nil nil 1 1) (deftest indexing-redef-class nil @@ -156,14 +213,14 @@ ;; create 10k objects, write each object's slots (defclass stress-normal () - ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed nil) - (stress2 :accessor stress2 :initarg :stress2 :initform nil :indexed nil)) + ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil) + (stress2 :accessor stress2 :initarg :stress2 :initform nil :index nil)) (:metaclass persistent-metaclass)) (defclass stress-index () - ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed t) - (stress2 :accessor stress2 :initarg :stress2 :initform 2 :indexed t) - (stress3 :accessor stress3 :initarg :stress3 :initform 3 :indexed nil)) + ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index t) + (stress2 :accessor stress2 :initarg :stress2 :initform 2 :index t) + (stress3 :accessor stress3 :initarg :stress3 :initform 3 :index nil)) (:metaclass persistent-metaclass)) (defvar normal-index nil) @@ -207,32 +264,43 @@ (deftest indexing-timing (progn - - (let ((insts (get-instances-by-class 'stress-index))) + (let ((insts (get-instances-by-class 'stress-index)) + (start nil) + (end nil) + (normal-time 0) + (index-time 0)) (when insts (drop-instances insts))) - (format t "~%Stress test normal setup time (~A):~%" *stress-count*) +;; (format t "~%Stress test normal setup time (~A):~%" *stress-count*) (with-transaction () - (time (normal-stress-setup *stress-count* 'stress-normal :stress2 10))) + (normal-stress-setup *stress-count* 'stress-normal :stress2 10) + ) - (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) +;; (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) (with-transaction () - (time (indexed-stress-setup *stress-count* 'stress-index :stress2 10))) + (indexed-stress-setup *stress-count* 'stress-index :stress2 10) + ) - (format t "~%Stress test normal lookup time (~A):~%" *range-size*) - (time - (dotimes (i *range-size*) - (declare (ignore i)) - (normal-range-lookup *stress-count* *range-size*))) +;; (format t "~%Stress test normal lookup time (~A):~%" *range-size*) + (setf start (get-internal-run-time)) + (dotimes (i *range-size*) + (declare (ignore i)) + (normal-range-lookup *stress-count* *range-size*)) + (setf end (get-internal-run-time)) + (setf normal-time (/ (- end start 0.0) internal-time-units-per-second)) - (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) - (prof:with-profiling (:type :time) - (time +;; (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) + (setf start (get-internal-run-time)) (dotimes (i *range-size*) (declare (ignore i)) - (indexed-range-lookup 'stress-index *stress-count* *range-size*)))) - t) + (indexed-range-lookup 'stress-index *stress-count* *range-size*)) + (setf end (get-internal-run-time)) + (setf index-time (/ (- end start 0.0) internal-time-units-per-second)) + + (format t "~%Ranged get of ~A/~A objects = Linear: ~A sec Indexed: ~A sec~%" + *range-size* *stress-count* normal-time index-time) + (> normal-time index-time)) t) From rread at common-lisp.net Tue Feb 14 15:25:10 2006 From: rread at common-lisp.net (rread) Date: Tue, 14 Feb 2006 09:25:10 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060214152510.E28802A034@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv373 Modified Files: bdb-enable.lisp indexing.lisp serializer.lisp Log Message: Thanks to Tayssir John Gabour for these bug fixes. --- /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/02/04 22:25:09 1.6 +++ /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/02/14 15:25:10 1.7 @@ -65,7 +65,7 @@ ;; "/db/ben/lisp/db43/lib/libdb.so" "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" ;; this works on FreeBSD - #+(and (or bsd freebsd) (not darwin macosx)) + #+(and (or bsd freebsd) (not darwin) (not macosx)) "/usr/local/lib/db43/libdb.so" #+(or darwin macosx) ;; for Fink (OS X) -- but I will assume Linux more common... --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/08 03:23:12 1.3 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/14 15:25:10 1.4 @@ -450,8 +450,8 @@ ;; ;; DEFINE THE SYNCHRONIZATION RULES +(eval-when (:compile-toplevel :load-toplevel) -(eval-when (:compile-toplevel) (defclass synch-rule () ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil) (rhs :accessor synch-rule-rhs :initarg :rhs :initform nil))) --- /project/elephant/cvsroot/elephant/src/serializer.lisp 2006/02/04 22:25:09 1.13 +++ /project/elephant/cvsroot/elephant/src/serializer.lisp 2006/02/14 15:25:10 1.14 @@ -466,7 +466,7 @@ (eval-when (:compile-toplevel :load-toplevel) (asdf:operate 'asdf:load-op :cl-base64) ) -(defun ser-deser-equal (x1 &keys sc) +(defun ser-deser-equal (x1 &key sc) (let* ( (x1s (serialize-to-base64-string x1)) (x1prime (deserialize-from-base64-string x1s :sc sc))) @@ -482,7 +482,7 @@ ) -(defun deserialize-from-base64-string (x &keys sc) +(defun deserialize-from-base64-string (x &key sc) (with-buffer-streams (other) (deserialize (sleepycat::buffer-write-byte-vector From rread at common-lisp.net Tue Feb 14 15:28:32 2006 From: rread at common-lisp.net (rread) Date: Tue, 14 Feb 2006 09:28:32 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060214152832.A71722A034@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv487 Modified Files: CREDITS Log Message: Adding some acknowledgements. --- /project/elephant/cvsroot/elephant/CREDITS 2005/11/23 17:51:31 1.6 +++ /project/elephant/cvsroot/elephant/CREDITS 2006/02/14 15:28:32 1.7 @@ -46,3 +46,10 @@ Dan Knapp fixed the fact that nil's were indistinguishable from unbound slots, and proved the system works with SQLite3. + +Tayssir John Gabbour has found two bugs on Feb. 14, 2006. + +Ian Eslick wrote src/indexing.lisp, which added major +convenience features for automatically indexing the a slot +in a class. + From ieslick at common-lisp.net Tue Feb 14 15:31:09 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 14 Feb 2006 09:31:09 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060214153109.499D42A034@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv1832 Modified Files: TODO Log Message: Updated TODO list. Minor tweak in indexing. --- /project/elephant/cvsroot/elephant/TODO 2006/02/10 01:39:12 1.11 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/14 15:31:09 1.12 @@ -7,16 +7,11 @@ 0.6.0 - Adding default class/slot indexing - Finish indexing tests (Ian) - Documentation update (Robert) -- Add a class-indexing class option to the metaclass so we can maintain class instances - index without any secondary indices or indexed slots (Ian) -- Add :inverse-reader to slot options to create a named method that indexes into objects - based on slot values. Is this a GF or defun? Do we dispatch on class name or bake it in? 0.6.1 - performance, safety and portability Stability: - Add clsql like support for building .so/.dylib from asdf loader on most systems -- Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) - Cleanup multi-repository operation (ensure that conflicts between an object's registry and *store-controller* does not leed to lockup, especially with BDB (Both) - Think through default vs. explicit store referencing all over the APIs (Both) @@ -28,19 +23,32 @@ in user code. (Both) - BDB: determine how to detect deadlock conditions as an optional run-safe mode? (?) Does BDB have timeouts enabled on select? (Ian) +- Fix backend dependency problems (missing functions with-transaction-sql, etc) + caused by not having clsql loaded. Backends should not cause such failures + and should use asdf to load their deps when the backends are instantiated; much + like clsql does now +- Remove build gensym warnings +- Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) - (From Ben's e-mail) We are storing persistent objects incorrectly. They should be stored only as OIDs, and we should have a separate OID->class table. This way - change-class can be handled correctly (Ian) + change-class can be handled correctly (Ian) ??? Performance: - Metering and understanding locking issues. Large transactions seem to use a lot of locks. In general understanding how to use Sleepycat - efficiently seems like a good thing. (Both) + efficiently seems like a good thing. (From Ben) - Reclaim table storage on index drop (Ian) - Higher performance fix for allegro unicode serialization workaround than my current one (Ian) +- Add dependency information into secondary index callback functions so that + we can more easily compute which indices need to be updated to avoid the + global remove/add in order to maintain consistency (Ian) Indexing features: +- Add a class-indexing class option to the metaclass so we can maintain class instances + index without any secondary indices or indexed slots (Ian) +- Add :inverse-reader to slot options to create a named method that indexes into objects + based on slot values. Is this a GF or defun? Do we dispatch on class name or bake it in? - On class change, new slots should have their initform values pushed into the slot value as if the slot was being created the first time (currently this doesn't happen) (Ian) @@ -50,9 +58,6 @@ 0.6.3 - Query & indexing expansion - simple object query language (Ian - orthogonal, on main branch) - - Add dependency information into secondary index callback functions so that - we can more easily compute which indices need to be updated to avoid the - global remove/add in order to maintain consistency (Ian) - Add needed support (if any) for persistent graph structures & queries (Ian on a branch) 0.6.4 - Compliance & Documentation @@ -69,8 +74,9 @@ (a simple REPL tool to see what classes are in a repository and what state they're in...useful for long-lived repositories) -0.6.4 - Additional datastructures? - - Support for cheap persistent sets (ala ACache) +0.6.5 - Additional datastructures? + - Native BDB persistent hashes (easy; can do on SQL backends?) + - Support for cheap persistent sets (medium? can do on SQL?) Some placeholders & dreams features below... :) From ieslick at common-lisp.net Tue Feb 14 15:31:09 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 14 Feb 2006 09:31:09 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060214153109.8CB572A034@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv1832/src Modified Files: indexing.lisp Log Message: Updated TODO list. Minor tweak in indexing. --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/14 15:25:10 1.4 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/14 15:31:09 1.5 @@ -399,12 +399,13 @@ nil))))) (defun drop-instances (instances &key (sc *store-controller*)) - (assert (consp instances)) - (with-transaction (:store-controller sc) - (let ((class-idx (find-class-index (class-of (first instances))))) - (mapc (lambda (instance) - (remove-kv (oid instance) class-idx)) - instances)))) + (when instances + (assert (consp instances)) + (with-transaction (:store-controller sc) + (let ((class-idx (find-class-index (class-of (first instances))))) + (mapc (lambda (instance) + (remove-kv (oid instance) class-idx)) + instances))))) ;; ============================= ;; CLASS / DB SYNCHRONIZATION From rread at common-lisp.net Wed Feb 15 01:54:07 2006 From: rread at common-lisp.net (rread) Date: Tue, 14 Feb 2006 19:54:07 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060215015407.442D74C008@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv17274 Modified Files: INSTALL TUTORIAL ele-bdb.asd ele-sqlite3.asd Log Message: Minor documentation fixes from Tayssir John Gabbour --- /project/elephant/cvsroot/elephant/INSTALL 2006/01/25 14:09:46 1.13 +++ /project/elephant/cvsroot/elephant/INSTALL 2006/02/15 01:54:07 1.14 @@ -64,7 +64,7 @@ Under Un*x, edit Makefile and run (using GNU make, gmake on BSD) -make install +make This compiles src/libsleepycat.c and installs it into @@ -109,9 +109,16 @@ Symlink elephant.asd to your asdf systems directory (mine is /usr/local/share/common-lisp/systems). Fire up lisp and -type +depending on your database backend: + +if you are using Sleepycat / Berkeley DB, type: + (asdf:operate 'asdf:load-op :ele-bdb) + +if you are using CL-SQL, type: + (asdf:operate 'asdf:load-op :ele-clsql) -(asdf:operate 'asdf:load-op :elephant) +if you are using SQLite3, type: + (asdf:operate 'asdf:load-op :ele-sqlite3) This will load and compile Elephant. This will also automatically load UFFI. --- /project/elephant/cvsroot/elephant/TUTORIAL 2004/09/02 15:11:58 1.6 +++ /project/elephant/cvsroot/elephant/TUTORIAL 2006/02/15 01:54:07 1.7 @@ -27,9 +27,16 @@ Assuming you've managed to install Elephant properly, -* (asdf:operate 'asdf:load-op :elephant) +* if you are using Sleepycat / Berkeley DB, type: + (asdf:operate 'asdf:load-op :ele-bdb) -will load the relevant files. +* or if you are using CL-SQL, type: + (asdf:operate 'asdf:load-op :ele-clsql) + +* or if you are using SQLite3, type: + (asdf:operate 'asdf:load-op :ele-sqlite3) + +which will load the relevant files. * (use-package "ELE") --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/04 22:25:09 1.4 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/15 01:54:07 1.5 @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-clsql.asd -- ASDF system definition for -;;; a CL-SQL based back-end for Elephant +;;; a Berkeley-DB based back-end for Elephant ;;; ;;; Initial version 10/12/2005 by Robert L. Read ;;; --- /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/05 23:13:07 1.3 +++ /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/15 01:54:07 1.4 @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-clsql.asd -- ASDF system definition for -;;; a CL-SQL based back-end for Elephant +;;; a SQLite3 based back-end for Elephant ;;; ;;; Initial version 10/12/2005 by Robert L. Read ;;; @@ -47,8 +47,8 @@ :version "0.1" :maintainer "Robert L. Read " :licence "GPL" - :description "Berkeley-DB based Object respository for Common Lisp" - :long-description "Including this loads the Berkeley-DB code; you may have to edit the pathname!" + :description "SQLite3 based Object respository for Common Lisp" + :long-description "Including this loads the SQLite3 code; you may have to edit the pathname!" :components ((:module :src From ieslick at common-lisp.net Wed Feb 15 04:18:39 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 14 Feb 2006 22:18:39 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060215041839.49E326D010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv3181/src Modified Files: classes.lisp metaclasses.lisp Log Message: Tentative fixes for change-class failure to update class index. --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/10 01:39:13 1.20 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/15 04:18:39 1.21 @@ -54,30 +54,34 @@ metaclass.") (:metaclass persistent-metaclass)) -;;(defmethod print-object ((obj persistent) stream) (defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys) - (declare (ignore initargs)) - (if (indexed (class-of instance)) - (progn - (let ((oid (oid instance))) - (declare (type fixnum oid)) - (inhibit-indexing oid) - (unwind-protect - (call-next-method) - (uninhibit-indexing oid)) - ;; Inhibit indexing if the object already was defined (ie being created from an oid) - ;; as it should be indexed already. This hack avoids a deadlock situation where we - ;; write the class or index page that we are currently reading via a cursor without - ;; going through the cursor abstraction. There has to be a better way to do this. - (when (not from-oid) - (let ((class-index (find-class-index (class-of instance)))) - (when class-index -;; (format t "Indexing initial instance: ~A :: ~A~%" oid instance) - (with-transaction () - (setf (get-value oid class-index) instance))))))) - ;; else - (call-next-method))) + (declare (ignorable initargs instance from-oid)) + (call-next-method)) + + +;; (defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys) +;; (if (indexed (class-of instance)) +;; (progn +;; (let ((oid (oid instance))) +;; (declare (type fixnum oid)) +;; (inhibit-indexing oid) +;; (unwind-protect +;; (call-next-method) +;; (uninhibit-indexing oid)) +;; ;; Inhibit indexing altogether if the object already was defined (ie being created +;; ;; from an oid) as it should be indexed already. This hack avoids a deadlock +;; ;; situation where we write the class or index page that we are currently reading +;; ;; via a cursor without going through the cursor abstraction. There has to be a +;; ;; better way to do this. +;; (when (not from-oid) +;; (let ((class-index (find-class-index (class-of instance)))) +;; (when class-index +;; ;; (format t "Indexing initial instance: ~A :: ~A~%" oid instance) +;; (with-transaction () +;; (setf (get-value oid class-index) instance))))))) +;; ;; else +;; (call-next-method))) (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." @@ -160,13 +164,16 @@ ;; (setf (%persistent-slots instance) ;; (cons (persistent-slot-names instance) nil))))) -(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) +(defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for implementations to optimize setting the slots via initforms and initargs in such a way that slot-value-using-class et al -aren't used. Calls the next method for the transient slots." +aren't used. We also handle writing any indices after the +class is fully initialized. Calls the next method for the transient +slots." (let* ((class (class-of instance)) + (oid (oid instance)) (persistent-slot-names (persistent-slot-names class))) (flet ((persistent-slot-p (item) (member item persistent-slot-names :test #'eq))) @@ -177,6 +184,8 @@ (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) + (inhibit-indexing oid) + (unwind-protect ;; initialize the persistent slots (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs @@ -187,23 +196,31 @@ (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) + 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)))) - ) + (funcall initfun))))) ;; (format t "transient-slot-inits ~A~%" transient-slot-inits) ;; (format t "indices boundp ~A~%" (slot-boundp instance 'indices)) ;; (format t "indices-caches boundp ~A~%" (slot-boundp instance 'indices-cache)) ;; let the implementation initialize the transient slots - (apply #'call-next-method instance transient-slot-inits initargs)))))) + (apply #'call-next-method instance transient-slot-inits initargs)) + (uninhibit-indexing oid)) + ;; Inhibit indexing altogether if the object already was defined (ie being created + ;; from an oid) as it should be indexed already. This hack avoids a deadlock + ;; situation where we write the class or index page that we are currently reading + ;; via a cursor without going through the cursor abstraction. There has to be a + ;; better way to do this. + (when (and (indexed class) (not from-oid)) + (let ((class-index (find-class-index (class-of instance)))) + (when class-index + (with-transaction () + (setf (get-value oid class-index) instance))))) + )))) (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; NOTE: probably should delete discarded slots, but we'll worry about that later --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/10 01:39:13 1.14 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/15 04:18:39 1.15 @@ -82,9 +82,9 @@ (defmacro defpclass (cname parents slot-defs &optional class-opts) `(defclass ,cname ,parents ,slot-defs - ,(add-persistent-metaclass class-opts))) + ,(add-persistent-metaclass-argument class-opts))) -(defun add-persistent-metaclass (class-opts) +(defun add-persistent-metaclass-argument (class-opts) (when (assoc :metaclass class-opts) (error "User metaclass specification not allowed in defpclass")) (append (list :metaclass 'persistent-metaclass) class-opts)) @@ -144,7 +144,8 @@ ;; This just encapsulates record keeping a bit (defclass indexing-record () - ((slots :accessor indexing-record-slots :initarg :slots :initform nil) + ((class :accessor indexing-record-class :initarg :class :initform t) + (slots :accessor indexing-record-slots :initarg :slots :initform nil) (derived-count :accessor indexing-record-derived :initarg :derived :initform 0))) (defmethod print-object ((obj indexing-record) stream) From rread at common-lisp.net Fri Feb 17 04:22:19 2006 From: rread at common-lisp.net (rread) Date: Thu, 16 Feb 2006 22:22:19 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060217042219.B187B40014@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv19434/tests Modified Files: elephant-tests.lisp Log Message: Removing duplicate definition. --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/10 01:39:13 1.11 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/17 04:22:19 1.12 @@ -103,12 +103,12 @@ (do-all-tests-spec *testsqlite3-path*) )) -(defun do-all-tests-spec (spec) - (when spec - (with-open-store (spec) - (let ((*auto-commit* nil)) - (declare (special *auto-commit*)) - (do-tests))))) +;; (defun do-all-tests-spec (spec) +;; (when spec +;; (with-open-store (spec) +;; (let ((*auto-commit* nil)) +;; (declare (special *auto-commit*)) +;; (do-tests))))) (defun do-test-spec (testname &optional (spec *testdb-path*)) "For easy interactive running of tests while debugging" From ieslick at common-lisp.net Fri Feb 17 22:45:21 2006 From: ieslick at common-lisp.net (ieslick) Date: Fri, 17 Feb 2006 16:45:21 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060217224521.3CD4A6E016@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv22917/src Modified Files: serializer.lisp sleepycat.lisp Log Message: Snapshot prior to transaction fix and backend reorg --- /project/elephant/cvsroot/elephant/src/serializer.lisp 2006/02/14 15:25:10 1.14 +++ /project/elephant/cvsroot/elephant/src/serializer.lisp 2006/02/17 22:45:21 1.15 @@ -79,7 +79,10 @@ (let ((s (symbol-name frob))) (declare (type string s) (dynamic-extent s)) (buffer-write-byte - #+(and allegro ics) +ucs2-symbol+ + #+(and allegro ics) + (etypecase s + (base-string +ucs1-symbol+) + (string +ucs2-symbol+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s (base-string +ucs1-symbol+) @@ -96,11 +99,14 @@ (string (progn (buffer-write-byte - #+(and allegro ics) +ucs2-string+ + #+(and allegro ics) + (etypecase frob + (base-string +ucs1-string+) + (string +ucs2-string+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase frob - (base-string +ucs1-string+) - (string #+sbcl +ucs4-string+ #+lispwoks +ucs2-string+)) + (base-string +ucs1-string+) + (string #+sbcl +ucs4-string+ #+lispworks +ucs2-string+)) #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) +ucs1-string+ bs) @@ -125,7 +131,10 @@ (let ((s (namestring frob))) (declare (type string s) (dynamic-extent s)) (buffer-write-byte - #+(and allegro ics) +ucs2-pathname+ + #+(and allegro ics) + (etypecase s + (base-string +ucs1-pathname+) + (string +ucs2-pathname+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s (base-string +ucs1-pathname+) @@ -250,7 +259,6 @@ ((= tag +fixnum+) (buffer-read-fixnum bs)) ((= tag +nil+) nil) - #-(and allegro ics) ((= tag +ucs1-symbol+) (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) @@ -272,7 +280,7 @@ (if maybe-package-name (intern name (find-package maybe-package-name)) (make-symbol name)))) - #-(and allegro ics) + #+(and allegro ics) ((= tag +ucs1-string+) (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) #+(or lispworks (and allegro ics)) @@ -292,7 +300,7 @@ (buffer-read-double bs)) ((= tag +char+) (code-char (buffer-read-uint bs))) - #-(and allegro ics) + #+(and allegro ics) ((= tag +ucs1-pathname+) (parse-namestring (or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) ""))) --- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/07 23:23:51 1.19 +++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/17 22:45:21 1.20 @@ -48,7 +48,7 @@ #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum #:buffer-read-int #:buffer-read-uint #:buffer-read-float #:buffer-read-double - #-(and allegro ics) #:buffer-read-ucs1-string + #+(and allegro ics) #:buffer-read-ucs1-string #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string #+(and sbcl sb-unicode) #:buffer-read-ucs4-string #:byte-length @@ -490,7 +490,9 @@ of a string." #+(and allegro ics) ;; old: `(let ((l (length ,s))) (+ l l)) - `(excl:native-string-sizeof ,s :external-format :unicode) + `(etypecase ,s + (base-string (length ,s)) + (string (excl:native-string-sizeof ,s :external-format :unicode))) #+(or (and sbcl sb-unicode) lispworks) `(etypecase ,s (base-string (length ,s)) @@ -547,20 +549,20 @@ (ccl::%copy-ivector-to-ptr ivector (+ disp src-offset) dest dest-offset length))) -#+allegro -(defun copy-str-to-buf (dest dest-offset src src-offset length) - "Use build-in unicode handling and copying facilities. - NOTE: We need to validate the speed of this vs. default." - (declare (optimize (speed 3) (safety 0)) - (type string src) - (type array-or-pointer-char dest) - (type fixnum length src-offset dest-offset) - (dynamic-extent src dest length)) - (excl:string-to-native (subseq src src-offset) :address (offset-char-pointer dest dest-offset) - :external-format :unicode)) +;; #+allegro +;; (defun copy-str-to-buf (dest dest-offset src src-offset length) +;; "Use build-in unicode handling and copying facilities. +;; NOTE: We need to validate the speed of this vs. default." +;; (declare (optimize (speed 3) (safety 0)) +;; (type string src) +;; (type array-or-pointer-char dest) +;; (type fixnum length src-offset dest-offset) +;; (dynamic-extent src dest length)) +;; (excl:string-to-native (subseq src src-offset) :address (offset-char-pointer dest dest-offset) +;; :external-format :unicode)) ;; Lisp version, for kicks. this assumes 8-bit chars! -#+(not (or cmu sbcl scl allegro openmcl lispworks)) +#+(not (or cmu sbcl scl openmcl lispworks)) (defun copy-str-to-buf (dest dest-offset src src-offset length) "Copy a string to a foreign buffer." (declare (optimize (speed 3) (safety 0)) @@ -730,9 +732,9 @@ (defun buffer-write-string (s bs) "Write the underlying bytes of a string. On Unicode Lisps, this is a 16-bit operation." -;; (declare (optimize (speed 3) (safety 0)) -;; (type buffer-stream bs) -;; (type string s)) + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type string s)) (with-struct-slots ((buf buffer-stream-buffer) (size buffer-stream-size) (len buffer-stream-length)) @@ -745,10 +747,10 @@ (resize-buffer-stream bs needed)) ;; I wonder if the basic problem here is that we are using this ;; routine instead of something like "copy-ub8-from-system-area"? - #-allegro +;; #-allegro (copy-str-to-buf buf size s 0 str-bytes) - #+allegro - (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode) +;; #+allegro +;; (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode) (setf size needed) nil))) From ieslick at common-lisp.net Fri Feb 17 22:45:21 2006 From: ieslick at common-lisp.net (ieslick) Date: Fri, 17 Feb 2006 16:45:21 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060217224521.7CE1E6E018@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv22917/tests Modified Files: elephant-tests.lisp Log Message: Snapshot prior to transaction fix and backend reorg --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/17 04:22:19 1.12 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/17 22:45:21 1.13 @@ -103,13 +103,6 @@ (do-all-tests-spec *testsqlite3-path*) )) -;; (defun do-all-tests-spec (spec) -;; (when spec -;; (with-open-store (spec) -;; (let ((*auto-commit* nil)) -;; (declare (special *auto-commit*)) -;; (do-tests))))) - (defun do-test-spec (testname &optional (spec *testdb-path*)) "For easy interactive running of tests while debugging" (when spec @@ -117,6 +110,14 @@ (let ((*auto-commit* nil)) (do-test testname))))) +(defun do-all-tests-spec(spec) + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (declare (special *auto-commit*) + (dynamic-extent *auto-commit*)) + (do-tests))))) + (defun do-indexing-tests () (declare (special *old-store*)) (setq *old-store* *store-controller*) @@ -160,14 +161,6 @@ ) )) -(defun do-all-tests-spec(spec) - (when spec - (with-open-store (spec) - (let ((*auto-commit* nil)) - (declare (special *auto-commit*) - (dynamic-extent *auto-commit*)) - (do-tests))))) - (defun find-slot-def (class-name slot-name) (find-if #'(lambda (slot-def) (eq (slot-definition-name slot-def) slot-name)) From ieslick at common-lisp.net Sun Feb 19 04:42:06 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:42:06 -0600 (CST) Subject: [elephant-cvs] CVS elephant/examples Message-ID: <20060219044206.CF2C069014@common-lisp.net> Update of /project/elephant/cvsroot/elephant/examples In directory common-lisp:/tmp/cvs-serv5587/examples Log Message: Directory /project/elephant/cvsroot/elephant/examples added to the repository From ieslick at common-lisp.net Sun Feb 19 04:45:56 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:45:56 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20060219044556.5EA7F6A022@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory common-lisp:/tmp/cvs-serv6758/memutil Log Message: Directory /project/elephant/cvsroot/elephant/src/memutil added to the repository From ieslick at common-lisp.net Sun Feb 19 04:45:56 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:45:56 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060219044556.980A86A021@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv6758/elephant Log Message: Directory /project/elephant/cvsroot/elephant/src/elephant added to the repository From ieslick at common-lisp.net Sun Feb 19 04:45:58 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:45:58 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060219044558.045B06C00C@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv6758/db-bdb Log Message: Directory /project/elephant/cvsroot/elephant/src/db-bdb added to the repository From ieslick at common-lisp.net Sun Feb 19 04:45:59 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:45:59 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060219044559.4B00F70000@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv6758/db-clsql Log Message: Directory /project/elephant/cvsroot/elephant/src/db-clsql added to the repository From ieslick at common-lisp.net Sun Feb 19 04:52:58 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:52:58 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060219045258.40B7871015@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv7130 Modified Files: Makefile TODO ele-bdb.asd ele-clsql.asd ele-sqlite3.asd elephant-tests.asd elephant.asd Log Message: See elephant-devel mail for changes...and take a big, deep breath... --- /project/elephant/cvsroot/elephant/Makefile 2006/01/29 01:08:31 1.8 +++ /project/elephant/cvsroot/elephant/Makefile 2006/02/19 04:52:58 1.9 @@ -32,10 +32,10 @@ all: libsleepycat.$(EXT) libmemutil.$(EXT) -libmemutil.$(EXT): src/libmemutil.c +libmemutil.$(EXT): src/memutil/libmemutil.c gcc $(SHARED) -Wall -fPIC -O3 -o $@ $< -lm -libsleepycat.$(EXT): src/libsleepycat.c +libsleepycat.$(EXT): src/db-bdb/libsleepycat.c gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm --- /project/elephant/cvsroot/elephant/TODO 2006/02/14 15:31:09 1.12 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/19 04:52:58 1.13 @@ -7,26 +7,26 @@ 0.6.0 - Adding default class/slot indexing - Finish indexing tests (Ian) - Documentation update (Robert) +* Add clsql like support for building .so/.dylib from asdf loader on most systems +* Make elephant thread bound variables dynamic and modifiable by backends +* Finish migration port and tests +- Think about dynamic vs. object based store & transaction resolution? + - Error checking when mixed + - Current store specific *current-transaction* stack +- Throw condition when store spec is invalid, etc 0.6.1 - performance, safety and portability Stability: -- Add clsql like support for building .so/.dylib from asdf loader on most systems -- Cleanup multi-repository operation (ensure that conflicts between an object's - registry and *store-controller* does not leed to lockup, especially with BDB (Both) - Think through default vs. explicit store referencing all over the APIs (Both) - Cleaner failure modes if operations are performed without repository or without transaction or auto-commit (Both) - Add asserts if *auto-index* is false and we're not in a transaction +- Add asserts if *auto-index* is false and we're not in a transaction to help users avoid lockups in bdb? Should be able to turn off for performance but it will help catch missing with-transaction statemetns in user code. (Both) - BDB: determine how to detect deadlock conditions as an optional run-safe mode? (?) - Does BDB have timeouts enabled on select? (Ian) -- Fix backend dependency problems (missing functions with-transaction-sql, etc) - caused by not having clsql loaded. Backends should not cause such failures - and should use asdf to load their deps when the backends are instantiated; much - like clsql does now + Does BDB have timeouts enabled on select? (Ian) - Remove build gensym warnings - Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) - (From Ben's e-mail) We are storing persistent objects incorrectly. They should be @@ -38,8 +38,6 @@ to use a lot of locks. In general understanding how to use Sleepycat efficiently seems like a good thing. (From Ben) - Reclaim table storage on index drop (Ian) -- Higher performance fix for allegro unicode serialization workaround than - my current one (Ian) - Add dependency information into secondary index callback functions so that we can more easily compute which indices need to be updated to avoid the global remove/add in order to maintain consistency (Ian) --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/15 01:54:07 1.5 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 04:52:58 1.6 @@ -1,10 +1,9 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; ele-clsql.asd -- ASDF system definition for -;;; a Berkeley-DB based back-end for Elephant +;;; elephant.asd -- ASDF system definition for elephant ;;; -;;; Initial version 10/12/2005 by Robert L. Read -;;; +;;; Initial version 8/26/2004 by Ben Lee +;;; ;;; ;;; part of ;;; @@ -13,46 +12,36 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA -;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :cl-user) + +(defpackage ele-bdb-system + (:use :cl :asdf)) + +(in-package :ele-bdb-system) (defsystem ele-bdb - :name "ele-bdb" - :author "Robert L. Read " - :version "0.1" - :maintainer "Robert L. Read " + :name "elephant" + :author "Ben Lee " + :version "0.6.0" + :maintainer "Ben Lee " :licence "LLGPL" - :description "Berkeley-DB based Object respository for Common Lisp" - :long-description "Including this loads the Berkeley-DB code; you may have to edit the pathname!" + :description "Object database for Common Lisp" + :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro." :components ((:module :src :components - ((:file "bdb-enable") - ) - :serial t)) - :depends-on (:elephant )) + ((:module :db-bdb + :components + ((:file "package") + (:file "sleepycat") + (:file "bdb-controller") + (:file "bdb-transactions") + (:file "bdb-collections")) + :serial t)))) + :depends-on (:uffi :elephant)) + + --- /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/04 22:25:09 1.3 +++ /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/19 04:52:58 1.4 @@ -1,10 +1,9 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; ele-clsql.asd -- ASDF system definition for -;;; a CL-SQL based back-end for Elephant +;;; elephant.asd -- ASDF system definition for elephant ;;; -;;; Initial version 10/12/2005 by Robert L. Read -;;; +;;; Initial version 8/26/2004 by Ben Lee +;;; ;;; ;;; part of ;;; @@ -13,48 +12,26 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA -;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -(defsystem ele-clsql - :name "ele-clsql" - :author "Robert L. Read " - :version "0.1" - :maintainer "Robert L. Read " +(defsystem ele-sql + :name "elephant" + :author "Ben Lee " + :version "0.6.0" + :maintainer "Ben Lee " :licence "LLGPL" :description "SQL-based Object respository for Common Lisp" :long-description "An experimental CL-SQL based implementation of Elephant" - - :components ((:module :src :components - ((:file "sql-controller") - (:file "sql-collections") - ) - :serial t)) + ((:module :db-clsql + :components + ((:file "sql-controller") + (:file "sql-transactions") + (:file "sql-collections")) + :serial t)))) :depends-on (:elephant :clsql :cl-base64)) + + --- /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/15 01:54:07 1.4 +++ /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/19 04:52:58 1.5 @@ -44,7 +44,7 @@ (defsystem ele-sqlite3 :name "ele-sqlite3" :author "Robert L. Read " - :version "0.1" + :version "0.6.0" :maintainer "Robert L. Read " :licence "GPL" :description "SQLite3 based Object respository for Common Lisp" @@ -56,4 +56,4 @@ ( ) :serial t)) - :depends-on (:ele-clsql :clsql-sqlite3)) + :depends-on (:ele-sql :clsql-sqlite3)) --- /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/02/07 23:23:50 1.5 +++ /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/02/19 04:52:58 1.6 @@ -55,11 +55,25 @@ :components ((:file "elephant-tests") (:file "testserializer") - (:file "testsleepycat") (:file "mop-tests") (:file "testcollections") (:file "testindexing") (:file "testmigration") ) :serial t))) + +(defsystem elephant-tests-bdb + :name "elephant" + :author "Ben Lee " + :version "0.1" + :maintainer "Ben Lee " + :licence "Lessor Lisp General Public License" + :description "Tests that only run under BDB" + + :depends-on (:elephant-tests) + :components + ((:module :tests + :components + ((:file "testsleepycat"))))) + --- /project/elephant/cvsroot/elephant/elephant.asd 2006/02/07 23:23:50 1.12 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 04:52:58 1.13 @@ -12,64 +12,49 @@ ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; -;;; This program is released under the following license -;;; ("GPL"). For differenct licensing terms, contact the -;;; copyright holders. -;;; -;;; This program is free software; you can redistribute it -;;; and/or modify it under the terms of the GNU General -;;; Public License as published by the Free Software -;;; Foundation; either version 2 of the License, or (at -;;; your option) any later version. -;;; -;;; This program is distributed in the hope that it will be -;;; useful, but WITHOUT ANY WARRANTY; without even the -;;; implied warranty of MERCHANTABILITY or FITNESS FOR A -;;; PARTICULAR PURPOSE. See the GNU General Public License -;;; for more details. -;;; -;;; The GNU General Public License can be found in the file -;;; LICENSE which should have been distributed with this -;;; code. It can also be found at -;;; -;;; http://www.opensource.org/licenses/gpl-license.php -;;; -;;; You should have received a copy of the GNU General -;;; Public License along with this program; if not, write -;;; to the Free Software Foundation, Inc., 59 Temple Place, -;;; Suite 330, Boston, MA 02111-1307 USA -;;; +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Lesser GNU Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. + +(in-package :cl-user) + +(defpackage elephant-system + (:use :cl :asdf)) + +(in-package :elephant-system) (defsystem elephant :name "elephant" :author "Ben Lee " - :version "0.5.0" + :version "0.6.0" :maintainer "Ben Lee " :licence "LLGPL" :description "Object database for Common Lisp" :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro." - :components ((:module :src :components - ((:file "sleepycat") - (:file "berkeley-db") - (:file "elephant") - (:file "utils") - #+cmu - (:file "cmu-mop-patches") - #+openmcl - (:file "openmcl-mop-patches") - (:file "metaclasses") - (:file "classes") - (:file "controller") - (:file "collections") - (:file "serializer") - (:file "index-utils") - (:file "indexing")) - #+openmcl - (:file "openmcl-mop-patches") - :serial t)) + ((:module memutil + :components + ((:file "memutil"))) + (:module elephant + :components + ((:file "elephant") + (:file "variables") + #+cmu (:file "cmu-mop-patches") + #+openmcl (:file "openmcl-mop-patches") + (:file "transactions") + (:file "metaclasses") + (:file "classes") + (:file "serializer") + (:file "cache") + (:file "controller") + (:file "collections") + (:file "classindex-utils") + (:file "classindex") + (:file "migrate") + (:file "backend")) + :serial t + :depends-on (memutil))))) :depends-on (:uffi)) - From ieslick at common-lisp.net Sun Feb 19 04:52:58 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:52:58 -0600 (CST) Subject: [elephant-cvs] CVS elephant/examples Message-ID: <20060219045258.8818E72003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/examples In directory common-lisp:/tmp/cvs-serv7130/examples Added Files: index-tutorial.lisp sql-tutorial.lisp Log Message: See elephant-devel mail for changes...and take a big, deep breath... --- /project/elephant/cvsroot/elephant/examples/index-tutorial.lisp 2006/02/19 04:52:58 NONE +++ /project/elephant/cvsroot/elephant/examples/index-tutorial.lisp 2006/02/19 04:52:58 1.1 (defpackage elephant-tutorial (:use :cl :elephant)) (in-package :elephant-tutorial) (defclass simple-plog () ((timestamp :accessor plog-timestamp :initarg :timestamp :index t) (type :accessor plog-type :initarg :type :index t) (data :accessor plog-data :initarg :data) (user :accessor plog-user :initarg :user :index t)) (:metaclass persistent-metaclass) (:documentation "Simple persistent log")) (defclass url-record () ((url :accessor url-record-url :initarg :url :initform "") (fetched :accessor url-record-fetched :initarg :fetched :initform nil) (analyzed :accessor url-record-analyzed :initarg :analyzed :initform nil)) (:documentation "An application object, declared persistent but not indexed")) (defmethod print-object ((obj url-record) stream) "Pretty print program objects so they're easy to inspect" (format stream "" (url-record-url obj) (url-record-fetched obj) (url-record-analyzed obj))) (defclass url-log (simple-plog) () (:metaclass persistent-metaclass) (:documentation "This class tracks events that transform our program object state")) (defmethod print-object ((obj url-log) stream) "Structured printing of log entries so they're easy to inspect at the repl" (format stream "#plog[~A :: ~A]" (plog-type obj) (plog-data obj))) (defun log-event (user type data) "A helper function to generically log various events by user" (make-instance 'url-log :timestamp (get-universal-time) :type type :data data :user user)) (defun report-events-by-time (user start end) "A custom reporting function for our logs - pull out a time range. A real implementation might do it by dates or by dates + times using one of the lisp time libraries" (let ((entries1 (get-instances-by-range 'url-log 'timestamp start end)) (entries2 (get-instances-by-value 'url-log 'user user))) (format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2)) (format t "~{~A~%~}" (nreverse (intersection entries1 entries2))))) ;; ;; This code is the skeleton of a program ;; (defvar *start-timestamp* nil) (defvar *end-timestamp* nil) (defun generate-events (user count &optional delay) (setf *start-timestamp* (get-universal-time)) (loop for i from 1 upto count do (let ((url (get-a-url user i))) (sleep delay) (fetch-url url user) (sleep delay) (analyze-url url user) (sleep delay))) (setf *end-timestamp* (get-universal-time))) (defun get-a-url (user seq) (let ((url (make-instance 'url-record :url (format nil "http://www.common-lisp.net/~A/" seq)))) (log-event user :received-url url) url)) (defun fetch-url (url user) (setf (url-record-fetched url) t) (log-event user :fetched-url url)) (defun analyze-url (url user) (setf (url-record-analyzed url) t) (log-event user :analyzed-url url)) ;; Top Level Test Code (defun test-generate-and-report (name store-spec) (open-store store-spec) (generate-events name 10 0.2) (report-events name) (close-store)) (defun report-events (name) (let ((first-third-start *start-timestamp*) (first-third-end (+ *start-timestamp* (/ (- *end-timestamp* *start-timestamp*) 3)))) (report-events-by-time name first-third-start first-third-end))) --- /project/elephant/cvsroot/elephant/examples/sql-tutorial.lisp 2006/02/19 04:52:58 NONE +++ /project/elephant/cvsroot/elephant/examples/sql-tutorial.lisp 2006/02/19 04:52:58 1.1 ;;; sql-tutorial.lisp ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (asdf:operate 'asdf:load-op :elephant) (asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :elephant-tests) (in-package "ELEPHANT-TESTS") (open-store *testdb-path*) (add-to-root "my key" "my value") (get-from-root "my key") (setq foo (cons nil nil)) (add-to-root "my key" foo) (add-to-root "my other key" foo) (eq (get-from-root "my key") (get-from-root "my other key")) (setf (car foo) T) (get-from-root "my key") (defclass my-persistent-class () ((slot1 :accessor slot1) (slot2 :accessor slot2)) (:metaclass persistent-metaclass)) (setq foo (make-instance 'my-persistent-class)) (add-to-root "foo" foo) (add-to-root "bar" foo) (eq (get-from-root "foo") (get-from-root "bar")) (get-from-root "foo") (setf (slot1 foo) "one") (setf (slot2 foo) "two") (slot1 foo) (slot2 foo) (setf (slot1 foo) "three") (slot1 (get-from-root "bar")) (setq *auto-commit* nil) (with-transaction () (setf (slot1 foo) 123456789101112) (setf (slot2 foo) "onetwothree...")) (defvar *friends-birthdays* (make-btree)) (add-to-root "friends-birthdays" *friends-birthdays*) (setf (get-value "Andrew" *friends-birthdays*) (encode-universal-time 0 0 0 22 12 1976)) (setf (get-value "Ben" *friends-birthdays*) (encode-universal-time 0 0 0 14 4 1976)) (get-value "Andrew" *friends-birthdays*) (decode-universal-time *) (defvar curs (make-cursor *friends-birthdays*)) (cursor-close curs) (setq curs (make-cursor *friends-birthdays*)) (cursor-current curs) (cursor-first curs) (cursor-next curs) (cursor-next curs) (cursor-close curs) (with-transaction () (with-btree-cursor (curs *friends-birthdays*) (loop (multiple-value-bind (more k v) (cursor-next curs) (unless more (return nil)) (format t "~A ~A~%" k v))))) (defclass appointment () ((date :accessor ap-date :initarg :date :type integer) (type :accessor ap-type :initarg :type :type string)) (:metaclass persistent-metaclass)) (defvar *appointments* (with-transaction () (make-indexed-btree *store-controller*))) (defun add-appointment (date type) (with-transaction () (setf (get-value date *appointments*) (make-instance 'appointment :date date :type type)))) (add-appointment (encode-universal-time 0 0 0 22 12 2004) "Birthday") (add-appointment (encode-universal-time 0 0 0 14 4 2005) "Birthday") (add-appointment (encode-universal-time 0 0 0 1 1 2005) "Holiday") (defun key-by-type (secondary-db primary value) (declare (ignore secondary-db primary)) (let ((type (ap-type value))) (when type (values t type)))) (with-transaction () (add-index *appointments* :index-name 'by-type :key-form 'key-by-type :populate t)) (defvar *by-type* (get-index *appointments* 'by-type)) (decode-universal-time (ap-date (get-value "Holiday" *by-type*))) (with-btree-cursor (curs *by-type*) (loop for (more? k v) = (multiple-value-list (cursor-set curs "Birthday")) then (multiple-value-list (cursor-next-dup curs)) do (unless more? (return t)) (multiple-value-bind (s m h d mo y) (decode-universal-time (ap-date v)) (declare (ignore s m h)) (format t "~A/~A/~A~%" mo d y)))) From ieslick at common-lisp.net Sun Feb 19 04:53:00 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:53:00 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060219045300.0A7D276005@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv7130/src Added Files: README Removed Files: IAN-TODO bdb-enable.lisp cmu-mop-patches.lisp collections.lisp controller.lisp elephant.lisp index-tutorial.lisp indexing.lisp libmemutil.c libsleepycat.c libsleepycat.def libutil.c metaclasses.lisp openmcl-mop-patches.lisp serializer.lisp sleepycat.lisp sql-collections.lisp sql-controller.lisp sql-tutorial.lisp utils.lisp Log Message: See elephant-devel mail for changes...and take a big, deep breath... --- /project/elephant/cvsroot/elephant/src/README 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/README 2006/02/19 04:53:00 1.1 The organization of the new Elephant is as follows: Top directory contains: - A binary object serialization framework (serializer.lisp) - Code necessary to support different platform MOPs (to move to closer-to-MOP in 0.6.1) (cmu/openmcl-mop-patches.lisp) - Top level transaction model (transaction.lisp) - An environment model for 'current store' and multi-repository operation (controller.lisp) - The metaclass protocol for supporting persistent objects (metaclass.lisp, classes.lisp) - Interface specs for persistent btrees & cursors (collections.lisp) - Indexing support for the metaclass (indexing.lisp, index-utils.lisp) Backends provide support for: - A store controller w/ a persistent root index (*-controller.lisp) - Includes support for slot operations in metaclass protocol - Collections defined via the specific controller (*-collections.lisp) - Transactions specific to the backend (*-transactions.lisp) From ieslick at common-lisp.net Sun Feb 19 04:53:00 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:53:00 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060219045300.6ABAA76007@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv7130/src/db-bdb Added Files: bdb-collections.lisp bdb-controller.lisp bdb-enable.lisp bdb-transactions.lisp libsleepycat.c libutil.c package.lisp sleepycat-old.lisp sleepycat.lisp Log Message: See elephant-devel mail for changes...and take a big, deep breath... --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 04:53:00 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; collections.lisp -- view Berkeley DBs as Lisp collections ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "SLEEPYCAT") (defclass bdb-btree (btree) () (:documentation "A BerkleyDB implementation of a BTree")) ;; It would be nice if this were a macro or a function ;; that would allow all of its arguments to be passed through; ;; otherwise an initialization slot is inaccessible. ;; I'll worry about that later. ;; Do these things need to take &rest arguments? (defmethod build-btree ((sc bdb-store-controller)) (make-instance 'bdb-btree :sc sc)) (defmethod get-value (key (bt bdb-btree)) (declare (optimize (speed 3) (space 0) (safety 0))) (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (let ((buf (db-get-key-buffered (controller-btrees sc) key-buf value-buf))) (if buf (values (deserialize buf :sc sc) T) (values nil nil)))))) (defmethod existsp (key (bt bdb-btree)) (declare (optimize (speed 3) (safety 0) (space 0))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (let ((buf (db-get-key-buffered (controller-btrees (get-con bt)) key-buf value-buf))) (if buf t nil)))) (defmethod (setf get-value) (value key (bt bdb-btree)) (declare (optimize (speed 3) (safety 0) (space 0))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (serialize value value-buf) (db-put-buffered (controller-btrees (get-con bt)) key-buf value-buf :auto-commit *auto-commit*) value)) (defmethod remove-kv (key (bt bdb-btree)) (declare (optimize (speed 3) (space 0) (safety 0))) (with-buffer-streams (key-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (db-delete-buffered (controller-btrees (get-con bt)) key-buf :auto-commit *auto-commit*))) ;; Secondary indices (defclass bdb-indexed-btree (indexed-btree bdb-btree) ( (indices :accessor indices :initform (make-hash-table)) (indices-cache :accessor indices-cache :initform (make-hash-table) :transient t) ) (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) (defmethod shared-initialize :after ((instance bdb-indexed-btree) slot-names &rest rest) (declare (ignore slot-names rest)) (setf (indices-cache instance) (indices instance))) (defmethod build-indexed-btree ((sc bdb-store-controller)) (let ((bt (make-instance 'bdb-indexed-btree :sc sc))) ;; (setf (:dbcn-spc-pst bt) (controller-path sc)) ;; I must be confused with multipler inheritance, because the above ;;; initforms in bdb-indexed-btree should be working, but aren't. ;; (setf (indices bt) (make-hash-table)) ;; (setf (indices-cache bt) (make-hash-table)) bt)) (defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) (let ((bt (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc))) ;; (setf (:dbcn-spc-pst bt) (controller-path sc)) ;; I must be confused with multipler inheritance, because the above ;;; initforms in bdb-indexed-btree should be working, but aren't. bt)) (defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) (let ((sc (get-con bt))) ;; Setting the value of *store-controller* is unfortunately ;; absolutely required at present, I think because the copying ;; of objects is calling "make-instance" without an argument. ;; I am sure I can find a way to make this cleaner, somehow. (if (and (not (null index-name)) (symbolp index-name) (or (symbolp key-form) (listp key-form))) ;; Can it be that this fails? (let ( (ht (indices bt)) (index (build-btree-index sc :primary bt :key-form key-form))) (setf (gethash index-name (indices-cache bt)) index) (setf (gethash index-name ht) index) (setf (indices bt) ht) (when populate (let ((key-fn (key-fn index))) (with-buffer-streams (primary-buf secondary-buf) (with-transaction (:store-controller sc) (map-btree #'(lambda (k v) (multiple-value-bind (index? secondary-key) (funcall key-fn index k v) (when index? (buffer-write-int (oid bt) primary-buf) (serialize k primary-buf) (buffer-write-int (oid index) secondary-buf) (serialize secondary-key secondary-buf) ;; should silently do nothing if ;; the key/value already exists (db-put-buffered (controller-indices sc) secondary-buf primary-buf) (reset-buffer-stream primary-buf) (reset-buffer-stream secondary-buf)))) bt))))) index) (error "Invalid index initargs!"))) ) (defmethod map-indices (fn (bt bdb-indexed-btree)) (maphash fn (indices-cache bt))) (defmethod get-index ((bt bdb-indexed-btree) index-name) (gethash index-name (indices-cache bt))) (defmethod remove-index ((bt bdb-indexed-btree) index-name) (remhash index-name (indices-cache bt)) (let ((indices (indices bt))) (remhash index-name indices) (setf (indices bt) indices))) (defmethod (setf get-value) (value key (bt bdb-indexed-btree)) "Set a key / value pair, and update secondary indices." (let ((sc (get-con bt))) (let ((indices (indices-cache bt))) (with-buffer-streams (key-buf value-buf secondary-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (serialize value value-buf) (with-transaction (:store-controller sc) (db-put-buffered (controller-btrees sc) key-buf value-buf) (loop for index being the hash-value of indices do (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? ;; Manually write value into secondary index (buffer-write-int (oid index) secondary-buf) (serialize secondary-key secondary-buf) ;; should silently do nothing if the key/value already ;; exists (db-put-buffered (controller-indices sc) secondary-buf key-buf) (reset-buffer-stream secondary-buf)))) value)))) ) (defmethod remove-kv (key (bt bdb-indexed-btree)) "Remove a key / value pair, and update secondary indices." (declare (optimize (speed 3))) (let ((sc (get-con bt))) (with-buffer-streams (key-buf secondary-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (with-transaction (:store-controller sc) (let ((value (get-value key bt))) (when value (let ((indices (indices-cache bt))) (loop for index being the hash-value of indices do (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? (buffer-write-int (oid index) secondary-buf) (serialize secondary-key secondary-buf) ;; need to remove kv pairs with a cursor! -- ;; this is a C performance hack (db-delete-kv-buffered (controller-indices (get-con bt)) secondary-buf key-buf) (reset-buffer-stream secondary-buf)))) (db-delete-buffered (controller-btrees (get-con bt)) key-buf)))))))) ;; This also needs to build the correct kind of index, and ;; be the correct kind of btree... (defclass bdb-btree-index (btree-index bdb-btree) () (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) ;; I now think this code should be split out into a separate ;; class... (defmethod get-value (key (bt bdb-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (let ((buf (db-get-key-buffered (controller-indices-assoc (get-con bt)) key-buf value-buf))) (if buf (values (deserialize buf :sc (get-con bt)) T) (values nil nil))))) (defmethod get-primary-key (key (bt btree-index)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf) (let ((buf (db-get-key-buffered (controller-indices (get-con bt)) key-buf value-buf))) (if buf (let ((oid (buffer-read-fixnum buf))) (values (deserialize buf :sc (get-con bt)) oid)) (values nil nil))))) ;; Cursor operations ;; Node that I have not created a bdb-cursor, but have ;; created a sql-currsor. This is almost certainly wrong ;; and furthermore will badly screw things up when we get to ;; secondary cursors. (defclass bdb-cursor (cursor) ((handle :accessor cursor-handle :initarg :handle)) (:documentation "A cursor for traversing (primary) BDB-BTrees.")) (defmethod make-cursor ((bt bdb-btree)) "Make a cursor from a btree." (declare (optimize (speed 3))) (make-instance 'bdb-cursor :btree bt :handle (db-cursor (controller-btrees (get-con bt))) :oid (oid bt))) (defmethod cursor-close ((cursor bdb-cursor)) (declare (optimize (speed 3))) (db-cursor-close (cursor-handle cursor)) (setf (cursor-initialized-p cursor) nil)) (defmethod cursor-duplicate ((cursor bdb-cursor)) (declare (optimize (speed 3))) (make-instance (type-of cursor) :initialized-p (cursor-initialized-p cursor) :oid (cursor-oid cursor) :handle (db-cursor-duplicate (cursor-handle cursor) :position (cursor-initialized-p cursor)))) (defmethod cursor-current ((cursor bdb-cursor)) (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) (multiple-value-bind (key val) (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf :current t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key :sc (get-con (cursor-btree cursor))) (deserialize val :sc (get-con (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-first ((cursor bdb-cursor)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) (multiple-value-bind (key val) (db-cursor-set-buffered (cursor-handle cursor) key-buf value-buf :set-range t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key :sc (get-con (cursor-btree cursor))) (deserialize val :sc (get-con (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil))))) ;;A bit of a hack..... (defmethod cursor-last ((cursor bdb-cursor)) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) (if (db-cursor-set-buffered (cursor-handle cursor) key-buf value-buf :set-range t) (progn (reset-buffer-stream key-buf) (reset-buffer-stream value-buf) (multiple-value-bind (key val) (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf :prev t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key :sc (get-con (cursor-btree cursor))) (deserialize val :sc (get-con (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))) (multiple-value-bind (key val) (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf :last t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key :sc (get-con (cursor-btree cursor))) (deserialize val :sc (get-con (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-next ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) (multiple-value-bind (key val) (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf :next t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (values t (deserialize key :sc (get-con (cursor-btree cursor))) (deserialize val :sc (get-con (cursor-btree cursor)))) (setf (cursor-initialized-p cursor) nil)))) (cursor-first cursor))) (defmethod cursor-prev ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) (multiple-value-bind (key val) (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf :prev t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (values t (deserialize key :sc (get-con (cursor-btree cursor))) (deserialize val :sc (get-con (cursor-btree cursor)))) (setf (cursor-initialized-p cursor) nil)))) (cursor-last cursor))) (defmethod cursor-set ((cursor bdb-cursor) key) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) (serialize key key-buf) (multiple-value-bind (k val) (db-cursor-set-buffered (cursor-handle cursor) key-buf value-buf :set t) (if k (progn (setf (cursor-initialized-p cursor) t) (values t key (deserialize val :sc (get-con (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil))))) (defmethod cursor-set-range ((cursor bdb-cursor) key) (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) (serialize key key-buf) (multiple-value-bind (k val) (db-cursor-set-buffered (cursor-handle cursor) key-buf value-buf :set-range t) (if (and k (= (buffer-read-int k) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize k :sc (get-con (cursor-btree cursor))) (deserialize val :sc (get-con (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil))))) (defmethod cursor-get-both ((cursor bdb-cursor) key value) (declare (optimize (speed 3))) [360 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 04:53:00 1.1 [557 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-enable.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-enable.lisp 2006/02/19 04:53:00 1.1 [646 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/19 04:53:00 1.1 [741 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/libsleepycat.c 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/libsleepycat.c 2006/02/19 04:53:00 1.1 [1734 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/libutil.c 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/libutil.c 2006/02/19 04:53:00 1.1 [1845 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/02/19 04:53:00 1.1 [1888 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat-old.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat-old.lisp 2006/02/19 04:53:00 1.1 [2953 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 04:53:00 1.1 [4821 lines skipped] From ieslick at common-lisp.net Sun Feb 19 04:53:00 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:53:00 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060219045300.B2E1276005@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv7130/src/db-clsql Added Files: sql-collections.lisp sql-controller.lisp sql-transaction.lisp Log Message: See elephant-devel mail for changes...and take a big, deep breath... --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 04:53:00 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; sql-controller.lisp -- Interface to a CLSQL based object store. ;;; ;;; Initial version 10/12/2005 by Robert L. Read ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2005 by Robert L. Read ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") (defclass sql-btree-index (btree-index sql-btree) () (:metaclass persistent-metaclass) (:documentation "A SQL-based BTree supports secondary indices.")) (defmethod get-value (key (bt sql-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3))) ;; Below, the take the oid and add it to the key, then look ;; thing up--- where? ;; Somehow I suspect that what I am getting back here ;; is actually the main key... (let* ((sc (get-con bt)) (con (controller-db sc))) (let ((pk (sql-get-from-clcn (oid bt) key sc con))) (if pk (sql-get-from-clcn (oid (primary bt)) pk sc con)) ))) (defmethod get-primary-key (key (bt sql-btree-index)) (declare (optimize (speed 3))) (let* ((sc (get-con bt)) (con (controller-db sc)) ) (sql-get-from-clcn (oid bt) key sc con))) ;; My basic strategy is to keep track of a current key ;; and to store all keys in memory so that we can sort them ;; to implement the cursor semantics. Clearly, passing ;; in a different ordering is a nice feature to have here. (defclass sql-cursor (cursor) ((keys :accessor :sql-crsr-ks :initarg :sql-cursor-keys :initform '()) (curkey :accessor :sql-crsr-ck :initarg :sql-cursor-curkey :initform -1 :type integer)) (:documentation "A SQL cursor for traversing (primary) BTrees.")) (defmethod make-cursor ((bt sql-btree)) "Make a cursor from a btree." (declare (optimize (speed 3))) (make-instance 'sql-cursor :btree bt :oid (oid bt))) (defmethod cursor-close ((cursor sql-cursor)) (setf (:sql-crsr-ck cursor) nil) (setf (cursor-initialized-p cursor) nil)) ;; Maybe this will still work? ;; I'm not sure what cursor-duplicate is meant to do, and if ;; the other state needs to be copied or now. Probably soo... (defmethod cursor-duplicate ((cursor sql-cursor)) (declare (optimize (speed 3))) (make-instance (type-of cursor) :initialized-p (cursor-initialized-p cursor) :oid (cursor-oid cursor) ;; Do we need to so some kind of copy on this collection? :keys (:sql-crsr-ks cursor) :curkey (:sql-crsr-ck cursor) :handle (db-cursor-duplicate (cursor-handle cursor) :position (cursor-initialized-p cursor)))) (defmethod cursor-current ((cursor sql-cursor)) (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (has-key-value cursor))) ;; Only for use within an operation... (defun my-generic-less-than (a b) (cond ((and (typep a 'persistent) (typep b 'persistent)) (< (oid a) (oid b)) ) ((and (numberp a ) (numberp b)) (< a b)) ((and (stringp a) (stringp b)) (string< a b)) (t (string< (format nil "~A" a) (format nil "~A" b))) )) (defmethod cursor-un-init ((cursor sql-cursor) &key (returnpk nil)) (setf (cursor-initialized-p cursor) nil) (if returnpk (values nil nil nil nil) (values nil nil nil))) (clsql::locally-enable-sql-reader-syntax) (defmethod cursor-init ((cursor sql-cursor)) (let* ((sc (get-con (cursor-btree cursor))) (con (controller-db sc)) (tuples (clsql:select [key] :from [keyvalue] :where [= [clctn_id] (oid (cursor-btree cursor))] :database con )) (len (length tuples))) ;; now we somehow have to load the keys into the array... ;; actually, this should be an adjustable vector... (setf (:sql-crsr-ks cursor) (make-array (length tuples))) (do ((i 0 (1+ i)) (tup tuples (cdr tup))) ((= i len) nil) (setf (aref (:sql-crsr-ks cursor) i) (deserialize-from-base64-string (caar tup) :sc sc))) (sort (:sql-crsr-ks cursor) #'my-generic-less-than) (setf (:sql-crsr-ck cursor) 0) (setf (cursor-initialized-p cursor) t) )) (clsql::restore-sql-reader-syntax-state) ;; we're assuming here that nil is not a legitimate key. (defmethod get-current-key ((cursor sql-cursor)) (let ((x (:sql-crsr-ck cursor))) (if (and (>= x 0) (< x (length (:sql-crsr-ks cursor)))) (svref (:sql-crsr-ks cursor) x) '() )) ) (defmethod get-current-value ((cursor sql-cursor)) (let ((key (get-current-key cursor))) (if key (get-value key (cursor-btree cursor)) '()))) (defmethod has-key-value ((cursor sql-cursor)) (let ((key (get-current-key cursor))) (if key (values t key (get-value key (cursor-btree cursor))) (cursor-un-init cursor)))) (defmethod cursor-first ((cursor sql-cursor)) (declare (optimize (speed 3))) ;; Read all of the keys... ;; We need to get the contoller db from the btree somehow... (cursor-init cursor) (has-key-value cursor) ) ;;A bit of a hack..... ;; If you run off the end, this can set cursor-initalized-p to nil. (defmethod cursor-last ((cursor sql-cursor) ) (unless (cursor-initialized-p cursor) (cursor-init cursor)) (setf (:sql-crsr-ck cursor) (- (length (:sql-crsr-ks cursor)) 1)) (setf (cursor-initialized-p cursor) t) (has-key-value cursor)) (defmethod cursor-next ((cursor sql-cursor)) (if (cursor-initialized-p cursor) (progn (incf (:sql-crsr-ck cursor)) (has-key-value cursor)) (cursor-first cursor))) (defmethod cursor-prev ((cursor sql-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (progn (decf (:sql-crsr-ck cursor)) (has-key-value cursor)) (cursor-last cursor))) (defmethod cursor-set ((cursor sql-cursor) key) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (let ((p (position key (:sql-crsr-ks cursor) :test #'equal))) (if p (progn (setf (:sql-crsr-ck cursor) p) (setf (cursor-initialized-p cursor) t) (has-key-value cursor) ) (setf (cursor-initialized-p cursor) nil))) (progn (cursor-init cursor) (let ((p (position key (:sql-crsr-ks cursor) :test #'equal))) (if p (progn (setf (:sql-crsr-ck cursor) p) (has-key-value cursor) ) (setf (cursor-initialized-p cursor) nil)))) )) (defmethod cursor-set-range ((cursor sql-cursor) key) (declare (optimize (speed 3))) ;; I'm a little fuzzy on when I should leave a cursor in ;; the initialized state... (unless (cursor-initialized-p cursor) (cursor-init cursor)) (let ((len (length (:sql-crsr-ks cursor))) (vs '())) (do ((i 0 (1+ i))) ((or (= i len) vs) vs) (progn (multiple-value-bind (h k v) (cursor-next cursor) (when (my-generic-less-than key k) (setf vs t)) ) )) (if vs (cursor-current cursor) (cursor-un-init cursor)))) (defmethod cursor-get-both ((cursor sql-cursor) key value) (declare (optimize (speed 3))) (let* ((bt (cursor-btree cursor)) (v (get-value key bt))) (if (equal v value) ;; We need to leave this cursor properly posistioned.... ;; For a secondary cursor it's harder, but for this, it's simple (cursor-set cursor key) (cursor-un-init cursor)))) ;; This needs to be rewritten! (defmethod cursor-get-both-range ((cursor sql-cursor) key value) (declare (optimize (speed 3))) (let* ((bt (cursor-btree cursor)) (v (get-value key bt))) ;; Since we don't allow duplicates in primary cursors, I ;; guess this is all that needs to be done! ;; If there were a test to cover this, the semantics would be clearer... (if (equal v value) (cursor-set cursor key) (cursor-un-init cursor)))) (defmethod cursor-delete ((cursor sql-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (multiple-value-bind (has k v) (cursor-current cursor) (declare (ignore has v)) ;; Now I need to suck the value out of the cursor, somehow.... (remove-kv k (cursor-btree cursor))) (error "Can't delete with uninitialized cursor!"))) ;; This needs to be changed! (defmethod cursor-put ((cursor sql-cursor) value &key (key nil key-specified-p)) "Put by cursor. Not particularly useful since primaries don't support duplicates. Currently doesn't properly move the cursor." (declare (optimize (speed 3))) (error "Puts on sql-cursors are not yet implemented, because I can't get them to work on BDB cursors!")) ;; Secondary Cursors (defclass sql-secondary-cursor (sql-cursor) ( (dup-number :accessor :dp-nmbr :initarg :dup-number :initform 0 :type integer) ) (:documentation "Cursor for traversing bdb secondary indices.")) (defmethod make-cursor ((bt sql-btree-index)) "Make a secondary-cursor from a secondary index." (declare (optimize (speed 3))) (make-instance 'sql-secondary-cursor :btree bt :oid (oid bt))) (defmethod has-key-value-scnd ((cursor sql-secondary-cursor) &key (returnpk nil)) (let ((ck (:sql-crsr-ck cursor))) (if (and (>= ck 0) (< ck (length (:sql-crsr-ks cursor)))) (let* ((cur-pk (aref (:sql-crsr-ks cursor) (:sql-crsr-ck cursor))) (sc (get-con (cursor-btree cursor))) (con (controller-db sc)) (indexed-pk (sql-get-from-clcn-nth (cursor-oid cursor) cur-pk sc con (:dp-nmbr cursor)))) (if indexed-pk (let ((v (get-value indexed-pk (primary (cursor-btree cursor))))) (if v (if returnpk (values t cur-pk v indexed-pk) (values t cur-pk v)) (cursor-un-init cursor :returnpk returnpk))) (cursor-un-init cursor :returnpk returnpk))) (progn (cursor-un-init cursor :returnpk returnpk))))) (defmethod cursor-current ((cursor sql-secondary-cursor) ) (cursor-current-x cursor)) (defmethod cursor-current-x ((cursor sql-secondary-cursor) &key (returnpk nil)) (has-key-value-scnd cursor :returnpk returnpk) ) (defmethod cursor-pcurrent ((cursor sql-secondary-cursor)) (cursor-current-x cursor :returnpk t)) (defmethod cursor-pfirst ((cursor sql-secondary-cursor)) (cursor-first-x cursor :returnpk t)) (defmethod cursor-plast ((cursor sql-secondary-cursor)) (cursor-last-x cursor :returnpk t)) (defmethod cursor-pnext ((cursor sql-secondary-cursor)) (cursor-next-x cursor :returnpk t)) (defmethod cursor-pprev ((cursor sql-secondary-cursor)) (cursor-prev-x cursor :returnpk t)) (defmethod cursor-pset ((cursor sql-secondary-cursor) key) (declare (optimize (speed 3))) (unless (cursor-initialized-p cursor) (cursor-init cursor)) (let ((idx (position key (:sql-crsr-ks cursor)))) (if idx (progn (setf (:sql-crsr-ck cursor) idx) (setf (:dp-nmbr cursor) 0) (cursor-current-x cursor :returnpk t)) (cursor-un-init cursor) ))) (defun array-index-if (p a) (do ((i 0 (1+ i))) ((or (not (array-in-bounds-p a i)) (funcall p (aref a i))) (if (funcall p (aref a i)) i -1))) ) (defmethod cursor-pset-range ((cursor sql-secondary-cursor) key) (declare (optimize (speed 3))) (unless (cursor-initialized-p cursor) (cursor-init cursor)) (let ((idx (array-index-if #'(lambda (x) (my-generic-less-than key x)) (:sql-crsr-ks cursor)))) (if (<= 0 idx) (progn (setf (:sql-crsr-ck cursor) idx) (setf (:dp-nmbr cursor) 0) (cursor-current-x cursor :returnpk t) ) (cursor-un-init cursor :returnpk t) ))) ;; Moves the cursor to a the first secondary key / primary key pair, ;; with secondary key equal to the key argument, and primary key greater or equal to the pkey argument. ;; Returns has-tuple / secondary key / value / primary key. (defmethod cursor-pget-both ((cursor sql-secondary-cursor) key pkey) (declare (optimize (speed 3))) ;; It's better to get the value by the primary key, ;; as that is unique.. (let* ((bt (primary (cursor-btree cursor))) (v (get-value pkey bt))) ;; Now, bascially we set the cursor to the key and ;; andvance it until we get the value that we want... (if v [217 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 04:53:00 1.1 [826 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/02/19 04:53:00 NONE +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/02/19 04:53:00 1.1 [869 lines skipped] From ieslick at common-lisp.net Sun Feb 19 04:53:01 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:53:01 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060219045301.4707576007@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv7130/src/elephant Added Files: backend.lisp cache.lisp classes.lisp classindex-utils.lisp classindex.lisp cmu-mop-patches.lisp collections.lisp controller.lisp elephant.lisp metaclasses.lisp migrate.lisp openmcl-mop-patches.lisp serializer.lisp transactions.lisp variables.lisp Log Message: See elephant-devel mail for changes...and take a big, deep breath... --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 04:53:01 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; backend.lisp -- Namespace support for backends ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package :cl-user) (defpackage :elephant-backend (:documentation "Backends should use this to get access to internal symbols of elephant that importers of elephant shouldn't see. Backends should also import elephant to get use-api generic function symbols, classes and globals") (:import-from #:elephant ;; Variables #:*cachesize* #:*dbconnection-spec* ;; shouldn't need this #:connection-is-indeed-open ;; Persistent objects #:oid #:get-con #:next-oid #:persistent-slot-writer #:persistent-slot-reader #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers #:open-controller #:close-controller #:controller-spec #:controller-root #:controller-class-root #:root #:class-root #:flush-instance-cache ;; Collection generic functions #:build-indexed-btree #:build-btree #:deserialize #:serialize #:existsp ;; Cursor accessors #:cursor-btree #:cursor-oid #:cursor-initialized-p ;; Misc #:slot-definition-name #:register-backend-con-init #:lookup-backend-con-init ;; Transactions #:execute-transaction #:controller-start-transaction #:controller-commit-transaction #:controller-abort-transaction ) (:export ;; Variables #:*cachesize* #:*dbconnection-spec* ;; shouldn't need this #:connection-is-indeed-open ;; Persistent objects #:oid #:get-con #:next-oid #:persistent-slot-writer #:persistent-slot-reader #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers #:open-controller #:close-controller #:controller-spec #:controller-root #:controller-class-root #:root #:class-root #:flush-instance-cache ;; Collection generic functions #:build-indexed-btree #:build-btree #:deserialize #:serialize #:existsp ;; Cursor accessors #:cursor-btree #:cursor-oid #:cursor-initialized-p ;; Misc #:slot-definition-name #:register-backend-con-init #:lookup-backend-con-init ;; Transactions #:execute-transaction #:controller-start-transaction #:controller-commit-transaction #:controller-abort-transaction )) --- /project/elephant/cvsroot/elephant/src/elephant/cache.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/cache.lisp 2006/02/19 04:53:01 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; migrate.lisp -- Migrate between repositories ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Portable value-weak hash-tables for the cache: when the ;;; values are collected, the entries (keys) should be ;;; flushed from the table too (defun make-cache-table (&rest args) "Make a values-weak hash table: when a value has been collected, so are the keys." #+(or cmu sbcl scl) (apply #'make-hash-table args) #+allegro (apply #'make-hash-table :values :weak args) #+lispworks (apply #'make-hash-table :weak-kind :value args) #+openmcl (apply #'make-hash-table :weak :value args) #-(or cmu sbcl scl allegro lispworks) (apply #'make-hash-table args) ) #+openmcl (defclass cleanup-wrapper () ((cleanup :accessor cleanup :initarg :cleanup) (value :accessor value :initarg :value))) #+openmcl (defmethod ccl:terminate ((c cleanup-wrapper)) (funcall (cleanup c))) (defun get-cache (key cache) "Get a value from a cache-table." #+(or cmu sbcl) (let ((val (gethash key cache))) (if val (values (weak-pointer-value val) t) (values nil nil))) #+openmcl (let ((wrap (gethash key cache))) (if wrap (values (value wrap) t) (values nil nil))) #+(or allegro lispworks) (gethash key cache) ) (defun make-finalizer (key cache) #+(or cmu sbcl) (lambda () (remhash key cache)) #+(or allegro openmcl) (lambda (obj) (declare (ignore obj)) (remhash key cache)) ) (defun setf-cache (key cache value) "Set a value in a cache-table." #+(or cmu sbcl) (let ((w (make-weak-pointer value))) (finalize value (make-finalizer key cache)) (setf (gethash key cache) w) value) #+openmcl (let ((w (make-instance 'cleanup-wrapper :value value :cleanup (make-finalizer key cache)))) (ccl:terminate-when-unreachable w) (setf (gethash key cache) w) value) #+allegro (progn (excl:schedule-finalization value (make-finalizer key cache)) (setf (gethash key cache) value)) #+lispworks (setf (gethash key cache) value) ) (defsetf get-cache setf-cache) --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/19 04:53:01 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; classes.lisp -- persistent objects via metaobjects ;;; ;;; Initial version 8/26/2004 by Andrew Blumberg ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid (sc *store-controller*)) "Sets the OID and home controller" (declare (ignore initargs)) (if (null sc) (error "Initialize instance for type persistent requires valid store controller argument :sc")) (if from-oid (setf (oid instance) from-oid) (setf (oid instance) (next-oid sc))) (setf (:dbcn-spc-pst instance) (controller-spec sc)) (cache-instance sc instance)) (defclass persistent-object (persistent) () (:metaclass persistent-metaclass) (:documentation "Superclass of all user-defined persistent classes. This is automatically inherited if you use the persistent-metaclass metaclass.")) (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) (persistent-object (find-class 'persistent-object)) (not-already-persistent (loop for superclass in direct-superclasses never (eq (class-of superclass) persistent-metaclass)))) (if (and (not (eq class persistent-object)) not-already-persistent) (apply #'call-next-method class slot-names :direct-superclasses (cons persistent-object direct-superclasses) args) (call-next-method)))) #+allegro (defun make-persistent-reader (name slot-definition class class-name) (eval `(defmethod ,name ((instance ,class-name)) (slot-value-using-class ,class instance ,slot-definition)))) #+allegro (defun make-persistent-writer (name slot-definition class class-name) (let ((name (if (and (consp name) (eq (car name) 'setf)) name `(setf ,name)))) (eval `(defmethod ,name ((instance ,class-name) value) (setf (slot-value-using-class ,class instance ,slot-definition) value))))) #+allegro (defmethod initialize-accessors ((slot-definition persistent-slot-definition) class) (let ((readers (slot-definition-readers slot-definition)) (writers (slot-definition-writers slot-definition)) (class-name (class-name class))) (loop for reader in readers do (make-persistent-reader reader slot-definition class class-name)) (loop for writer in writers do (make-persistent-writer writer slot-definition class class-name)))) #+allegro (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) (update-indexed-record instance (indexed-slot-names-from-defs instance)) (set-db-synch instance :class) (loop with persistent-slots = (persistent-slots instance) for slot-def in (class-direct-slots instance) when (member (slot-definition-name slot-def) persistent-slots) do (initialize-accessors slot-def instance)) (make-instances-obsolete instance)))) #+(or cmu sbcl openmcl) (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) (update-indexed-record instance (indexed-slot-names-from-defs instance)) (set-db-synch instance :class) (make-instances-obsolete instance)))) ;; #+allegro (defmethod finalize-inheritance :around ((instance persistent-metaclass)) (prog1 (call-next-method) (when (not (slot-boundp instance '%persistent-slots)) (setf (%persistent-slots instance) (cons (persistent-slot-names instance) nil))) (when (not (slot-boundp instance '%indexed-slots)) (update-indexed-record instance (indexed-slot-names-from-defs instance))))) ;; #+(or cmu sbcl) ;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) ;; (prog1 ;; (call-next-method) ;; (if (not (slot-boundp instance '%persistent-slots)) ;; (setf (%persistent-slots instance) ;; (cons (persistent-slot-names instance) nil))))) (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for implementations to optimize setting the slots via initforms and initargs in such a way that slot-value-using-class et al aren't used. We also handle writing any indices after the class is fully initialized. Calls the next method for the transient slots." (let* ((class (class-of instance)) (oid (oid instance)) (persistent-slot-names (persistent-slot-names class))) (flet ((persistent-slot-p (item) (member item persistent-slot-names :test #'eq))) (let ((transient-slot-inits (if (eq slot-names t) ; t means all slots (transient-slot-names class) (remove-if #'persistent-slot-p slot-names))) (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) (inhibit-indexing oid) (unwind-protect ;; initialize the persistent slots (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs with slot-initargs = (slot-definition-initargs slot-def) when (member initarg slot-initargs :test #'eq) do (setf (slot-value-using-class class instance slot-def) (getf initargs initarg)) (return t)))) (loop for slot-def in (class-slots class) unless (initialize-from-initarg slot-def) when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq) unless (slot-boundp-using-class class instance slot-def) do (let ((initfun (slot-definition-initfunction slot-def))) (when initfun (setf (slot-value-using-class class instance slot-def) (funcall initfun))))) ;; (format t "transient-slot-inits ~A~%" transient-slot-inits) ;; (format t "indices boundp ~A~%" (slot-boundp instance 'indices)) ;; (format t "indices-caches boundp ~A~%" (slot-boundp instance 'indices-cache)) ;; let the implementation initialize the transient slots (apply #'call-next-method instance transient-slot-inits initargs)) (uninhibit-indexing oid)) ;; Inhibit indexing altogether if the object already was defined (ie being created ;; from an oid) as it should be indexed already. This hack avoids a deadlock ;; situation where we write the class or index page that we are currently reading ;; via a cursor without going through the cursor abstraction. There has to be a ;; better way to do this. (when (and (indexed class) (not from-oid)) (let ((class-index (find-class-index (class-of instance)))) (when class-index (with-transaction () (setf (get-value oid class-index) instance))))) )))) (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; NOTE: probably should delete discarded slots, but we'll worry about that later (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) (let* ((class (class-of instance)) (new-persistent-slots (set-difference (persistent-slots class) (old-persistent-slots class)))) ;; Update new persistent slots, the others we get for free (same oid!) ;; Isn't this done by the default call-next-method? (apply #'shared-initialize instance new-persistent-slots initargs)) ) ) (defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key) (let* ((old-class (class-of previous)) (new-class (class-of current)) (new-persistent-slots (set-difference (persistent-slots new-class) (persistent-slots old-class))) (raw-retained-persistent-slots (intersection (persistent-slots new-class) (persistent-slots old-class))) [75 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2006/02/19 04:53:01 1.1 [218 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/19 04:53:01 1.1 [791 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/cmu-mop-patches.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/cmu-mop-patches.lisp 2006/02/19 04:53:01 1.1 [902 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/19 04:53:01 1.1 [1277 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 04:53:01 1.1 [1541 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp 2006/02/19 04:53:01 1.1 [1795 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 04:53:01 1.1 [2171 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/19 04:53:01 1.1 [2269 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/openmcl-mop-patches.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/openmcl-mop-patches.lisp 2006/02/19 04:53:01 1.1 [2349 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/02/19 04:53:01 1.1 [2888 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/02/19 04:53:01 1.1 [2990 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/02/19 04:53:01 NONE +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2006/02/19 04:53:01 1.1 [3087 lines skipped] From ieslick at common-lisp.net Sun Feb 19 04:53:02 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:53:02 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20060219045302.BBA4C76007@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory common-lisp:/tmp/cvs-serv7130/src/memutil Added Files: libmemutil.c memutil.lisp Log Message: See elephant-devel mail for changes...and take a big, deep breath... --- /project/elephant/cvsroot/elephant/src/memutil/libmemutil.c 2006/02/19 04:53:02 NONE +++ /project/elephant/cvsroot/elephant/src/memutil/libmemutil.c 2006/02/19 04:53:02 1.1 /* ;;; ;;; libsleepycat.c -- C wrappers for Sleepycat for FFI ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; This program is released under the following license ;;; ("GPL"). For differenct licensing terms, contact the ;;; copyright holders. ;;; ;;; This program is free software; you can redistribute it ;;; and/or modify it under the terms of the GNU General ;;; Public License as published by the Free Software ;;; Foundation; either version 2 of the License, or (at ;;; your option) any later version. ;;; ;;; This program is distributed in the hope that it will be ;;; useful, but WITHOUT ANY WARRANTY; without even the ;;; implied warranty of MERCHANTABILITY or FITNESS FOR A ;;; PARTICULAR PURPOSE. See the GNU General Public License ;;; for more details. ;;; ;;; The GNU General Public License can be found in the file ;;; LICENSE which should have been distributed with this ;;; code. It can also be found at ;;; ;;; http://www.opensource.org/licenses/gpl-license.php ;;; ;;; You should have received a copy of the GNU General ;;; Public License along with this program; if not, write ;;; to the Free Software Foundation, Inc., 59 Temple Place, ;;; Suite 330, Boston, MA 02111-1307 USA ;;; ;;; Portions of this program (namely the C unicode string ;;; sorter) are derived from IBM's ICU: ;;; ;;; http://oss.software.ibm.com/icu/ ;;; ;;; Copyright (c) 1995-2003 International Business Machines ;;; Corporation and others All rights reserved. ;;; ;;; ICU's copyright, license and warranty can be found at ;;; ;;; http://oss.software.ibm.com/cvs/icu/~checkout~/icu/license.html ;;; ;;; or in the file LICENSE. ;;; */ #include #include /* Pointer arithmetic utility functions */ /* should these be in network-byte order? probably not..... */ int read_int(char *buf, int offset) { int i; memcpy(&i, buf+offset, sizeof(int)); return i; } unsigned int read_uint(char *buf, int offset) { unsigned int ui; memcpy(&ui, buf+offset, sizeof(unsigned int)); return ui; } float read_float(char *buf, int offset) { float f; memcpy(&f, buf+offset, sizeof(float)); return f; } double read_double(char *buf, int offset) { double d; memcpy(&d, buf+offset, sizeof(double)); return d; } void write_int(char *buf, int num, int offset) { memcpy(buf+offset, &num, sizeof(int)); } void write_uint(char *buf, unsigned int num, int offset) { memcpy(buf+offset, &num, sizeof(unsigned int)); } void write_float(char *buf, float num, int offset) { memcpy(buf+offset, &num, sizeof(float)); } void write_double(char *buf, double num, int offset) { memcpy(buf+offset, &num, sizeof(double)); } char *offset_charp(char *p, int offset) { return p + offset; } void copy_buf(char *dest, int dest_offset, char *src, int src_offset, int length) { memcpy(dest + dest_offset, src + src_offset, length); } --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 04:53:02 NONE +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 04:53:02 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; memutil.lisp -- FFI interface to UFFI/memory as base for serializer.lisp ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (defpackage elephant-memutil (:documentation "A low-level UFFI-based memory access and serialization toolkit. Provides basic cross-platform binary serialization support for backends.") (:use common-lisp uffi) #+cmu (:use alien) #+sbcl (:use sb-alien) #+cmu (:import-from :sys #:sap+) #+sbcl (:import-from :sb-sys #:sap+) #+openmcl (:import-from :ccl #:byte-length) (:export #:buffer-stream #:make-buffer-stream #:with-buffer-streams #:resize-buffer-stream #:resize-buffer-stream-no-copy #:reset-buffer-stream #:buffer-stream-buffer #:buffer-stream-length #:buffer-stream-size #:buffer-write-byte #:buffer-write-int #:buffer-write-uint #:buffer-write-float #:buffer-write-double #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum #:buffer-read-int #:buffer-read-uint #:buffer-read-float #:buffer-read-double #:buffer-read-ucs1-string #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string #+(and sbcl sb-unicode) #:buffer-read-ucs4-string #:byte-length #:pointer-int #:pointer-void #:array-or-pointer-char +NULL-CHAR+ +NULL-VOID+ )) (in-package "ELEPHANT-MEMUTIL") #+cmu (eval-when (:compile-toplevel) (proclaim '(optimize (ext:inhibit-warnings 3)))) (eval-when (:compile-toplevel :load-toplevel) (defparameter *c-library-extension* #+(or darwin macosx) "dylib" #-(or darwin macosx) "so" ) (defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant/")) (eval-when (:compile-toplevel :load-toplevel) (unless (uffi:load-foreign-library (if (find-package 'asdf) (merge-pathnames (make-pathname :name "libmemutil" :type *c-library-extension*) (asdf:component-pathname (asdf:find-system 'elephant))) (format nil "~A/~A.~A" *elephant-lib-path* "libmemutil" *c-library-extension*)) :module "libmemutil") (error "Couldn't load libmemutil.~A!" *c-library-extension*)) ;; fini on user editable part (def-type pointer-int (* :int)) (def-type pointer-void :pointer-void) (def-foreign-type array-or-pointer-char #+allegro (:array :char) #+(or cmu sbcl scl openmcl) (* :char)) (def-type array-or-pointer-char array-or-pointer-char) ) (declaim (inline read-int read-uint read-float read-double write-int write-uint write-float write-double offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs ;;resize-buffer-stream ;;buffer-stream-buffer buffer-stream-size buffer-stream-position ;;buffer-stream-length reset-buffer-stream buffer-write-byte buffer-write-int buffer-write-uint buffer-write-float buffer-write-double buffer-write-string buffer-read-byte buffer-read-fixnum buffer-read-int buffer-read-uint buffer-read-float buffer-read-double buffer-read-ucs1-string #+(or lispworks (and allegro ics)) buffer-read-ucs2-string #+(and sbcl sb-unicode) buffer-read-ucs4-string)) ;; Constants and Flags ;; eventually write a macro which generates a custom flag function. (defvar +NULL-VOID+ (make-null-pointer :void) "A null pointer to a void type.") (defvar +NULL-CHAR+ (make-null-pointer :char) "A null pointer to a char type.") ;; Thread local storage (special variables) (defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) "Vector of buffer-streams, which you can grab / return.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; buffer-streams ;;; ;;; a stream-like interface for our buffers; methods are ;;; below. ultimately we might want a gray / simple -stream ;;; for real, for now who cares? (defstruct buffer-stream "A stream-like interface to foreign (alien) char buffers." (buffer (allocate-foreign-object :char 10) :type array-or-pointer-char) (size 0 :type fixnum) (position 0 :type fixnum) (length 10 :type fixnum)) (defun grab-buffer-stream () "Grab a buffer-stream from the *buffer-streams* resource pool." (declare (optimize (speed 3))) (if (= (length *buffer-streams*) 0) (make-buffer-stream) (vector-pop *buffer-streams*))) (defun return-buffer-stream (bs) "Return a buffer-stream to the *buffer-streams* resource pool." (declare (optimize (speed 3))) (reset-buffer-stream bs) (vector-push-extend bs *buffer-streams*)) (defmacro with-buffer-streams (names &body body) "Grab a buffer-stream, executes forms, and returns the stream to the pool on exit." `(let ,(loop for name in names collect (list name '(grab-buffer-stream))) (unwind-protect (progn , at body) (progn ,@(loop for name in names collect (list 'return-buffer-stream name)))))) ;; Buffer management / pointer arithmetic ;; Notes: on Allegro: with-cast-pointer + deref-array is ;; faster than FFI + C pointer arithmetic. however pointer ;; arithmetic is usually consing. OpenMCL supports ;; non-consing pointer arithmentic though. Check these ;; CMUCL / SBCL things don't cons unless necessary. ;; TODO: #+openmcl versions which do macptr arith. #+(or cmu sbcl) (defun read-int (buf offset) "Read a 32-bit signed integer from a foreign char buffer." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) buf) (type fixnum offset)) (the (signed-byte 32) (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* integer))))) #+(or cmu sbcl) (defun read-uint (buf offset) "Read a 32-bit unsigned integer from a foreign char buffer." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) buf) (type fixnum offset)) (the (unsigned-byte 32) (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* (unsigned 32)))))) #+(or cmu sbcl) (defun read-float (buf offset) "Read a single-float from a foreign char buffer." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) buf) (type fixnum offset)) (the single-float (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* single-float))))) #+(or cmu sbcl) (defun read-double (buf offset) "Read a double-float from a foreign char buffer." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) buf) (type fixnum offset)) (the double-float (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* double-float))))) #+(or cmu sbcl) (defun write-int (buf num offset) "Write a 32-bit signed integer to a foreign char buffer." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) buf) (type (signed-byte 32) num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* integer))) num)) #+(or cmu sbcl) (defun write-uint (buf num offset) "Write a 32-bit unsigned integer to a foreign char buffer." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) buf) (type (unsigned-byte 32) num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* (unsigned 32)))) num)) #+(or cmu sbcl) (defun write-float (buf num offset) "Write a single-float to a foreign char buffer." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) buf) (type single-float num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* single-float))) num)) #+(or cmu sbcl) (defun write-double (buf num offset) "Write a double-float to a foreign char buffer." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) buf) (type double-float num) (type fixnum offset)) (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* double-float))) num)) #+(or cmu sbcl) (defun offset-char-pointer (p offset) "Pointer arithmetic." (declare (optimize (speed 3) (safety 0)) (type (alien (* char)) p) (type fixnum offset)) (sap-alien (sap+ (alien-sap p) offset) (* char))) #-(or cmu sbcl) (def-function ("read_int" read-int) ((buf array-or-pointer-char) (offset :int)) :returning :int) #-(or cmu sbcl) (def-function ("read_uint" read-uint) ((buf array-or-pointer-char) (offset :int)) :returning :unsigned-int) #-(or cmu sbcl) (def-function ("read_float" read-float) ((buf array-or-pointer-char) (offset :int)) :returning :float) #-(or cmu sbcl) (def-function ("read_double" read-double) ((buf array-or-pointer-char) (offset :int)) :returning :double) #-(or cmu sbcl) (def-function ("write_int" write-int) ((buf array-or-pointer-char) (num :int) (offset :int)) :returning :void) #-(or cmu sbcl) (def-function ("write_uint" write-uint) ((buf array-or-pointer-char) [454 lines skipped] From ieslick at common-lisp.net Sun Feb 19 04:53:03 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 22:53:03 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060219045303.3AC6D76008@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv7130/tests Modified Files: elephant-tests.lisp mop-tests.lisp testcollections.lisp testindexing.lisp testmigration.lisp testserializer.lisp testsleepycat.lisp Log Message: See elephant-devel mail for changes...and take a big, deep breath... --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/17 22:45:21 1.13 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 04:53:02 1.14 @@ -60,86 +60,102 @@ ;; Putting this in to make the test work; I have no idea what it means... (deftype array-or-pointer-char () '(or array t)) - -(defvar *testdb-path* - (namestring - (merge-pathnames - #p"tests/testdb/" - (asdf:component-pathname (asdf:find-system 'elephant-tests))))) - -(defvar *testdb-path2* - (namestring - (merge-pathnames - #p"tests/testdb2/" - (asdf:component-pathname (asdf:find-system 'elephant-tests))))) - -(defvar *sleepycatdb-path* - (namestring - (merge-pathnames - #p"tests/testsleepycat/" - (asdf:component-pathname (asdf:find-system 'elephant-tests))))) - -(defvar *testpg-path* -'(:postgresql "localhost.localdomain" "test" "postgres" "")) - -(defvar *testsqlite3-path* -;; This is of the form '(filename &optional init-function), -;; and using :memory: as a file name will get you an completely in-memory system... -;; '(":memory:") - '(:sqlite3 "sqlite3-test.db") -) - -(defvar *test-path-primary* - *testdb-path* -) - -(defvar *test-path-secondary* - *testdb-path2* -) - -(defun do-all-tests() - (progn - (do-all-tests-spec *testdb-path*) - (do-all-tests-spec *testsqlite3-path*) - )) - -(defun do-test-spec (testname &optional (spec *testdb-path*)) - "For easy interactive running of tests while debugging" - (when spec +(defvar *testbdb-spec* + `(:bdb + ,(namestring + (merge-pathnames + #p"tests/testdb/" + (asdf:component-pathname (asdf:find-system 'elephant-tests))))) + "The primary test spec for testing sleepycat") + +(defvar *testbdb-spec2* + `(:bdb + ,(namestring + (merge-pathnames + #p"tests/testdb2/" + (asdf:component-pathname (asdf:find-system 'elephant-tests))))) + "A second bdb test directory for bdb-to-bdb tests") + +(defvar *testpg-spec* + '(:clsql (:postgresql "localhost.localdomain" "test" "postgres" ""))) + +(defvar *testsqlite3-spec* + '(:clsql (:sqlite3 "sqlite3-test.db")) + "This is of the form '(filename &optional init-function),") + +(defvar *testsqlite3-memory-spec* + '(:clsql (:sqlite3 :memory)) + "Using :memory: as a file name will get you an completely in-memory system") + + +;; +;; GUIDE TO TESTING +;; +;; 1) Set *default-spec* to the above spec of your choice +;; 2) Call (do-backend-tests) to test the standard API +;; 3) To test migration: (do-migration *default-spec* ) inserting a second +;; spec, typically a bdb spec or create another instance of a sql db depending on +;; your configuration +;; 4) A backend is green if it passes do-backend-tests and can succesfully be +;; used as spec1 or spec2 argument in the migration test +;; + +(defvar *default-spec* nil + "Set this at the REPL to have the following interfaces default to a given spec + mostly here to save typing...") + +(defun do-backend-tests (&optional (spec *default-spec*)) + "Will test a specific backend based on the spec. Note, + if you run a :bdb backend test it will load sleepycat + specific tests which should silently succeed if you + test another backend" + (when (and (consp spec) (symbolp (car spec))) (with-open-store (spec) + (cond ((eq (car spec) :bdb) + (asdf:operate 'asdf:load-op :elephant-tests-bdb))) (let ((*auto-commit* nil)) - (do-test testname))))) - -(defun do-all-tests-spec(spec) + (do-tests))))) + +(defun do-test-spec (testname &optional (spec *default-spec*)) + "For easy interactive running of single tests while debugging" (when spec (with-open-store (spec) (let ((*auto-commit* nil)) - (declare (special *auto-commit*) - (dynamic-extent *auto-commit*)) - (do-tests))))) + (do-test testname))))) -(defun do-indexing-tests () - (declare (special *old-store*)) - (setq *old-store* *store-controller*) - (unwind-protect - (progn - (let ((*auto-commit* nil)) - (declare (special *auto-commit*) - (dynamic-extent *auto-commit*)) - (open-store *testdb-path*) - (print (do-test 'indexing-basic)) - (print (do-test 'indexing-inherit)) - (print (do-test 'indexing-range)) - (print (do-test 'indexing-reconnect-db)) - (print (do-test 'indexing-change-class)) - (print (do-test 'indexing-redef-class)) - (print (do-test 'indexing-explicit-changes)) - (print (do-test 'indexing-timing)) - (close-store))) - (setq *store-controller* *old-store*))) +(defun do-migration-tests (spec1 spec2) + "Interface to do explicit migration tests between backends" + (let ((*test-spec-primary* spec1) + (*test-spec-secondary* spec2)) + (declare (special *test-spec-primary* *test-spec-secondary*)) + (print (do-test 'remove-element)) + (print (do-test 'migrate1)) + (print (do-test 'migrate2)) + (print (do-test 'migrate3)) + (print (do-test 'migrate4)) + (print (do-test 'migrate5)))) + + + +;; +;; Various test groups +;; + +(defun do-indexing-tests (&optional (spec *default-spec*)) + "Just test indexing" + (with-open-store (spec) + (print (do-test 'indexing-basic)) + (print (do-test 'indexing-inherit)) + (print (do-test 'indexing-range)) + (print (do-test 'indexing-reconnect-db)) + (print (do-test 'indexing-change-class)) + (print (do-test 'indexing-redef-class)) + (print (do-test 'indexing-explicit-changes)) + (print (do-test 'indexing-timing)))) (defun do-crazy-pg-tests() - (open-store *testpg-path*) + "Specific problematic pg tests" + (open-store *testpg-spec*) (do-test 'indexed-btree-make) (do-test 'add-indices) (do-test 'test-indices) @@ -148,24 +164,23 @@ (close-store) ) -(defun do-migrate-test-spec(spud) - (with-open-store(spud) - (let ((*auto-commit* nil)) - (assert (equal (do-test 'remove-element) 'remove-element)) - (assert (equal (do-test 'migrate1) 'migrate1)) - (assert (equal (do-test 'migrate2) 'migrate2)) - (assert (equal (do-test 'migrate3) 'migrate3)) - (assert (equal (do-test 'migrate4) 'migrate4)) - (assert (equal (do-test 'migrate5) 'migrate5)) - t - ) - )) - (defun find-slot-def (class-name slot-name) (find-if #'(lambda (slot-def) (eq (slot-definition-name slot-def) slot-name)) (class-slots (find-class class-name)))) + +(defvar *sleepycatdb-spec* + `(:bdb . ,(namestring + (merge-pathnames + #p"tests/testsleepycat/" + (asdf:component-pathname (asdf:find-system 'elephant-tests)))))) + + +;; +;; UTILITIES +;; + (defmacro finishes (&body body) `(handler-case (progn , at body) --- /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2006/02/05 23:13:08 1.10 +++ /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2006/02/19 04:53:02 1.11 @@ -221,16 +221,19 @@ (slot2 foo)))) 1 2) -(deftest change-class2 - (with-transaction (:store-controller *store-controller*) - (let ((foo (build-btree *store-controller*))) - (change-class foo (find-class - (if (typep *store-controller* 'bdb-store-controller) - 'bdb-indexed-btree - 'sql-indexed-btree) - )) - (is-not-null (indices foo)))) - t) +;; +;; ISE NOTE: This violates single backend testing, I've removed it for now +;; +;; (deftest change-class2 +;; (with-transaction (:store-controller *store-controller*) +;; (let ((foo (make-btree *store-controller*))) +;; (change-class foo (find-class +;; (if (typep *store-controller* 'bdb-store-controller) +;; 'bdb-indexed-btree +;; 'sql-indexed-btree) +;; )) +;; (is-not-null (indices foo)))) +;; t) (deftest change-class3 (progn --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/07 23:23:51 1.11 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/19 04:53:02 1.12 @@ -22,8 +22,7 @@ (let ((x (gensym))) (add-to-root "x" x) ;; Clear instances - (setf (elephant::instance-cache *store-controller*) - (elephant::make-cache-table :test #'eql)) + (flush-instance-cache *store-controller*) ;; Are gensyms equal across db instantiations? ;; This forces a refetch of the object from db (setq rv (equal (format nil "~A" x) @@ -55,17 +54,9 @@ (defvar bt) (deftest btree-make - (finishes (setq bt (build-btree *store-controller*))) + (finishes (setq bt (make-btree *store-controller*))) t) -;; This is a very dangerous and naughty statement. -;; It was probably placed in this file for a good reason, -;; but nothing seems to reset it. The result is that after loading -;; theses tests, nothing works as you expect it later. -;; It may be that the proper fix is not just to take it out, -;; but that is the best that I can do right now. -;; (setq *auto-commit* nil) - (deftest btree-put (finishes (with-transaction (:store-controller *store-controller*) @@ -115,7 +106,7 @@ (deftest indexed-btree-make (finishes (with-transaction (:store-controller *store-controller*) - (setq indexed (build-indexed-btree *store-controller*)))) + (setq indexed (make-indexed-btree *store-controller*)))) t) (defun key-maker (s key value) @@ -134,11 +125,18 @@ (values t (slot2 value))))))) t) +;; ISE NOTE: indices accessor is not portable across backends in current +;; system so I'm using alternate access (map-indices) instead (deftest test-indices (values - (= (hash-table-count (indices indexed)) 2) - (eq index1 (gethash 'slot1 (indices indexed))) - (eq index2 (gethash 'slot2 (indices indexed)))) + ;; (= (hash-table-count (indices indexed)) 2) + (let ((count 0)) + (map-indices (lambda (x y) (declare (ignore x y)) (incf count)) indexed) + (eq count 2)) + ;; (gethash 'slot1 (indices indexed))) + (eq index1 (get-index indexed 'slot1)) + ;; (eq index2 (gethash 'slot2 (indices indexed)))) + (eq index2 (get-index indexed 'slot2))) t t t) #| @@ -321,7 +319,7 @@ (deftest rem-kv (with-transaction (:store-controller *store-controller*) - (let ((ibt (build-indexed-btree *store-controller*))) + (let ((ibt (make-indexed-btree *store-controller*))) (loop for i from 0 to 10 do (setf (get-value i ibt) (* i i))) @@ -346,7 +344,7 @@ (deftest rem-idexkv (with-transaction (:store-controller *store-controller*) - (let* ((ibt (build-indexed-btree *store-controller*)) + (let* ((ibt (make-indexed-btree *store-controller*)) (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) (loop for i from 0 to 10 do @@ -387,7 +385,7 @@ (deftest make-indexed2 (finishes (with-transaction (:store-controller *store-controller*) - (setq indexed2 (build-indexed-btree *store-controller*)))) + (setq indexed2 (make-indexed-btree *store-controller*)))) t) (defun crunch (s k v) @@ -473,7 +471,7 @@ ;; Note: If this is not done inside a transaction, ;; it HANGS BDB! (with-transaction (:store-controller *store-controller*) - (let* ((ibt (build-indexed-btree *store-controller*)) + (let* ((ibt (make-indexed-btree *store-controller*)) (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) (loop for i from 0 to 10 do @@ -533,7 +531,7 @@ (deftest cur-del2 (with-transaction (:store-controller *store-controller*) - (let* ((ibt (build-indexed-btree *store-controller*)) + (let* ((ibt (make-indexed-btree *store-controller*)) (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) (loop for i from 0 to 10 do @@ -691,12 +689,12 @@ (setq *auto-commit* t) (remove-from-root key) (setf exists1 - (from-root-existsp key) + (root-existsp key) ) (add-to-root key 'a) - (setf exists2 (from-root-existsp key)) + (setf exists2 (root-existsp key)) (remove-from-root key) - (setf exists3 (from-root-existsp key)) + (setf exists3 (root-existsp key)) ) (setq *auto-commit* *prev-commit*) ) @@ -709,7 +707,7 @@ ;; This test not only does not work, it appears to ;; hang sleepycat forcing a recovery!?!?!?! ;; (deftest cursor-put -;; (let* ((ibt (build-indexed-btree *store-controller*))) +;; (let* ((ibt (make-indexed-btree *store-controller*))) ;; (let ( ;; (index ;; (add-index ibt :index-name 'crunch :key-form 'crunch --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/10 01:39:13 1.4 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/19 04:53:02 1.5 @@ -20,12 +20,16 @@ (trace elephant::db-transaction-commit) ) +(defvar inst1) +(defvar inst2) +(defvar inst3) + ;; put list of objects, retrieve on value, range and by class (deftest indexing-basic (progn -;; (format t "Global vars:~%") -;; (format t "~%basic store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) -;; (format t "auto-commit: ~A~%" *auto-commit*) + ;;(format t "Global vars:~%") + ;;(format t "~%basic store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) + ;;(format t "auto-commit: ~A~%" *auto-commit*) (disable-class-indexing 'idx-one :errorp nil) (setf (find-class 'idx-one) nil) --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/05 23:13:08 1.6 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/19 04:53:02 1.7 @@ -14,50 +14,53 @@ (in-package :ele-tests) (deftest remove-element - (if (or (null *test-path-secondary*) - (null *test-path-primary*)) + (if (or (not (boundp '*test-spec-secondary*)) + (null *test-spec-secondary*)) (progn - (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.") + (format t "~%Single store mode: ignoring") t) - (let ((a (vector 'a 'b 'c)) - (ans (vector 'a 'c))) - (setf a (ele::remove-indexed-element-and-adjust 1 a)) - (and (equal (aref a 0) (aref ans 0)) - (equal (aref a 1) (aref ans 1)) - (equal (length a) (length ans))))) + (let ((a (vector 'a 'b 'c)) + (ans (vector 'a 'c))) + (setf a (ele::remove-indexed-element-and-adjust 1 a)) + (and (equal (aref a 0) (aref ans 0)) + (equal (aref a 1) (aref ans 1)) + (equal (length a) (length ans))))) t) - (deftest migrate1 - (if (or (null *test-path-secondary*) - (null *test-path-primary*)) + (if (or (not (boundp '*test-spec-secondary*) ) + (null *test-spec-secondary*)) (progn - (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.") + (format t "~%Single store mode: ignoring") t) (let ((old-store *store-controller*) (*prev-commit* *auto-commit*) (*auto-commit* t) - (rv nil)) - (unwind-protect - (let ( - (sc1 (open-store *test-path-primary*)) - (sc2 (open-store *test-path-secondary*))) - (add-to-root "x" "y" :store-controller sc1) - (copy-from-key "x" sc1 sc2) - (setf rv (equal (get-from-root "x" :store-controller sc1) - (get-from-root "x" :store-controller sc2)))) - (progn - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))) + (rv nil) + (sc1 nil) + (sc2 nil)) + (unwind-protect + (progn + (setf sc1 (open-store *test-spec-primary*)) + (setf sc2 (open-store *test-spec-secondary*)) + (add-to-root "x" "y" :store-controller sc1) + (copy-from-key "x" sc1 sc2) + (setf rv (equal (get-from-root "x" :store-controller sc1) + (get-from-root "x" :store-controller sc2)))) + (progn + (when sc1 (close-store sc1)) + (when sc2 (close-store sc2)) + (setq *store-controller* old-store) + (setq *auto-commit* *prev-commit*))) rv)) - t) + t) (deftest migrate2 - (if (or (null *test-path-secondary*) - (null *test-path-primary*)) + (if (or (not (boundp '*test-spec-secondary*) ) + (null *test-spec-secondary*)) (progn - (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.") + (format t "~%Single store mode: ignoring") nil) (let ((old-store *store-controller*) (*prev-commit* *auto-commit*) @@ -65,8 +68,8 @@ (rv nil)) (unwind-protect (let - ((sc1 (open-store *test-path-primary*)) - (sc2 (open-store *test-path-secondary*))) + ((sc1 (open-store *test-spec-primary*)) + (sc2 (open-store *test-spec-secondary*))) (let ((ibt (build-btree sc1))) (loop for i from 0 to 10 do @@ -80,18 +83,18 @@ (deftest migrate3 - (if (or (null *test-path-secondary*) - (null *test-path-primary*)) + (if (or (not (boundp '*test-spec-secondary*) ) + (null *test-spec-secondary*)) (progn - (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.") + (format t "~%Single store mode: ignoring") t) (let ((old-store *store-controller*) (*prev-commit* *auto-commit*) (*auto-commit* t) (rv nil)) (unwind-protect - (let ((sc1 (open-store *test-path-primary*)) - (sc2 (open-store *test-path-secondary*)) + (let ((sc1 (open-store *test-spec-primary*)) + (sc2 (open-store *test-spec-secondary*)) ) (let* ((ibt (build-indexed-btree sc1))) (let ( @@ -125,10 +128,10 @@ (deftest migrate4 - (if (or (null *test-path-secondary*) - (null *test-path-primary*)) + (if (or (not (boundp '*test-spec-secondary*) ) + (null *test-spec-secondary*)) (progn - (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.") + (format t "~%Single store mode: ignoring") t) (finishes (let ((old-store *store-controller*) @@ -137,8 +140,8 @@ (rv nil)) (unwind-protect (let* ( - (sc1 (open-store *test-path-primary*)) - (sc2 (open-store *test-path-secondary*)) + (sc1 (open-store *test-spec-primary*)) + (sc2 (open-store *test-spec-secondary*)) ) (let* ((ibt (build-indexed-btree sc1))) (let ( @@ -158,34 +161,34 @@ t) (deftest migrate5 - (if (or (null *test-path-secondary*) - (null *test-path-primary*)) + (if (or (not (boundp '*test-spec-secondary*) ) + (null *test-spec-secondary*)) (progn - (format t "*test-path-secondary* and *test-path-primary* not both set, skipping this test.") + (format t "~%Single store mode: ignoring") t) (let ((*prev-commit* *auto-commit*)) - (prog2 - (setq *auto-commit* t) - (let ( - (sc1 (open-store *test-path-primary*)) - (sc2 (open-store *test-path-secondary*))) - (let* ((f1 (make-instance 'pfoo :sc sc1)) - (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) - (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) - ) - (let ((fm1 - (ele::migraten-pobj - sc2 f1 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) + (prog2 + (setq *auto-commit* t) + (let ( + (sc1 (open-store *test-spec-primary*)) + (sc2 (open-store *test-spec-secondary*))) + (let* ((f1 (make-instance 'pfoo :sc sc1)) + (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) + (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) + ) + (let ((fm1 + (migrate ;; (ele::migraten-pobj + sc2 f1 + #'(lambda (dst src) + (if (slot-boundp src 'slot1) + (setf (slot1 dst) (slot1 src)))))) (fm2 - (ele::migraten-pobj + (migrate ;; (ele::migraten-pobj sc2 f2 #'(lambda (dst src) (if (slot-boundp src 'slot1) (setf (slot1 dst) (slot1 src)))))) - (bm1 (ele::migraten-pobj + (bm1 (migrate ;; (ele::migraten-pobj sc2 b1 #'(lambda (dst src) (if (slot-boundp src 'slot2) --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2006/02/04 22:25:10 1.9 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2006/02/19 04:53:02 1.10 @@ -375,7 +375,7 @@ ;; test it both ways...since we won't know how they will want it ;; implemented, we will have to somehow make a choice here, maybe ;; based on the stype of *store-controller* - (h (build-btree *store-controller*))) + (h (make-btree *store-controller*))) (are-not-null (in-out-eq f1) (in-out-eq f2) --- /project/elephant/cvsroot/elephant/tests/testsleepycat.lisp 2006/02/04 22:25:10 1.6 +++ /project/elephant/cvsroot/elephant/tests/testsleepycat.lisp 2006/02/19 04:53:02 1.7 @@ -13,12 +13,13 @@ (in-package "ELE-TESTS") + (defvar env) (defvar db) -(defun prepare-sleepycat() +(defun prepare-sleepycat () (setq env (sleepycat::db-env-create)) - (sleepycat::db-env-open env *sleepycatdb-path* :create t :init-txn t :init-lock t + (sleepycat::db-env-open env (cdr *sleepycatdb-spec*) :create t :init-txn t :init-lock t :init-mpool t :init-log t :thread t :recover-fatal t) @@ -27,11 +28,12 @@ :auto-commit t :create t :thread t)) (deftest prepares-sleepycat - (if (not (find-package 'ele-bdb)) + (progn + (if (not (find-package :sleepycat)) (progn - (format t "package ele-bdb not found, so not runnning test prepares-sleepycat~%") - t) - (finishes (prepare-sleepycat))) + (format t "sleepycat db not valid, so not runnning test prepares-sleepycat~%") + t) + (finishes (prepare-sleepycat)))) t) #| @@ -77,7 +79,7 @@ (deftest test-seq1 (if (not (find-package 'ele-bdb)) (progn - (format t "package ele-bdb not found, so not runnning test prepares-sleepycat~%") + (format t "database db not valid, so not runnning test test-seq1~%") t) (finishes (test-sequence1))) t) @@ -98,11 +100,11 @@ finally (sleepycat::db-sequence-remove seq :auto-commit t)))) (deftest test-seq2 - (if (not (find-package 'ele-bdb)) + (if (not db) (progn - (format t "package ele-bdb not found, so not runnning test prepares-sleepycat~%") - t) - (finishes (test-sequence2))) + (format t "sleepycat db not valid, so not runnning test test-seq2~%") + t) + (finishes (test-sequence2))) t) (defun cleanup-sleepycat () @@ -113,9 +115,9 @@ (sleepycat::db-env-remove env "test")) (deftest cleansup-sleepycat - (if (not (find-package 'ele-bdb)) + (if (not db) (progn - (format t "package ele-bdb not found, so not runnning test prepares-sleepycat~%") + (format t "sleepycat db not valid, so not runnning test cleanup-sleepycat~%") t) (finishes (cleanup-sleepycat))) t) From ieslick at common-lisp.net Sun Feb 19 05:13:02 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 23:13:02 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060219051302.87A562A01A@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv9084 Modified Files: ele-clsql.asd Log Message: Minor changes for sql-backend --- /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/19 04:52:58 1.4 +++ /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/19 05:13:02 1.5 @@ -16,7 +16,7 @@ ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -(defsystem ele-sql +(defsystem ele-clsql :name "elephant" :author "Ben Lee " :version "0.6.0" @@ -24,6 +24,7 @@ :licence "LLGPL" :description "SQL-based Object respository for Common Lisp" :long-description "An experimental CL-SQL based implementation of Elephant" + :components ((:module :src :components ((:module :db-clsql From ieslick at common-lisp.net Sun Feb 19 05:13:02 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 23:13:02 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060219051302.CDDEA2A018@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv9084/src/db-clsql Modified Files: sql-controller.lisp Log Message: Minor changes for sql-backend --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 05:13:02 1.2 @@ -19,7 +19,7 @@ (in-package "ELEPHANT") (defpackage elephant-clsql - (:use :common-lisp :elephant :uffi)) + (:use :common-lisp :elephant :elephant-memutil :uffi :elephant-backend :cl-base64)) (in-package "ELEPHANT-CLSQL") @@ -57,18 +57,17 @@ 'with-transaction-sql ) -(defun sql-store-spec-p (path) - (listp path)) +(defun sql-store-spec-p (spec) + (and (listp spec) + (eq (first spec) :clsql))) (defun sql-test-and-construct (spec) (if (sql-store-spec-p spec) (open-store-sql spec) - nil) - ) + nil)) -(eval-when ( :load-toplevel) - (register-strategy 'sql-test-and-construct) - ) +(eval-when (:load-toplevel) + (register-backend-con-init :clsql 'sql-test-and-construct)) (defmacro with-open-store-sql ((spec) &body body) "Executes the body with an open controller, @@ -326,8 +325,8 @@ (recover-fatal nil) (thread t)) (the sql-store-controller - (let* ((dbtype (car (:dbcn-spc sc))) - (con (clsql:connect (cdr (:dbcn-spc sc)) + (let* ((dbtype (car (second (:dbcn-spc sc)))) + (con (clsql:connect (cdr (second (:dbcn-spc sc))) ;; WARNING: This line of code forces us to use postgresql. ;; If this were parametrized upwards we could concievably try ;; other backends. From ieslick at common-lisp.net Sun Feb 19 05:13:03 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 18 Feb 2006 23:13:03 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060219051303.1EE522A018@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv9084/src/elephant Modified Files: controller.lisp Log Message: Minor changes for sql-backend --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 05:13:02 1.2 @@ -32,9 +32,8 @@ (defvar *elephant-backends* '((:bdb (:ele-bdb)) - (:sqlite3 (:ele-clsql :clsql-sqlite3)) - (:postgres (:ele-clsql :clsql-postgres))) - "Entries have the form of (backend-type asdf-depends-list open-controller-fn)") + (:clsql (:ele-clsql))) + "Entries have the form of (backend-type asdf-depends-list") (defvar *elephant-controller-init* (make-hash-table)) From ieslick at common-lisp.net Sun Feb 19 16:22:40 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 10:22:40 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060219162240.13BAF4200E@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv18566 Modified Files: Makefile ele-clsql.asd elephant.asd Log Message: Further reorg, added auto build of memutil --- /project/elephant/cvsroot/elephant/Makefile 2006/02/19 04:52:58 1.9 +++ /project/elephant/cvsroot/elephant/Makefile 2006/02/19 16:22:39 1.10 @@ -1,41 +1,57 @@ # -# GNU Makefile for compiling libsleepycat.c (BSDers use gmake) +# GNU Makefile for compiling elephant libs (BSDers use gmake) # -# Contributed by Rafal Strzalinski +# Originally contributed by Rafal Strzalinski # SHELL=/bin/sh UNAME:=$(shell uname -s) -# DB43DIR=/db/ben/lisp/db43 -# Dan Knapp contributed this line, which came form OS X? -#DB43DIR=/sw +ifeq (Darwin,$(UNAME)) + SHARED=-bundle + EXT=dylib +else + SHARED=-shared + EXT=so +endif + +# +# ALL PLATFORMS NEED TO LOAD MEMUTILS +# + +UTILSRC=src/memutil + +all: $(UTILSRC)/libmemutil.$(EXT) + +$(UTILSRC)/libmemutil.$(EXT): $(UTILSRC)/libmemutil.c + gcc $(SHARED) -Wall -fPIC -O3 -o $@ $< -lm + +# +# NON BDB PLATFORMS SHOULDN'T NEED TO COMPILE LIBSLEEPYCAT +# SO ONLY EDIT THIS IF YOU WANT TO USE BDB! +# + # But I will assume that Linux is more common? DB43DIR=/usr/local/BerkeleyDB.4.3/ +# Dan Knapp contributed this line, which came form OS X? +# DB43DIR=/sw +# Other example paths +# DB43DIR=/db/ben/lisp/db43 -DBLIBDIR=$(DB43DIR)/lib/ DBINCDIR=$(DB43DIR)/include/ # Dan Knapp contributed this line; for fink/OS X? #DBINCDIR=$(DB43DIR)/include/db4/ +DBLIBDIR=$(DB43DIR)/lib/ # *BSD users will probably want #DBLIBDIR=/usr/local/lib/db43 #DBINCDIR=/usr/local/include/db43 -ifeq (Darwin,$(UNAME)) - SHARED=-bundle - EXT=dylib -else - SHARED=-shared - EXT=so -endif - -all: libsleepycat.$(EXT) libmemutil.$(EXT) +BDBSRC=src/db-bdb -libmemutil.$(EXT): src/memutil/libmemutil.c - gcc $(SHARED) -Wall -fPIC -O3 -o $@ $< -lm +bdb: libsleepycat.$(EXT) -libsleepycat.$(EXT): src/db-bdb/libsleepycat.c +$(BDBSRC)/libsleepycat.$(EXT): $(BDBSRC)/libsleepycat.c gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm --- /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/19 05:13:02 1.5 +++ /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/19 16:22:39 1.6 @@ -30,7 +30,7 @@ ((:module :db-clsql :components ((:file "sql-controller") - (:file "sql-transactions") + (:file "sql-transaction") (:file "sql-collections")) :serial t)))) :depends-on (:elephant :clsql :cl-base64)) --- /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 04:52:58 1.13 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 16:22:39 1.14 @@ -23,6 +23,58 @@ (in-package :elephant-system) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; We need this dependency satisfied to compute what to do for C files + (unless (find-package 'uffi) + (asdf:operate 'asdf:load-op 'uffi))) + +(defclass elephant-util-c-source (c-source-file) + ()) + +(defparameter *root-dir* (pathname-directory *load-truename*)) + +(defparameter *library-file-dir* (append (pathname-directory *load-truename*) + (list "src" "memutil"))) + +;; Compile foreign library on non-win32 platforms + +(defmethod output-files ((o compile-op) (c elephant-util-c-source)) + (let* ((library-file-type + (funcall (intern (symbol-name '#:default-foreign-library-type) + (symbol-name '#:uffi))))) + (list (make-pathname :name (component-name c) + :type library-file-type + :directory *library-file-dir*)))) + +(defmethod perform ((o compile-op) (c elephant-util-c-source)) + (unless (operation-done-p o c) + #-(or win32 windows) + (unless (zerop (uffi:run-shell-command + (format nil + #-freebsd "cd ~A; make" + #+freebds "cd ~A; gmake" + (make-pathname :directory *root-dir*)))) + (error 'operation-error :component c :operation o)))) + +(defmethod operation-done-p ((o compile-op) (c elephant-util-c-source)) + (or (let ((lib (make-pathname :defaults (component-pathname c) + :type (uffi:default-foreign-library-type)))) + (and (probe-file lib) (probe-file (component-pathname c)) + (> (file-write-date lib) (file-write-date (component-pathname c))))))) + +;; Load op - ensure that foreign library is loaded + +(defmethod perform ((o load-op) (c elephant-util-c-source)) + "Nothing to do!" + t) + +(defmethod operation-done-p ((o load-op) (c elephant-util-c-source)) + "Operation is done when the foreign library is loaded which should + happen when we compile the interface lisp file" + (and (symbol-function (intern (symbol-name '#:copy-bufs) + (find-package '#:elephant-memutil))) + t)) + (defsystem elephant :name "elephant" :author "Ben Lee " @@ -36,7 +88,9 @@ :components ((:module memutil :components - ((:file "memutil"))) + ((:elephant-util-c-source "libmemutil") + (:file "memutil")) + :serial t) (:module elephant :components ((:file "elephant") @@ -58,3 +112,6 @@ :depends-on (memutil))))) :depends-on (:uffi)) + + + From ieslick at common-lisp.net Sun Feb 19 16:22:40 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 10:22:40 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src Message-ID: <20060219162240.648E74200E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv18566/src Removed Files: berkeley-db.lisp classes.lisp index-utils.lisp Log Message: Further reorg, added auto build of memutil From ieslick at common-lisp.net Sun Feb 19 16:22:40 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 10:22:40 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060219162240.AB3314200E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv18566/src/db-bdb Removed Files: bdb-enable.lisp libutil.c sleepycat-old.lisp Log Message: Further reorg, added auto build of memutil From ieslick at common-lisp.net Sun Feb 19 16:22:41 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 10:22:41 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060219162241.1389743000@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv18566/src/db-clsql Modified Files: sql-collections.lisp sql-controller.lisp sql-transaction.lisp Log Message: Further reorg, added auto build of memutil --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 16:22:40 1.2 @@ -17,8 +17,7 @@ ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; -(in-package "ELEPHANT") - +(in-package "ELEPHANT-CLSQL") (defclass sql-btree-index (btree-index sql-btree) () @@ -80,10 +79,10 @@ :oid (cursor-oid cursor) ;; Do we need to so some kind of copy on this collection? :keys (:sql-crsr-ks cursor) - :curkey (:sql-crsr-ck cursor) - :handle (db-cursor-duplicate - (cursor-handle cursor) - :position (cursor-initialized-p cursor)))) + :curkey (:sql-crsr-ck cursor))) +;; :handle (db-cursor-duplicate +;; (cursor-handle cursor) +;; :position (cursor-initialized-p cursor)))) (defmethod cursor-current ((cursor sql-cursor)) (declare (optimize (speed 3))) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 05:13:02 1.2 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 16:22:40 1.3 @@ -19,13 +19,14 @@ (in-package "ELEPHANT") (defpackage elephant-clsql - (:use :common-lisp :elephant :elephant-memutil :uffi :elephant-backend :cl-base64)) + (:use :common-lisp :uffi :cl-base64 + :elephant :elephant-memutil :elephant-backend )) (in-package "ELEPHANT-CLSQL") ;;; other clsql packages would have to be added for ;;; non-postgresql databases, see the CL-SQL documentation -(eval-when ( :compile-toplevel :load-toplevel) +(eval-when (:compile-toplevel :load-toplevel) ;; NOTE: Integrate into load process ;; Probably must be customized ... see documentation on installin postgres. (defvar *clsql-foreign-lib-path* "/usr/lib") @@ -40,22 +41,15 @@ ;; to the database called "test" under the user postgress ;; with the psql console first. Then study the authorization ;; and configuration files. - :initform '("localhost.localdomain" "test" "postgres" "") - ) - ) + :initform '("localhost.localdomain" "test" "postgres" "")) + (db :accessor controller-db :initarg :db :initform nil)) (:documentation "Class of objects responsible for the -book-keeping of holding DB handles, the cache, table -creation, counters, locks, the root (for garbage collection,) -et cetera. This is the Postgresql-specific subclass of store-controller.") - ) + book-keeping of holding DB handles, the cache, table + creation, counters, locks, the root (for garbage collection,) + et cetera. This is the Postgresql-specific subclass of store-controller.")) (defmethod build-btree ((sc sql-store-controller)) - (make-sql-btree sc) - ) - -(defmethod get-transaction-macro-symbol ((sc sql-store-controller)) - 'with-transaction-sql - ) + (make-sql-btree sc)) (defun sql-store-spec-p (spec) (and (listp spec) @@ -171,7 +165,7 @@ (when populate (let ((key-fn (key-fn index)) ) - (with-transaction-sql (:store-controller-sql sc) + (with-transaction (:store-controller sc) (map-btree #'(lambda (k v) (multiple-value-bind (index? secondary-key) @@ -193,7 +187,7 @@ (let* ((sc (get-con bt)) (con (controller-db sc)) (indices (indices-cache bt))) - (with-transaction-sql (:store-controller-sql sc) + (with-transaction (:store-controller sc) (maphash #'(lambda (k index) (multiple-value-bind (index? secondary-key) @@ -216,7 +210,7 @@ (let* ( (sc (get-con bt)) (con (controller-db sc))) - (with-transaction-sql (:store-controller-sql sc) + (with-transaction (:store-controller sc) (let ((value (get-value key bt))) (when value (let ((indices (indices-cache bt))) @@ -342,7 +336,8 @@ ;; can put it in a function.... (unless (keyvalue-table-exists con) (create-keyvalue-table con)) - (setf (slot-value sc 'root) (make-sql-btree sc)) + (setf (slot-value sc 'root) (build-btree sc)) + (setf (slot-value sc 'class-root) (build-indexed-btree sc)) ;; Actaully, it would seem here that we must further set the oid ;; of the root tree to 0 to ensure that we read the correct thing ;; when we next opent he controller... --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/02/19 16:22:40 1.2 @@ -17,14 +17,14 @@ ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; +(in-package "ELEPHANT-CLSQL") -(defun execute-transaction ((sc sql-store-controller) txn-fn args) +(defmethod execute-transaction ((sc sql-store-controller) txn-fn &key &allow-other-keys) "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." - (declare (ignore args)) ;; SQL doesn't support nested transaction so we lump it all ;; together (if (clsql::in-transaction-p :database (controller-db sc)) @@ -36,8 +36,12 @@ (funcall txn-fn)) (clsql::set-autocommit t))))) -;; NOTE: Implement this! -(defmethod controller-start-transaction ((sc sql-store-controller) &rest args)) -(defmethod controller-commit-transaction ((sc sql-store-controller)) -(defmethod controller-abort-transaction ((sc sql-store-controller))) +(defmethod controller-start-transaction ((sc sql-store-controller) &key &allow-other-keys) + (clsql:start-transaction :database (controller-db sc))) + +(defmethod controller-commit-transaction ((sc sql-store-controller) &key &allow-other-keys) + (clsql:commit :database (controller-db sc))) + +(defmethod controller-abort-transaction ((sc sql-store-controller) &key &allow-other-keys) + (clsql:rollback :database (controller-db sc))) From ieslick at common-lisp.net Sun Feb 19 16:22:43 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 10:22:43 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060219162243.8A83944012@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv18566/src/elephant Modified Files: backend.lisp Log Message: Further reorg, added auto build of memutil --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 16:22:43 1.2 @@ -45,21 +45,26 @@ #:class-root #:flush-instance-cache ;; Collection generic functions - #:build-indexed-btree #:build-btree - #:deserialize #:serialize #:existsp + #:build-indexed-btree #:build-btree #:existsp + ;; Serialization + #:deserialize #:serialize + #:deserialize-from-base64-string + #:serialize-to-base64-string ;; Cursor accessors #:cursor-btree #:cursor-oid #:cursor-initialized-p - ;; Misc - #:slot-definition-name - #:register-backend-con-init - #:lookup-backend-con-init ;; Transactions #:execute-transaction #:controller-start-transaction #:controller-commit-transaction #:controller-abort-transaction + ;; Misc + #:slot-definition-name + #:remove-indexed-element-and-adjust + #:register-backend-con-init + #:lookup-backend-con-init + #:form-slot-key ) (:export ;; Variables @@ -83,20 +88,25 @@ #:class-root #:flush-instance-cache ;; Collection generic functions - #:build-indexed-btree #:build-btree - #:deserialize #:serialize #:existsp + #:build-indexed-btree #:build-btree #:existsp + ;; Serialization + #:deserialize #:serialize + #:deserialize-from-base64-string + #:serialize-to-base64-string ;; Cursor accessors #:cursor-btree #:cursor-oid #:cursor-initialized-p - ;; Misc - #:slot-definition-name - #:register-backend-con-init - #:lookup-backend-con-init ;; Transactions #:execute-transaction #:controller-start-transaction #:controller-commit-transaction #:controller-abort-transaction + ;; Misc + #:slot-definition-name + #:remove-indexed-element-and-adjust + #:register-backend-con-init + #:lookup-backend-con-init + #:form-slot-key )) \ No newline at end of file From ieslick at common-lisp.net Sun Feb 19 16:22:43 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 10:22:43 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20060219162243.CEBEC44009@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory common-lisp:/tmp/cvs-serv18566/src/memutil Modified Files: memutil.lisp Log Message: Further reorg, added auto build of memutil --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 04:53:02 1.1 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 16:22:43 1.2 @@ -65,21 +65,14 @@ #+(or darwin macosx) "dylib" #-(or darwin macosx) "so" ) - (defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant/")) - -(eval-when (:compile-toplevel :load-toplevel) - - (unless - (uffi:load-foreign-library - (if (find-package 'asdf) - (merge-pathnames - (make-pathname :name "libmemutil" :type *c-library-extension*) - (asdf:component-pathname (asdf:find-system 'elephant))) - (format nil "~A/~A.~A" *elephant-lib-path* "libmemutil" *c-library-extension*)) - :module "libmemutil") - (error "Couldn't load libmemutil.~A!" *c-library-extension*)) - - ;; fini on user editable part + (unless + (uffi:load-foreign-library + (merge-pathnames + (make-pathname :name "libmemutil" :type *c-library-extension* ) + (merge-pathnames (make-pathname :directory "src/memutil") + (asdf:component-pathname (asdf:find-system 'elephant)))) + :module "libmemutil") + (error "Couldn't load src/memutil/libmemutil.~A in!" *c-library-extension*)) (def-type pointer-int (* :int)) (def-type pointer-void :pointer-void) @@ -87,7 +80,16 @@ #+allegro (:array :char) #+(or cmu sbcl scl openmcl) (* :char)) (def-type array-or-pointer-char array-or-pointer-char) - ) + + ;; Standard utility for copying two foreign buffers -- + ;; also to test that lib is actually loaded! + (def-function ("copy_buf" copy-bufs) + ((dest array-or-pointer-char) + (dest-offset :int) + (src array-or-pointer-char) + (src-offset :int) + (length :int)) + :returning :void)) (declaim (inline read-int read-uint read-float read-double write-int write-uint write-float write-double @@ -410,15 +412,6 @@ (setf (deref-array dest 'array-or-pointer-char (+ i dest-offset)) (char-code (char src (+ i src-offset)))))))) -;; For copying two foreign buffers -(def-function ("copy_buf" copy-bufs) - ((dest array-or-pointer-char) - (dest-offset :int) - (src array-or-pointer-char) - (src-offset :int) - (length :int)) - :returning :void) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From ieslick at common-lisp.net Sun Feb 19 17:25:53 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 11:25:53 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060219172553.0CEB72A01A@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv25268 Modified Files: INSTALL Makefile ele-bdb.asd Log Message: New build process completed & tested for BDB --- /project/elephant/cvsroot/elephant/INSTALL 2006/02/15 01:54:07 1.14 +++ /project/elephant/cvsroot/elephant/INSTALL 2006/02/19 17:25:52 1.15 @@ -26,9 +26,28 @@ A C compiler, probably gcc or Visual Studio. Presumably you have this if you installed Sleepycat. ------------- -Instructions ------------- +------------------ +Short Instructions +------------------ + +The new build system should work out of the box on most Un*x +platforms that have asdf, uffi and either clsql or Berkeley DB +installed in the usual places. + +Try: (asdf:operate 'asdf:load-op :elephant) +Then: (open-store '( )) + +Where = { :bdb | :clsql } + = { '(:sqlite3 "db path") | '(:postgresql "db path") | "bdb directory" } + +This should load all files, including compiling libraries, on +most systems. For Win32, see the instructions below. + +(We'll improve the build process for Win32 if there is demand) + +----------------- +Long Instructions +----------------- I assume you have a supported lisp with asdf. @@ -36,58 +55,69 @@ /usr/local/share/common-lisp/elephant-0.3/ + 1) Install UFFI. If you're using 1.4.24 replace -path-to-uffi/src/functions.lisp + path-to-uffi/src/functions.lisp + + with the provided file. -with the provided file. -2) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. +2) Install ASDF. + +Ensure that you have a recent version of ASDF installed as +the load process now depends upon it. + + +3) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. + +------- +SQL +------- For relational database systems, refering the formal documentation other the heading "SQL-BACK-END". -For Berkeley 4.3: -Under Un*x, you may actually -already have this installed, though it may be compiled with -funny options, so if things don't work you may want to try -to start from scratch. FreeBSD has a port for this, as I'm -sure do other BSDs (including Darwin/Fink.) Take note of -where libdb.so and db.h are installed (usually -/usr/local/BerekleyDB.4.3/lib/libdb.so and -/usr/local/BerekleyDB.4.3/include/db.h, or -/usr/local/lib/db42/libdb.so and -/usr/local/include/db42/db.h.) +------------- +Berkeley 4.3: +------------- -Compile and install the libsleepycat shared library. +Under Un*x, you may actually already have this installed, though +it may be compiled with funny options, so if things don't work +you may want to try to start from scratch. FreeBSD has a port +for this, as I'm sure do other BSDs (including Darwin/Fink.) +Take note of where libdb.so and db.h are installed, usually: -Under Un*x, edit Makefile and run (using GNU make, gmake on -BSD) + /usr/local/BerekleyDB.4.3/lib/libdb.so and + /usr/local/BerekleyDB.4.3/include/db.h, or -make + /usr/local/lib/db42/libdb.so and + /usr/local/include/db42/db.h.) -This compiles src/libsleepycat.c and installs it into +a) Edit Makefile variable DB43DIR and DB43INC, DB43LIB if necessary -/usr/local/share/common-lisp/elephant-0.3/ +This makes sure that the build process can find your files. +You can test that the build works by calling: -You probably have to make sure this directory exists before running -make install. +'make bdb'. -If you need to change this path, you will change it in the Makefile -and also in controller.lisp on the line: +b) Also edit the variable *sleepycat-foreign-library-path* in -(defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant-0.3/") + ele-bdb.asd -or where you specified. On Darwin / OS X you need to have -the developer tools installed. In the Makefile and other places -there are commented-out lines showing settings that some users have used for -OS X; if you are using that I assume you will have to comment out the -appropriate lines and uncomment those examples. +to point to your local distribution of the Berkeley DB libraries -For Win32 (directions courtesy of Bill Clementson): +Darwin / OS X +--------------- +You need to have the developer tools installed. In the Makefile and +ele-bdb.lib there are commented-out lines showing settings that some +users have used for OS X; if you are using that I assume you will +have to comment out the appropriate lines and uncomment those examples. -Create an MSVC dll project and add src/libsleepycat.c, -src/libsleepycat.def and the Berkeley DB libdb43.lib files +For Win32 (directions courtesy of Bill Clementson): +--------------------------------------------------- +Create an MSVC dll project and add src/db-bdb/libsleepycat.c, +src/db-bdb/libsleepycat.def and the Berkeley DB libdb43.lib files to the project (should be in the build_win32/release folder) Add the Berkeley DB dbinc include files directory and the @@ -101,15 +131,28 @@ libsleepycat.c, it may or may not be necessary to load libdb43.dll into Lisp (see below.) -3) Compile and load Elephant: -First, edit src/sleepycat.lisp so that it points to the -correct libraries. If you're using Un*x and ASDF, this is -probably automagic. - -Symlink elephant.asd to your asdf systems directory (mine is -/usr/local/share/common-lisp/systems). Fire up lisp and -depending on your database backend: +4) Compile and load Elephant: + +The new backend load process should work automatically on Un*x +systems but if there are problems with loading foreign libraries, +then you can test your C tools setup with 'make' in the elephant +root directory. This will build the common memutils library +in src/memutil/libmemutil.so/dylib that all backends require. + +There is a new two-phase load process. The first requires that +you use asdf to load the main elephant front-end: + +(asdf:operate 'asdf:load-op :elephant) + +This will load and compile Elephant. This will also automatically +load UFFI. + +When you call (open-store ) inside lisp it will automatically +load the remaining dependencies for the specified backend via ASDF. + +To test the load process explicitly the following asdf files are +provided: if you are using Sleepycat / Berkeley DB, type: (asdf:operate 'asdf:load-op :ele-bdb) @@ -120,16 +163,8 @@ if you are using SQLite3, type: (asdf:operate 'asdf:load-op :ele-sqlite3) -This will load and compile Elephant. This will also -automatically load UFFI. -I can't seem to make OpenMCL not intern default keyword -values of my macros -- something which doesn't happen on -other implementations. I can't reproduce the issue except -for in my code, but expect (use-package "ELE")'s to produce -conflicting symbol warnings. - -4) Make the documentation: +5) Make the documentation: Execute: @@ -137,6 +172,7 @@ In the doc directory should be build the HTML version of the texinfo files. + ------- Testing ------- @@ -145,16 +181,29 @@ http://www.cliki.net/RT -Once RT is installed, edit tests/elephant-tests.lisp to make -*testdb-path* point to somewhere appropriate. Symlink -elephant-tests.asd to your asdf systems directory, then run +Once RT is installed (asdf:operate 'asdf:load-op :elephant-tests) (in-package :ele-tests) -(do-all-tests) +(setf *default-spec* ) + where = { *testsqlite3-spec* | *testpg-spec* | *testbdb-spec* } +(do-backend-tests) + +This will test the standalone API for your backend. Currently all tests are +passing on 0.6.0. There will be a set of migration tests that will be 'ignored' +but the final message should indicate no failing tests. + +This should take less than 5 minutes on decent hardware. + +Elephant allows migration between repositories. To test this: + +(do-migration-tests *default-spec* ) + where is a different *testXXXXX-spec* variable to test migration + to that backend. + +This should take less than 2 minutes on decent hardware. + +A backend is considered "green" if it can pass both the backend tests and the +migration tests. -this should take about 5 minutes on decent hardware. Note -that the "no-eval-initform" and "update-class" tests fail, -these are known bugs which will get fixed in a future -release. --- /project/elephant/cvsroot/elephant/Makefile 2006/02/19 16:22:39 1.10 +++ /project/elephant/cvsroot/elephant/Makefile 2006/02/19 17:25:52 1.11 @@ -49,7 +49,7 @@ BDBSRC=src/db-bdb -bdb: libsleepycat.$(EXT) +bdb: $(BDBSRC)/libsleepycat.$(EXT) $(BDBSRC)/libsleepycat.$(EXT): $(BDBSRC)/libsleepycat.c gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 04:52:58 1.6 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 17:25:52 1.7 @@ -23,6 +23,82 @@ (in-package :ele-bdb-system) +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; We need this dependency satisfied to compute what to do for C files + (unless (find-package 'uffi) + (asdf:operate 'asdf:load-op 'uffi))) + +;; +;; EDIT ME FOR YOUR SYSTEM +;; +;; An attempt at good defaults is here. We should +;; later add a search function that users can add to +;; so they don't have to edit source +;; + +(defparameter *sleepycat-foreign-library-path* + ;; Sleepycat: this works on linux + #+linux +;; "/db/ben/lisp/db43/lib/libdb.so" + "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" + ;; this works on FreeBSD + #+(and (or bsd freebsd) (not (or darwin macosx))) + "/usr/local/lib/db43/libdb.so" + #+(or darwin macosx) + ;; for Fink (OS X) -- but I will assume Linux more common... +;; "/sw/lib/libdb-4.3.dylib" + ;; a possible manual install + "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib") + +(defclass bdb-c-source (c-source-file) + ()) + +(defparameter *root-dir* (pathname-directory *load-truename*)) + +(defparameter *library-file-dir* (append (pathname-directory *load-truename*) + (list "src" "db-bdb"))) + +;; Compile foreign library on non-win32 platforms + +(defmethod output-files ((o compile-op) (c bdb-c-source)) + (let ((library-file-type + (funcall (intern (symbol-name '#:default-foreign-library-type) + (symbol-name '#:uffi))))) + (list (make-pathname :name (component-name c) + :type library-file-type + :directory *library-file-dir*)))) + +(defmethod perform ((o compile-op) (c bdb-c-source)) + (unless (operation-done-p o c) + #-(or win32 windows) + (unless (zerop (uffi:run-shell-command + (format nil + #-freebsd "cd ~A; make bdb" + #+freebds "cd ~A; gmake bdb" + (make-pathname :directory *root-dir*)))) + (format t "Couldn't build library from libsleepycat.c via 'make bdb'~%") + (error 'operation-error :component c :operation o)))) + +(defmethod operation-done-p ((o compile-op) (c bdb-c-source)) + (or (let ((lib (make-pathname :defaults (component-pathname c) + :type (uffi:default-foreign-library-type)))) + (and (probe-file lib) (probe-file (component-pathname c)) + (> (file-write-date lib) (file-write-date (component-pathname c))))))) + +;; Load op - ensure that foreign library is loaded + +(defmethod perform ((o load-op) (c bdb-c-source)) + "Nothing to do!" + t) + +(defmethod operation-done-p ((o load-op) (c bdb-c-source)) + "Operation is done when the foreign library is loaded which should + happen when we compile the interface lisp file" + (and (symbol-function (intern (symbol-name '#:%db-strerror) + (find-package '#:sleepycat))) + t)) + + (defsystem ele-bdb :name "elephant" :author "Ben Lee " @@ -37,6 +113,7 @@ ((:module :db-bdb :components ((:file "package") + (:bdb-c-source "libsleepycat") (:file "sleepycat") (:file "bdb-controller") (:file "bdb-transactions") From ieslick at common-lisp.net Sun Feb 19 17:25:53 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 11:25:53 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060219172553.5DC162A01A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv25268/src/db-bdb Modified Files: sleepycat.lisp Added Files: libsleepycat.def Log Message: New build process completed & tested for BDB --- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 17:25:53 1.2 @@ -45,8 +45,69 @@ %db-sequence-get-lower db-sequence-get-fixnum )) +;; +;; EXTERNAL LIBRARY DEPENDENCIES - LOAD DURING LOAD/COMPILATION +;; + +(eval-when (:compile-toplevel :load-toplevel) + + ;; + ;; Under Linux we need pthreads! + ;; + + #+linux + (unless + (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") + (error "Couldn't load libpthread!")) + + ;; + ;; Our interface library requires that the main Berkeley DB library be loaded + ;; + + (unless + (uffi:load-foreign-library + ele-bdb-system::*sleepycat-foreign-library-path* + :module "sleepycat") + (error "Couldn't load libdb (Sleepycat)!")) + + ;; + ;; Our local interface library + ;; + + (unless + (uffi:load-foreign-library + (merge-pathnames + (make-pathname :name "libsleepycat" :type *c-library-extension*) + (merge-pathnames (make-pathname :directory "src/db-bdb") + (asdf:component-pathname (asdf:find-system 'elephant)))) + :module "libsleepycat") + (error "Couldn't load src/db-bdb/libsleepycat.~A!" elephant-memutil::*c-library-extension*)) + + ;; Error handling + ;; I put this here so we could validate that the library was loaded + + (def-function ("db_strerr" %db-strerror) + ((error :int)) + :returning :cstring) + + (defun db-strerror (errno) + "Get the string error associated with an error number." + (convert-from-cstring (%db-strerror errno))) + + (define-condition db-error (error) + ((errno :type fixnum :initarg :errno :reader db-error-errno)) + (:report + (lambda (condition stream) + (declare (type db-error condition) (type stream stream)) + (format stream "Berkeley DB error: ~A" + (db-strerror (db-error-errno condition))))) + (:documentation "Berkeley DB / Sleepycat errors.")) + ) + +;; ;; Constants and Flags ;; eventually write a macro which generates a custom flag function. +;; ;I don't like the UFFI syntax for enumerations (defconstant DB-BTREE 1) @@ -327,45 +388,6 @@ ,@(when set-transaction-timeout `((when ,set-transaction-timeout (setq ,flags (logior ,flags DB_SET_TXN_TIMEOUT))))) ,flags))) - -(eval-when (:compile-toplevel :load-toplevel) - (def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN)) - - #+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" - "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" - ;; this works on FreeBSD - #+(and (or bsd freebsd) (not darwin) (not macosx)) - "/usr/local/lib/db43/libdb.so" - #+(or darwin macosx) - ;; for Fink (OS X) -- but I will assume Linux more common... -;; "/sw/lib/libdb-4.3.dylib" - ;; a possible manual install - "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib" - :module "sleepycat") - (error "Couldn't load libdb (Sleepycat)!")) - - ;; Libsleepycat.so: edit this - (unless - (uffi:load-foreign-library - (if (find-package 'asdf) - (merge-pathnames - (make-pathname :name "libsleepycat" :type elephant-memutil::*c-library-extension*) - (asdf:component-pathname (asdf:find-system 'elephant))) - (format nil "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.~A" elephant-memutil::*c-library-extension*)) - :module "libsleepycat") - (error "Couldn't load libsleepycat.~A!" elephant-memutil::*c-library-extension*)) - ) - - ;; Environment (def-function ("db_env_cr" %db-env-create) @@ -470,6 +492,9 @@ ;; Database +(eval-when (:compile-toplevel :load-toplevel) + (def-enum DBTYPE ((:BTREE 1) :HASH :QUEUE :RECNO :UNKNOWN))) + (def-function ("db_cr" %db-create) ((dbenv :pointer-void) (flags :unsigned-int) @@ -1845,24 +1870,3 @@ (if (< ret 0) (error 'db-error :errno ret) ret))) - -;; Misc - -;; Errors - -(def-function ("db_strerr" %db-strerror) - ((error :int)) - :returning :cstring) - -(defun db-strerror (errno) - "Get the string error associated with an error number." - (convert-from-cstring (%db-strerror errno))) - -(define-condition db-error (error) - ((errno :type fixnum :initarg :errno :reader db-error-errno)) - (:report - (lambda (condition stream) - (declare (type db-error condition) (type stream stream)) - (format stream "Berkeley DB error: ~A" - (db-strerror (db-error-errno condition))))) - (:documentation "Berkeley DB / Sleepycat errors.")) --- /project/elephant/cvsroot/elephant/src/db-bdb/libsleepycat.def 2006/02/19 17:25:53 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/libsleepycat.def 2006/02/19 17:25:53 1.1 LIBRARY Elephant EXPORTS read_int read_uint read_float read_double write_int write_uint write_float write_double offset_charp copy_buf db_env_cr db_strerr db_env_close db_env_open db_env_dbremove db_env_dbrename db_env_remove db_env_set_flags db_env_get_flags db_cr db_close db_open db_remove db_rename db_sync db_truncate db_set_flags db_get_flags db_set_pagesize db_get_pagesize db_set_bt_compare db_set_dup_compare read_num lisp_compare db_set_lisp_compare db_set_lisp_dup_compare case_cmp lex_cmp utf16_cmp db_get_raw db_put_raw db_del db_cursor db_cursor_close db_cursor_del db_cursor_dup db_cursor_get_raw db_cursor_pget_raw db_cursor_put_raw db_del_kv db_cursor_get_multiple_key db_multiple_key_next db_txn_begin db_txn_abort db_txn_commit db_txnp_begin db_txn_id db_env_lock_id db_env_lock_id_free db_env_lock_get db_env_lock_put db_env_lock_vec db_env_set_timeout db_env_get_timeout db_env_set_lk_detect db_env_get_lk_detect db_env_lock_detect db_associate never_index db_fake_associate next_counter From ieslick at common-lisp.net Sun Feb 19 17:25:53 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 11:25:53 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20060219172553.9F9F32A01A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory common-lisp:/tmp/cvs-serv25268/src/memutil Modified Files: memutil.lisp Log Message: New build process completed & tested for BDB --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 16:22:43 1.2 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 17:25:53 1.3 @@ -52,6 +52,8 @@ #:pointer-int #:pointer-void #:array-or-pointer-char +NULL-CHAR+ +NULL-VOID+ + + #:*c-library-extension* )) (in-package "ELEPHANT-MEMUTIL") @@ -63,7 +65,7 @@ (eval-when (:compile-toplevel :load-toplevel) (defparameter *c-library-extension* #+(or darwin macosx) "dylib" - #-(or darwin macosx) "so" ) + #-(or darwin macosx) "so") (unless (uffi:load-foreign-library From ieslick at common-lisp.net Sun Feb 19 17:25:54 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 11:25:54 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060219172554.63AD02A01A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv25268/tests Modified Files: elephant-tests.lisp Log Message: New build process completed & tested for BDB --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 04:53:02 1.14 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 17:25:53 1.15 @@ -93,7 +93,7 @@ ;; ;; 1) Set *default-spec* to the above spec of your choice ;; 2) Call (do-backend-tests) to test the standard API -;; 3) To test migration: (do-migration *default-spec* ) inserting a second +;; 3) To test migration: (do-migration-tests *default-spec* ) inserting a second ;; spec, typically a bdb spec or create another instance of a sql db depending on ;; your configuration ;; 4) A backend is green if it passes do-backend-tests and can succesfully be From ieslick at common-lisp.net Sun Feb 19 20:06:03 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 14:06:03 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060219200603.2DD556B00C@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv14267 Modified Files: TODO ele-bdb.asd ele-sqlite3.asd elephant.asd Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/TODO 2006/02/19 04:52:58 1.13 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/19 20:06:03 1.14 @@ -7,17 +7,19 @@ 0.6.0 - Adding default class/slot indexing - Finish indexing tests (Ian) - Documentation update (Robert) -* Add clsql like support for building .so/.dylib from asdf loader on most systems -* Make elephant thread bound variables dynamic and modifiable by backends +* Make sure library path push happens in build + process and not sql-controller... +* Finish CLSQL debug * Finish migration port and tests -- Think about dynamic vs. object based store & transaction resolution? - - Error checking when mixed - - Current store specific *current-transaction* stack -- Throw condition when store spec is invalid, etc +? Make elephant thread bound variables dynamic and modifiable by backends 0.6.1 - performance, safety and portability Stability: +- Think about dynamic vs. object based store & transaction resolution? + - Error checking when mixed + - Current store specific *current-transaction* stack +- Throw condition when store spec is invalid, etc - Think through default vs. explicit store referencing all over the APIs (Both) - Cleaner failure modes if operations are performed without repository or without transaction or auto-commit (Both) --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 17:25:52 1.7 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 20:06:03 1.8 @@ -94,8 +94,9 @@ (defmethod operation-done-p ((o load-op) (c bdb-c-source)) "Operation is done when the foreign library is loaded which should happen when we compile the interface lisp file" - (and (symbol-function (intern (symbol-name '#:%db-strerror) - (find-package '#:sleepycat))) + (and (and (find-package '#:sleepycat) + (symbol-function (intern (symbol-name '#:%db-strerror) + (find-package '#:sleepycat)))) t)) --- /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/19 04:52:58 1.5 +++ /project/elephant/cvsroot/elephant/ele-sqlite3.asd 2006/02/19 20:06:03 1.6 @@ -56,4 +56,4 @@ ( ) :serial t)) - :depends-on (:ele-sql :clsql-sqlite3)) + :depends-on (:ele-clsql :clsql-sqlite3)) --- /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 16:22:39 1.14 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 20:06:03 1.15 @@ -71,8 +71,9 @@ (defmethod operation-done-p ((o load-op) (c elephant-util-c-source)) "Operation is done when the foreign library is loaded which should happen when we compile the interface lisp file" - (and (symbol-function (intern (symbol-name '#:copy-bufs) - (find-package '#:elephant-memutil))) + (and (find-package "ELEPHANT-MEMUTIL") + (symbol-function (intern "COPY-BUFS" + (find-package "ELEPHANT-MEMUTIL"))) t)) (defsystem elephant From ieslick at common-lisp.net Sun Feb 19 20:06:03 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 14:06:03 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060219200603.84E626C003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv14267/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp sleepycat.lisp Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 20:06:03 1.2 @@ -76,11 +76,9 @@ ;; Secondary indices (defclass bdb-indexed-btree (indexed-btree bdb-btree) - ( - (indices :accessor indices :initform (make-hash-table)) + ((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 BDB-based BTree supports secondary indices.")) @@ -90,20 +88,10 @@ (setf (indices-cache instance) (indices instance))) (defmethod build-indexed-btree ((sc bdb-store-controller)) - (let ((bt (make-instance 'bdb-indexed-btree :sc sc))) -;; (setf (:dbcn-spc-pst bt) (controller-path sc)) -;; I must be confused with multipler inheritance, because the above -;;; initforms in bdb-indexed-btree should be working, but aren't. -;; (setf (indices bt) (make-hash-table)) -;; (setf (indices-cache bt) (make-hash-table)) - bt)) + (make-instance 'bdb-indexed-btree :sc sc)) (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)) + (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) (defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) (let ((sc (get-con bt))) @@ -221,8 +209,6 @@ (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) -;; I now think this code should be split out into a separate -;; class... (defmethod get-value (key (bt bdb-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3))) @@ -248,13 +234,6 @@ (values (deserialize buf :sc (get-con bt)) oid)) (values nil nil))))) - -;; Cursor operations -;; Node that I have not created a bdb-cursor, but have -;; created a sql-currsor. This is almost certainly wrong -;; and furthermore will badly screw things up when we get to -;; secondary cursors. - (defclass bdb-cursor (cursor) ((handle :accessor cursor-handle :initarg :handle)) (:documentation "A cursor for traversing (primary) BDB-BTrees.")) @@ -507,8 +486,8 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t -(deserialize key :sc (get-con (cursor-btree cursor))) -(deserialize val :sc (get-con (cursor-btree cursor))) + (deserialize key :sc (get-con (cursor-btree cursor))) + (deserialize val :sc (get-con (cursor-btree cursor))) (progn (buffer-read-int pkey) (deserialize pkey)))) (setf (cursor-initialized-p cursor) nil))))) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 20:06:03 1.2 @@ -38,14 +38,14 @@ ;; Backend Registry Support ;; -(eval-when (:compile-toplevel :load-toplevel) - (register-backend-con-init :bdb 'bdb-test-and-construct)) - (defun bdb-test-and-construct (spec) (if (bdb-store-spec-p spec) - (open-store-bdb spec) + (make-instance 'bdb-store-controller :spec spec) (error (format nil "uninterpretable spec specifier: ~A" spec)))) +(eval-when (:compile-toplevel :load-toplevel) + (register-backend-con-init :bdb 'bdb-test-and-construct)) + (defun bdb-store-spec-p (spec) (and (eq (first spec) :bdb) (typecase (second spec) @@ -53,13 +53,6 @@ (string t) (otherwise nil)))) -(defmethod next-oid ((sc bdb-store-controller)) - "Get the next OID." - (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 bdb-store-controller) &key (recover t) (recover-fatal nil) (thread t)) @@ -144,12 +137,12 @@ ;; Delete connection spec so object ops on cached db info fail (remhash (controller-spec *store-controller*) *dbconnection-spec*)) -(defun open-store-bdb (spec &key (recover nil) (recover-fatal nil) (thread t)) - "Conveniently open a store controller." - (setq *store-controller* - (make-instance 'bdb-store-controller :spec spec)) - (open-controller *store-controller* :recover recover - :recover-fatal recover-fatal :thread thread)) + +(defmethod next-oid ((sc bdb-store-controller)) + "Get the next OID." + (declare (type bdb-store-controller sc)) + (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ + :auto-commit t :txn-nosync t)) ;; --- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 17:25:53 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/02/19 20:06:03 1.3 @@ -78,7 +78,7 @@ (uffi:load-foreign-library (merge-pathnames (make-pathname :name "libsleepycat" :type *c-library-extension*) - (merge-pathnames (make-pathname :directory "src/db-bdb") + (merge-pathnames "src/db-bdb/" (asdf:component-pathname (asdf:find-system 'elephant)))) :module "libsleepycat") (error "Couldn't load src/db-bdb/libsleepycat.~A!" elephant-memutil::*c-library-extension*)) From ieslick at common-lisp.net Sun Feb 19 20:06:03 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 14:06:03 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060219200603.D8CA67000E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv14267/src/db-clsql Modified Files: sql-collections.lisp sql-controller.lisp Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 16:22:40 1.2 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 20:06:03 1.3 @@ -19,11 +19,6 @@ (in-package "ELEPHANT-CLSQL") -(defclass sql-btree-index (btree-index sql-btree) - () - (:metaclass persistent-metaclass) - (:documentation "A SQL-based BTree supports secondary indices.")) - (defmethod get-value (key (bt sql-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3))) @@ -234,6 +229,7 @@ (progn (multiple-value-bind (h k v) (cursor-next cursor) + (declare (ignore h v)) (when (my-generic-less-than key k) (setf vs t)) ) @@ -285,7 +281,8 @@ "Put by cursor. Not particularly useful since primaries don't support duplicates. Currently doesn't properly move the cursor." - (declare (optimize (speed 3))) + (declare (optimize (speed 3)) + (ignore key value key-specified-p)) (error "Puts on sql-cursors are not yet implemented, because I can't get them to work on BDB cursors!")) ;; Secondary Cursors @@ -451,7 +448,7 @@ (remove-kv p (primary (cursor-btree cursor))) (let ((ck (:sql-crsr-ck cursor)) (dp (:dp-nmbr cursor))) - + (declare (ignorable dp)) (cursor-next cursor) ;; Now that we point to the old slot, remove the old slot from the array... (setf (:sql-crsr-ks cursor) @@ -466,20 +463,20 @@ (defmethod cursor-get-both ((cursor sql-secondary-cursor) key value) "cursor-get-both not implemented for secondary indices. Use cursor-pget-both." - (declare (ignore cursor key value)) + (declare (ignore key value)) (error "cursor-get-both not implemented on secondary indices. Use cursor-pget-both.")) (defmethod cursor-get-both-range ((cursor sql-secondary-cursor) key value) "cursor-get-both-range not implemented for secondary indices. Use cursor-pget-both-range." - (declare (ignore cursor key value)) + (declare (ignore key value)) (error "cursor-get-both-range not implemented on secondary indices. Use cursor-pget-both-range.")) (defmethod cursor-put ((cursor sql-secondary-cursor) value &rest rest) "Puts are forbidden on secondary indices. Try adding to the primary." - (declare (ignore rest value cursor)) + (declare (ignore rest value)) (error "Puts are forbidden on secondary indices. Try adding to the primary.")) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 16:22:40 1.3 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 20:06:03 1.4 @@ -26,91 +26,75 @@ ;;; other clsql packages would have to be added for ;;; non-postgresql databases, see the CL-SQL documentation -(eval-when (:compile-toplevel :load-toplevel) - ;; NOTE: Integrate into load process - ;; Probably must be customized ... see documentation on installin postgres. - (defvar *clsql-foreign-lib-path* "/usr/lib") - (clsql:push-library-path *clsql-foreign-lib-path*) - (clsql:push-library-path *elephant-lib-path*)) +;; (eval-when (:compile-toplevel :load-toplevel) +;; ;; NOTE: Integrate into load process +;; ;; Probably must be customized ... see documentation on installin postgres. +;; (defvar *clsql-foreign-lib-path* "/usr/lib") +;; (clsql:push-library-path *clsql-foreign-lib-path*) +;; (clsql:push-library-path *elephant-lib-path*)) + + +;; +;; The main SQL Controller Class +;; + (defclass sql-store-controller (store-controller) - ((dbonnection-spec :type list :accessor :dbcn-spc :initarg :dbconnection-spec - ;; for postgres, this is host, db, user, password - ;; If you can't get the lisp system to connect with - ;; this default information, make sure you can connect - ;; to the database called "test" under the user postgress - ;; with the psql console first. Then study the authorization - ;; and configuration files. - :initform '("localhost.localdomain" "test" "postgres" "")) - (db :accessor controller-db :initarg :db :initform nil)) + ((db :accessor controller-db :initarg :db :initform nil)) (:documentation "Class of objects responsible for the book-keeping of holding DB handles, the cache, table creation, counters, locks, the root (for garbage collection,) et cetera. This is the Postgresql-specific subclass of store-controller.")) -(defmethod build-btree ((sc sql-store-controller)) - (make-sql-btree sc)) +(eval-when (:compile-toplevel :load-toplevel) + (register-backend-con-init :clsql 'sql-test-and-construct)) + +(defun sql-test-and-construct (spec) + "Entry function for making SQL backend controllers" + (if (sql-store-spec-p spec) + (make-instance 'sql-store-controller + :spec (if spec spec + '("localhost.localdomain" "test" "postgres" ""))) + (error (format nil "uninterpretable path/spec specifier: ~A" spec)))) (defun sql-store-spec-p (spec) (and (listp spec) (eq (first spec) :clsql))) -(defun sql-test-and-construct (spec) - (if (sql-store-spec-p spec) - (open-store-sql spec) - nil)) - -(eval-when (:load-toplevel) - (register-backend-con-init :clsql 'sql-test-and-construct)) +;; +;; Controller Indices +;; -(defmacro with-open-store-sql ((spec) &body body) - "Executes the body with an open controller, -unconditionally closing the controller on exit." - `(let ((*store-controller* - (make-instance 'sql-store-controller :dbconnection-spec ,spec))) - (declare (special *store-controller*)) - (open-controller *store-controller*) - (unwind-protect - (progn , at body) - (close-controller *store-controller*)))) - -(defun open-store-sql (spec &key (recover nil) - (recover-fatal nil) (thread t)) - "Conveniently open a store controller." - (setq *store-controller* - (if (sql-store-spec-p spec) - (make-instance 'sql-store-controller :dbconnection-spec spec) - (error (format nil "uninterpretable path/spec specifier: ~A" spec))) - ) - (open-controller *store-controller* :recover recover - :recover-fatal recover-fatal :thread thread) - ) ;; When you build one of these, you have to put in the connection spec. -(defclass sql-btree (btree) - ( - ) +(defclass sql-btree (btree) () (:documentation "A SQL implementation of a BTree")) +(defmethod build-btree ((sc sql-store-controller)) + (make-instance 'sql-btree :sc sc) + ) + (defmethod get-value (key (bt sql-btree)) (let* ((sc (get-con bt)) (con (controller-db sc))) - (sql-get-from-clcn (oid bt) key sc con))) - + (sql-get-from-clcn (oid bt) key sc con) + ) + ) -(defmethod existsp (key (bt sql-btree)) +(defmethod (setf get-value) (value key (bt sql-btree)) (let* ((sc (get-con bt)) (con (controller-db sc))) - (sql-from-clcn-existsp (oid bt) key con) + (sql-add-to-clcn (oid bt) key value sc con) ) ) -(defmethod (setf get-value) (value key (bt sql-btree)) +(defmethod existsp (key (bt sql-btree)) (let* ((sc (get-con bt)) (con (controller-db sc))) - (sql-add-to-clcn (oid bt) key value sc con) + (sql-from-clcn-existsp (oid bt) key con) ) ) + (defmethod remove-kv (key (bt sql-btree)) (let* ((sc (get-con bt)) (con (controller-db sc))) @@ -125,40 +109,47 @@ ;; directly into the class above. I am not sure how best to ;; handle this problem. (defclass sql-indexed-btree (indexed-btree sql-btree ) - ( - (indices :accessor indices :initform (make-hash-table) - ) + ((indices :accessor indices :initform (make-hash-table)) (indices-cache :accessor indices-cache :initform (make-hash-table) - :transient t) - ) + :transient t)) (:metaclass persistent-metaclass) (:documentation "A SQL-based BTree that supports secondary indices.")) +(defmethod shared-initialize :after ((instance sql-indexed-btree) slot-names + &rest rest) + (declare (ignore slot-names rest)) + (setf (indices-cache instance) (indices instance))) + (defmethod build-indexed-btree ((sc sql-store-controller)) - (let ((bt (make-instance 'sql-indexed-btree :sc sc))) - (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) - bt - )) + (make-instance 'sql-indexed-btree :sc sc)) (defmethod build-btree-index ((sc sql-store-controller) &key primary key-form) - (let ((bt (make-instance 'sql-btree-index :primary primary :key-form key-form :sc sc))) - (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) - bt - )) + (make-instance 'sql-btree-index :primary primary :key-form key-form :sc sc)) -;; I need some way to get to the store-controller here... -;; I could be the store controller in the hash table, that's probably -;; the simplest thing to do.. +;; ISE NOTE: Much of the index management functionality is common between +;; bdb and sql - we could lift this along with indices and indices-cache +;; up to the main elephant code base and introduce a new update-index +;; generic function to handle the backend specific method for updating +(defmethod map-indices (fn (bt sql-indexed-btree)) + (maphash fn (indices-cache bt))) + +(defmethod get-index ((bt sql-indexed-btree) index-name) + (gethash index-name (indices-cache bt))) + +(defmethod remove-index ((bt sql-indexed-btree) index-name) + (remhash index-name (indices-cache bt)) + (let ((indices (indices bt))) + (remhash index-name indices) + (setf (indices bt) indices))) + (defmethod add-index ((bt sql-indexed-btree) &key index-name key-form populate) (let* ((sc (get-con bt)) - (con (controller-db sc))) + (con (controller-db sc))) (if (and (not (null index-name)) (symbolp index-name) (or (symbolp key-form) (listp key-form))) (let ((indices (indices bt)) - (index (make-instance 'sql-btree-index :primary bt - :key-form key-form - :sc sc))) + (index (build-btree-index sc :primary bt :key-form key-form))) (setf (gethash index-name (indices-cache bt)) index) (setf (gethash index-name indices) index) (setf (indices bt) indices) @@ -190,6 +181,7 @@ (with-transaction (:store-controller sc) (maphash #'(lambda (k index) + (declare (ignore k)) (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? @@ -216,6 +208,7 @@ (let ((indices (indices-cache bt))) (maphash #'(lambda (k index) + (declare (ignore k)) (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? @@ -237,7 +230,6 @@ value)))) - (defclass sql-btree-index (btree-index sql-btree) () (:metaclass persistent-metaclass) @@ -290,8 +282,9 @@ ;; apparently in postgres this is failing pretty awfully because ;; sequence-exists-p return nil and then we get an error that the sequence exists! ;; (unless (sequence-exists-p [persistent_seq]) - (clsql::create-sequence [persistent_seq] - :database con) + (clsql::create-sequence [persistent_seq] :database con) + ;; Leave room for root and class-root + (clsql::set-sequence-position [persistent_seq] 2 :database con) ;;) ;; (unless (index-exists-p [idx_clctn_id]) (clsql::create-index [idx_clctn_id] :on [keyvalue] @@ -311,16 +304,16 @@ ;;) ) - (defmethod open-controller ((sc sql-store-controller) ;; At present these three have no meaning &key (recover nil) (recover-fatal nil) (thread t)) + (declare (ignore recover recover-fatal thread)) (the sql-store-controller - (let* ((dbtype (car (second (:dbcn-spc sc)))) - (con (clsql:connect (cdr (second (:dbcn-spc sc))) + (let* ((dbtype (car (second (controller-spec sc)))) + (con (clsql:connect (cdr (second (controller-spec sc))) ;; WARNING: This line of code forces us to use postgresql. ;; If this were parametrized upwards we could concievably try ;; other backends. @@ -328,7 +321,6 @@ ;; DNK :postgresql ;; :database-type :postgresql :if-exists :old))) - (setf (gethash (:dbcn-spc sc) *dbconnection-spec*) sc) (setf (slot-value sc 'db) con) ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it.. @@ -336,32 +328,22 @@ ;; can put it in a function.... (unless (keyvalue-table-exists con) (create-keyvalue-table con)) - (setf (slot-value sc 'root) (build-btree sc)) - (setf (slot-value sc 'class-root) (build-indexed-btree sc)) - ;; Actaully, it would seem here that we must further set the oid - ;; of the root tree to 0 to ensure that we read the correct thing - ;; when we next opent he controller... - (setf (oid (slot-value sc 'root)) 0) + ;; These should get oid 0 and 1 respectively + (setf (slot-value sc 'root) (make-instance 'sql-btree :sc sc :from-oid 0)) + (setf (slot-value sc 'class-root) (make-instance 'sql-indexed-btree :sc sc :from-oid 1)) sc) ) ) -(defun make-sql-btree (sc) - (let ((bt (make-instance 'sql-btree :sc sc))) - (setf (:dbcn-spc-pst bt) (:dbcn-spc sc)) - bt) - ) - (defmethod close-controller ((sc sql-store-controller)) (when (slot-value sc 'db) - ;; close the conneciton + ;; close the connection ;; (actually clsql has pooling and other complications, I am not sure ;; that this is complete.) (clsql:disconnect :database (controller-db sc)) (setf (slot-value sc 'root) nil) )) - ;; Because this is part of the public ;; interface that I'm tied to, it has to accept a store-controller... (defmethod next-oid ((sc sql-store-controller )) @@ -370,7 +352,6 @@ :database con)) ) - ;; if add-to-root is a method, then we can make it class dependent... ;; otherwise we have to change the original code. There is ;; almost no way to implement this without either changing the existing @@ -379,15 +360,14 @@ ;; a proper method myself, but I will give it a name so it doesn't ;; conflict with 'add-to-root. 'add-to-root can remain a convenience symbol, ;; that will end up calling this routine! -(defmethod sql-add-to-root (key value (pgsc sql-store-controller ) con) +(defun sql-add-to-root (key value pgsc con) (sql-add-to-clcn 0 key value pgsc con) ) -;;(defmethod sql-add-to-root (key value dbcon) -;; (sql-add-to-clcn 0 key value sc dbcon) -;; ) -(defmethod sql-add-to-clcn ((clcn integer) key value sc con +(defun sql-add-to-clcn (clcn key value sc con &key (insert-only nil)) + (declare (ignore sc)) + (assert (integerp clcn)) (let ( (vbs (serialize-to-base64-string value)) @@ -411,9 +391,9 @@ ) - -(defmethod sql-get-from-root (key sc con) - (sql-get-from-clcn 0 key sc con)) +(defun sql-get-from-root (key sc con) + (sql-get-from-clcn 0 key sc con) + ) ;; This is a major difference betwen SQL and BDB: ;; BDB plans to give you one value and let you iterate, but @@ -431,10 +411,13 @@ ;; To do that I have to read in all of the values and deserialized them ;; This could be a good reason to keep the oids out, and separte, in ;; a separate column. -(defmethod sql-get-from-clcn ((clcn integer) key sc con) +(defun sql-get-from-clcn (clcn key sc con) + (assert (integerp clcn)) (sql-get-from-clcn-nth clcn key sc con 0) ) -(defmethod sql-get-from-clcn-nth ((clcn integer) key sc con (n integer)) + +(defun sql-get-from-clcn-nth (clcn key sc con n) + (assert (and (integerp clcn) (integerp n))) (let* ( (kbs (serialize-to-base64-string key)) @@ -463,7 +446,8 @@ t) (values nil nil)))) -(defmethod sql-get-from-clcn-cnt ((clcn integer) key con) +(defun sql-get-from-clcn-cnt (clcn key con) + (assert (integerp clcn)) (let* ( (kbs (serialize-to-base64-string key)) (tuples @@ -474,7 +458,8 @@ ))) (caar tuples))) -(defmethod sql-dump-clcn ((clcn integer) sc con) +(defun sql-dump-clcn (clcn sc con) + (assert (integerp clcn)) (let* ( (tuples (clsql::select [key] [value] @@ -485,11 +470,12 @@ (mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string q :sc sc)) x)) tuples))) -(defmethod sql-from-root-existsp (key con) +(defun sql-from-root-existsp (key con) (sql-from-clcn-existsp 0 key con) ) -(defmethod sql-from-clcn-existsp ((clcn integer) key con) +(defun sql-from-clcn-existsp (clcn key con) + (assert (integerp clcn)) (let* ( (kbs (with-buffer-streams (out-buf) (serialize-to-base64-string key)) @@ -505,11 +491,14 @@ nil) )) -(defmethod sql-remove-from-root (key sc con) +(defun sql-remove-from-root (key sc con) [53 lines skipped] From ieslick at common-lisp.net Sun Feb 19 20:06:04 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 14:06:04 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060219200604.37D747000E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv14267/src/elephant Modified Files: backend.lisp controller.lisp metaclasses.lisp Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 16:22:43 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 20:06:04 1.3 @@ -41,8 +41,7 @@ #:controller-spec #:controller-root #:controller-class-root - #:root - #:class-root + #:root #:spec #:class-root #:flush-instance-cache ;; Collection generic functions #:build-indexed-btree #:build-btree #:existsp @@ -64,7 +63,6 @@ #:remove-indexed-element-and-adjust #:register-backend-con-init #:lookup-backend-con-init - #:form-slot-key ) (:export ;; Variables @@ -84,8 +82,7 @@ #:controller-spec #:controller-root #:controller-class-root - #:root - #:class-root + #:root #:spec #:class-root #:flush-instance-cache ;; Collection generic functions #:build-indexed-btree #:build-btree #:existsp @@ -107,6 +104,5 @@ #:remove-indexed-element-and-adjust #:register-backend-con-init #:lookup-backend-con-init - #:form-slot-key )) \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 05:13:02 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 20:06:04 1.3 @@ -120,22 +120,6 @@ (progn , at body) (close-controller *store-controller*)))) -;; ISE: 2/17 - Removing this as it's not clear what usage model requires -;; it unless your often closing a controller while keeping -;; the object around. Usage should be to toss a closed -;; controller so you don't end up with two! -;; -;; (defmacro with-open-controller ((&optional (sc '*store-controller*)) -;; &body body) -;; "Executes body with the specified controller open, closing -;; the controller unconditionally on exit." -;; `(unwind-protect -;; (progn -;; (let ((*store-controller* (open-controller ,sc))) -;; (declare (special *store-controller*)) -;; , at body)) -;; (close-controller ,sc))) - ;; ;; COMMON STORE CONTROLLER FUNCTIONALITY ;; --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 20:06:04 1.2 @@ -326,11 +326,6 @@ when (eq (slot-definition-name slot-def) slot-name) do (return slot-def))) -;; This this is not a good way to form a key... -(defun form-slot-key (oid name) - (format nil "~A ~A" oid name) - ) - #+(or cmu sbcl) (defun make-persistent-reader (name) (lambda (instance) From ieslick at common-lisp.net Sun Feb 19 20:06:04 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 19 Feb 2006 14:06:04 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20060219200604.89A0F7000E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory common-lisp:/tmp/cvs-serv14267/src/memutil Modified Files: memutil.lisp Log Message: Includes most SQL fixes - works under SBCL/ACL. Two problems remain in indexing under SQL for both SBCL/ACL --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 17:25:53 1.3 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/02/19 20:06:04 1.4 @@ -71,7 +71,7 @@ (uffi:load-foreign-library (merge-pathnames (make-pathname :name "libmemutil" :type *c-library-extension* ) - (merge-pathnames (make-pathname :directory "src/memutil") + (merge-pathnames "src/memutil/" (asdf:component-pathname (asdf:find-system 'elephant)))) :module "libmemutil") (error "Couldn't load src/memutil/libmemutil.~A in!" *c-library-extension*)) From ieslick at common-lisp.net Mon Feb 20 15:45:36 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 09:45:36 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060220154536.CA4A74C011@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv24854 Modified Files: INSTALL Removed Files: functions.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/INSTALL 2006/02/19 17:25:52 1.15 +++ /project/elephant/cvsroot/elephant/INSTALL 2006/02/20 15:45:36 1.16 @@ -3,25 +3,22 @@ Requirements ------------ -CMUCL 19a, SBCL 0.9.5, OpemMCL 0.14.2, or Allegro CL 6.2. -This version ahs been tested under Linux and SBCL 0.9.5, but -Dan Knapp has also run something very closed under Darwin. -can't personally test Win32 but I've compiled under Visual -Studio .NET and a user has gotten it to work with Visual -Studio 6. A Lispworks version will come if requested. - -ASDF - http://www.cliki.net/asdf - -UFFI 1.4.24+ - http://uffi.b9.com -(I have been testing with UFFI 1.5.4 and I recommend you use that.) - -I've patched src/functions.lisp to support some kinds of -:out arguments. it is backwards-compatible so shouldn't -interfere with your existing work. It is included in -1.4.25+, but just in case you have 1.4.24 I have included -it. - -Sleepycat Berkeley DB 4.3 - http://www.sleepycat.com +Support Lisps: +CMUCL 19a Linux +SBCL 0.9.6/0.9.9 Linux / Mac OSX +Allegro CL 6.2/7.0/8.0 Linux / Mac OSX +OpenMCL 0.14.2 +LispWorks (port in-progress) + +Lisp libraries: +ASDF - http://www.cliki.net/asdf +UFFI 1.5.4+ - http://uffi.b9.com/ + +Backends: +1) Sleepycat Berkeley DB 4.3 - http://www.sleepycat.com +2) CLSQL - http://clsql.b9.com/ + And an appropriate SQL installation. + Tested with SQlite3 and Postgresql so far A C compiler, probably gcc or Visual Studio. Presumably you have this if you installed Sleepycat. @@ -55,21 +52,14 @@ /usr/local/share/common-lisp/elephant-0.3/ - -1) Install UFFI. If you're using 1.4.24 replace - - path-to-uffi/src/functions.lisp - - with the provided file. - - -2) Install ASDF. +1) Install ASDF. Ensure that you have a recent version of ASDF installed as the load process now depends upon it. +2) Install UFFI. -3) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. +3) Install a backend: Either Berkeley DB 4.3, PostGresql, or SQLite 3. ------- SQL From ieslick at common-lisp.net Mon Feb 20 15:45:37 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 09:45:37 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060220154537.226174E003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv24854/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/19 20:06:03 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/20 15:45:37 1.3 @@ -135,7 +135,7 @@ (setf (controller-environment sc) nil) nil) ;; Delete connection spec so object ops on cached db info fail - (remhash (controller-spec *store-controller*) *dbconnection-spec*)) + (remhash (controller-spec sc) *dbconnection-spec*)) (defmethod next-oid ((sc bdb-store-controller)) From ieslick at common-lisp.net Mon Feb 20 15:45:37 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 09:45:37 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060220154537.6734B4E003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv24854/src/db-clsql Modified Files: sql-controller.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/19 20:06:03 1.4 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/20 15:45:37 1.5 @@ -314,20 +314,14 @@ (the sql-store-controller (let* ((dbtype (car (second (controller-spec sc)))) (con (clsql:connect (cdr (second (controller-spec sc))) -;; WARNING: This line of code forces us to use postgresql. -;; If this were parametrized upwards we could concievably try -;; other backends. :database-type dbtype -;; DNK :postgresql -;; :database-type :postgresql :if-exists :old))) (setf (slot-value sc 'db) con) ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it.. - ;; This kind of thing is typically database-specific, but at least we - ;; can put it in a function.... (unless (keyvalue-table-exists con) - (create-keyvalue-table con)) + (with-transaction (:store-controller sc) + (create-keyvalue-table con))) ;; These should get oid 0 and 1 respectively (setf (slot-value sc 'root) (make-instance 'sql-btree :sc sc :from-oid 0)) (setf (slot-value sc 'class-root) (make-instance 'sql-indexed-btree :sc sc :from-oid 1)) From ieslick at common-lisp.net Mon Feb 20 15:45:38 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 09:45:38 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060220154538.34CD74F00C@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv24854/src/elephant Modified Files: backend.lisp collections.lisp controller.lisp migrate.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/19 20:06:04 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/02/20 15:45:37 1.4 @@ -36,6 +36,7 @@ #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers + #:store-controller #:open-controller #:close-controller #:controller-spec @@ -44,12 +45,15 @@ #:root #:spec #:class-root #:flush-instance-cache ;; Collection generic functions + #:btree #:btree-index #:indexed-btree #:build-indexed-btree #:build-btree #:existsp + #:map-indices ;; Serialization #:deserialize #:serialize #:deserialize-from-base64-string #:serialize-to-base64-string ;; Cursor accessors + #:cursor #:cursor-btree #:cursor-oid #:cursor-initialized-p @@ -77,6 +81,7 @@ #:persistent-slot-boundp #:persistent-slot-makunbound ;; Controllers + #:store-controller #:open-controller #:close-controller #:controller-spec @@ -85,12 +90,15 @@ #:root #:spec #:class-root #:flush-instance-cache ;; Collection generic functions + #:btree #:btree-index #:indexed-btree #:build-indexed-btree #:build-btree #:existsp + #:map-indices ;; Serialization #:deserialize #:serialize #:deserialize-from-base64-string #:serialize-to-base64-string ;; Cursor accessors + #:cursor #:cursor-btree #:cursor-oid #:cursor-initialized-p --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 15:45:37 1.2 @@ -324,13 +324,13 @@ (progn , at body) (cursor-close ,var)))) -(defun map-btree (fn bt) +(defun map-btree (fn btree) "Like maphash." - (with-btree-cursor (curs bt) + (with-btree-cursor (curs btree) (loop (multiple-value-bind (more k v) (cursor-next curs) (unless more (return nil)) - (funcall fn k v))))) + (funcall fn k v))))) (defun dump-btree (bt) (format t "DUMP ~A~%" bt) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/19 20:06:04 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 15:45:37 1.4 @@ -102,12 +102,12 @@ (open-controller *store-controller* :recover recover :recover-fatal recover-fatal :thread thread)) -(defun close-store () +(defun close-store (&optional sc) "Conveniently close the store controller." (declare (special *store-controller*)) - (if *store-controller* + (if (or sc *store-controller*) (progn - (close-controller *store-controller*) + (close-controller (or sc *store-controller*)) (setf *store-controller* nil)))) (defmacro with-open-store ((spec) &body body) --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/20 15:45:37 1.2 @@ -2,8 +2,8 @@ ;;; ;;; migrate.lisp -- Migrate between repositories ;;; -;;; Initial version 8/26/2004 by Ben Lee -;;; +;;; New Version 2/19/2006 by Ian Eslick +;;; ;;; ;;; part of ;;; @@ -20,79 +20,233 @@ (in-package "ELEPHANT") ;; -;; MULTI-STORE OPERATION API +;; The generic function Migrate provides an interface to moving objects between +;; repositories +;; + +;; NOTES AND LIMITATIONS: +;; - Migrate currently will not handle circular list objects +;; - Migrate does not support arrays with nested persistent objects +;; - Migrate assumes that after migration, indexed classes belong to the +;; target store. +;; - In general, migration is a one-time activity and afterwards (or after +;; a validation test) the source store should be closed. Any failures +;; in migration should then be easy to catch +;; - Each call to migration will be good about keeping track of already +;; copied objects to avoid duplication. Duplication _shouldn't_ screw +;; up the semantics, just cost storage but is to be avoided. However +;; this information is not saved between calls and there's no other +;; way to do comparisons between objects across stores (different oid +;; namespaces) so user beware of the pitfalls of partial migrations... ;; +;; CUSTOMIZE MIGRATION: +;; - To customize migration overload a version of migrate to specialize on +;; your specific persistent class type. +;; +;; (defmethod migrate ((dst store-controller) (src my-class))) +;; +;; In the body of this method you can call (call-next-method) +;; to get a destination repository object with all the slots copied over +;; to the target repository which you can then overwrite. To avoid the +;; slot copying, bind the dynamic variable *inhibit-slot-writes* in your +;; user method using (with-inhibited-slot-copy () ...) a convenience macro +;; + (defgeneric migrate (dst src) (:documentation "Migrate an object from the src object, collection or controller - to the dst controller")) + to the dst controller. Returns a copy of the object in the new + store so you can drop it into a parent object or the root of + the dst controller")) -(defmethod migrate ((dst store-controller) (src t)) - (error "Cannot migrate object ~A of type ~A" dst (type-of dst))) +;; DEFAULT HANDLERS (defmethod migrate ((dst t) (src t)) (error "Cannot migrate ~A of type ~A to destination of type ~A" src (type-of src) (type-of dst))) +(defmethod migrate ((dst store-controller) (src t)) + "Default: standard objects are automatically migrated" + src) + +;; Avoiding Duplication Semantics + +(defvar *migrate-copied-oids* (make-hash-table)) +(defvar *migrating* nil) + +;; ERROR CHECKING + +(defmethod migrate :around ((dst store-controller) (src t)) + "This method ensures that we wipe our duplication detection + around any top level call to migrate" + (if *migrating* + (call-next-method) + (let ((*migrating* t)) + (declare (special *migrating*)) + (reset-migrate-duplicate-detection) + (call-next-method)))) + +(defmethod migrate :before ((dst store-controller) (src persistent)) + "This provides some sanity checking that we aren't trying to copy + to the same controller. We also need to be careful about deadlocking + our transactions among the two gets/puts. Each leaf migration should + be in its own transaction to avoid too many write locks. " + (let ((dst-spec (controller-spec dst))) + (unless (object-was-copied-p src) + (typecase src + (store-controller (assert (not (equal dst-spec (controller-spec src))))) + (persistent (assert (not (equal dst-spec (:dbcn-spc-pst src))))))))) + +;; WHOLE STORE MIGRATION + (defmethod migrate ((dst store-controller) (src store-controller)) "Perform a wholesale repository migration from the root. - Also a poor man's GC!" - (migrate-btree-contents (controller-root dst) (controller-root src)) - ;; NOTE: we have to migrate class indexes also and update the class objects. - ) + Also acts as a poor man's GC if you copy to another store + of the same type!" + (map-btree (lambda (key value) + (let ((newval (migrate dst value))) + (with-transaction (:store-controller dst :txn-nosync t) + (add-to-root key newval :store-controller dst)))) + (controller-root src)) + (map-btree (lambda (classname classidx) + (declare (ignore classidx)) + (when (find-class classname nil) + (migrate dst (find-class classname)))) + (controller-class-root src)) + dst) + +;; PERSISTENT OBJECTS THAT AREN'T INDICES + +(defvar *inhibit-slot-copy* nil) + +(defmacro with-inhibited-slot-copy ((&key &allow-other-keys) &body body) + `(let ((*inhibit-slot-copy* t)) + (declare (special *inhibit-slot-copy*) + (dynamic-extent *inhibit-slot-copy*)) + , at body)) + +(defmethod migrate ((dst store-controller) (src persistent)) + "Migrate a persistent object and apply a binary (lambda (dst src) ...) + + function to the new object. Users can override migrate by creating + a function that calls the default copy and then does stuff with the + slot values. A dynamic variable: *inhibit-slot-copy* can be bound + in the caller to keep the new object from having it's slots copied" + (let ((class (class-of src))) + (migrate dst class) + ;; Copy or lookup persistent object + (if (object-was-copied-p src) + (retrieve-copied-object src) + (copy-persistent-object dst src)))) + +(defmethod migrate ((dst store-controller) (class persistent-metaclass)) + ;; Migrate classes with indices + (return-from migrate) + (unless (or (not (indexed class)) + (equal (controller-spec dst) + (:dbcn-spc-pst (%index-cache class)))) + (format t "Migrating class~A~%" (class-name class)) + (let ((new-cidx (migrate dst (%index-cache class)))) + (setf (get-value (class-name class) (controller-class-root dst)) new-cidx) + (setf (%index-cache class) new-cidx))) + class) + +(defun reset-migrate-duplicate-detection () + (setf *migrate-copied-oids* (make-hash-table))) + +(defun object-was-copied-p (src) + (and (subtypep (type-of src) 'persistent) + (gethash (oid src) *migrate-copied-oids*))) + +(defun register-copied-object (src dst) + (assert (not (equal (:dbcn-spc-pst src) (:dbcn-spc-pst dst)))) + (setf (gethash (oid src) *migrate-copied-oids*) dst)) + +(defun retrieve-copied-object (src) + (gethash (oid src) *migrate-copied-oids*)) +;; (make-instance (class-of src) +;; :sc dstsc +;; :from-oid (gethash (oid src) *migrate-copied-oids*))) + +(defun copy-persistent-object (dstsc src) + (let ((dst (make-instance (class-of src) :sc dstsc))) + (register-copied-object src dst) + (unless *inhibit-slot-copy* + (copy-persistent-slots dstsc (class-of src) src dst)) + dst)) + +(defun copy-persistent-slots (dstsc class src dst) + "Copy all slots from src to dst - transient and persistent + so we maintain any active data" + (loop for slot-def in (class-slots class) do + (when (slot-boundp-using-class class src slot-def) + (setf (slot-value-using-class class dst slot-def) + (migrate dstsc (slot-value-using-class class src slot-def)))))) + + +;; MIGRATE INDICES (Override normal persistent copies) (defmethod migrate ((dst store-controller) (src btree)) - "Copy a currently persistent object to a new repository." - (let ((newbtree (build-btree dst))) - newbtree)) + "Copy an index and it's contents to the target repository" + (if (object-was-copied-p src) + (retrieve-copied-object src) + (let ((newbtree (build-btree dst))) + (copy-btree-contents dst newbtree src) + (register-copied-object src newbtree) + newbtree))) + +(defmethod migrate ((dst store-controller) (src indexed-btree)) + "Also copy the inverse indices for indexed btrees" + (if (object-was-copied-p src) + (retrieve-copied-object src) + (let ((newbtree (build-indexed-btree dst))) + (copy-btree-contents dst newbtree src) + (map-indices (lambda (name srciidx) + (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t)) + newbtree) + (register-copied-object src newbtree) + newbtree))) -(defun migrate-btree-contents (dst src) +(defmethod copy-btree-contents ((sc store-controller) dst src) (map-btree (lambda (key value) - (setf (get-value key dst) value)) + (let ((newval (migrate sc value))) + (with-transaction (:store-controller sc :txn-nosync t) + (setf (get-value key dst) newval)))) src)) -(defmethod migrate ((dst store-controller) (btree indexed-btree)) - "Copy indexes and then copy contents and update indices" - (let ((newbtree (build-indexed-btree dst))) - (map-indices (lambda (name idx) - (add-index newbtree :index-name name :key-form (key-form idx) :populate nil)) - btree) - (migrate-btree-contents newbtree btree) - newbtree)) - -;; NOTE: These functions should get rolled into migrate GF - -(defun copy-from-key (key src dst) - "Move the object identified by key on the root in the src to the dst." - (let ((v (get-from-root key :store-controller src))) - (if v - (add-to-root key v :store-controller dst) - v))) - -;; 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)) - -;; ;; 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)) - ) - ) + +;; SUPPORT LISP COLLECTIONS TO HANDLE NESTED PERSISTENT OBJECTS +;; CLEANLY + +;; If we don't do this, then a nested persistent object may be +;; of the source store's class and fail to copy slots on a write +;; and we'll silently lose data... + +(defmethod migrate ((dst store-controller) (src hash-table)) + "Copy the hash elements one at a time" + (let ((newhash (make-hash-table + :test (hash-table-test src) + :size (hash-table-size src) + :rehash-size (hash-table-rehash-size src) + :rehash-threshold (hash-table-rehash-threshold src)))) + (maphash (lambda (key value) + (setf (gethash key newhash) (migrate dst value))) + src))) + +(defmethod migrate ((dst store-controller) (src cons)) + "WARNING: This assumes a standard list or tree-of-lists, but doesn't + work for circular lists!" + (cons (migrate dst (car src)) + (migrate dst (cdr src)))) + +(defmethod migrate ((dst store-controller) (src string)) + "Strings are fine to copy as is" + src) + +(defmethod migrate ((dst store-controller) (src array)) + "NOTE: We need to handle arrays that might contain persistent objects!" + (warn "Arrays with persistent objects will fail migration!") + src) + From ieslick at common-lisp.net Mon Feb 20 15:45:38 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 09:45:38 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060220154538.870414F00C@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv24854/tests Modified Files: elephant-tests.lisp testmigration.lisp Log Message: Migration implementation; indexed class migration is broken but all else passes basic tests --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/19 17:25:53 1.15 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/20 15:45:38 1.16 @@ -129,12 +129,17 @@ (*test-spec-secondary* spec2)) (declare (special *test-spec-primary* *test-spec-secondary*)) (print (do-test 'remove-element)) - (print (do-test 'migrate1)) - (print (do-test 'migrate2)) - (print (do-test 'migrate3)) - (print (do-test 'migrate4)) - (print (do-test 'migrate5)))) + (print (do-test 'migrate-basic)) + (print (do-test 'migrate-btree)) + (print (do-test 'migrate-idx-btree)) + (print (do-test 'migrate-pclass)))) +;; (print (do-test 'migrate-ipclass)))) +(defun do-migration-test-spec (test spec1 spec2) + (let ((*test-spec-primary* spec1) + (*test-spec-secondary* spec2)) + (declare (special *test-spec-primary* *test-spec-secondary*)) + (print (do-test test)))) ;; --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/19 04:53:02 1.7 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 15:45:38 1.8 @@ -13,6 +13,14 @@ (in-package :ele-tests) +;; TEST TODO: +;; - inhibited slot copy & user overloading of migrate methodss +;; - proper use of clearing the tracking of copies +;; (oids not same over two copys of same object) +;; - whole repository migration (write comparison method to sanity check) +;; - transient slot migration is correct (online transfer of state to new repos) +;; - + (deftest remove-element (if (or (not (boundp '*test-spec-secondary*)) (null *test-spec-secondary*)) @@ -27,7 +35,8 @@ (equal (length a) (length ans))))) t) -(deftest migrate1 +;; Simple root element copy +(deftest migrate-basic (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn @@ -41,10 +50,10 @@ (sc2 nil)) (unwind-protect (progn - (setf sc1 (open-store *test-spec-primary*)) - (setf sc2 (open-store *test-spec-secondary*)) + (setf sc1 (open-store *test-spec-primary* :recover t)) + (setf sc2 (open-store *test-spec-secondary* :recover t)) (add-to-root "x" "y" :store-controller sc1) - (copy-from-key "x" sc1 sc2) + (migrate sc2 sc1) (setf rv (equal (get-from-root "x" :store-controller sc1) (get-from-root "x" :store-controller sc2)))) (progn @@ -55,8 +64,8 @@ rv)) t) - -(deftest migrate2 +;; Simple test of a btree +(deftest migrate-btree (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn @@ -70,7 +79,7 @@ (let ((sc1 (open-store *test-spec-primary*)) (sc2 (open-store *test-spec-secondary*))) - (let ((ibt (build-btree sc1))) + (let ((ibt (make-btree sc1))) (loop for i from 0 to 10 do (setf (get-value i ibt) (* i i))) @@ -81,8 +90,8 @@ (setq *auto-commit* *prev-commit*))))) nil) - -(deftest migrate3 +;; Simple test of indexed btrees +(deftest migrate-idx-btree (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn @@ -96,23 +105,21 @@ (let ((sc1 (open-store *test-spec-primary*)) (sc2 (open-store *test-spec-secondary*)) ) - (let* ((ibt (build-indexed-btree sc1))) - (let ( - (index + (let* ((ibt (make-indexed-btree sc1))) + (let ((index (add-index ibt :index-name 'crunch :key-form 'crunch - :populate t)) - ) + :populate t))) (loop for i from 0 to 10 do (setf (get-value i ibt) (* i i))) (let* ((mig (migrate sc2 ibt)) - (nindex (gethash 'crunch (indices ibt)))) + (nindex (get-index ibt 'crunch))) (loop for i from 0 to 10 do (if (not (equal (get-value i index) - (get-value i nindex) + (get-value i nindex) )) (progn (format t "YIKES ~A ~%" i) @@ -126,79 +133,72 @@ )) t) - -(deftest migrate4 +;; Simple test of persistent classes +(deftest migrate-pclass (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn (format t "~%Single store mode: ignoring") t) - (finishes - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil)) - (unwind-protect - (let* ( - (sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*)) - ) - (let* ((ibt (build-indexed-btree sc1))) - (let ( - (index - (add-index ibt :index-name 'crunch :key-form 'crunch - :populate t)) - (x 0) - ) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) - ))) - (progn - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))) - ))) + (let ((*prev-commit* *auto-commit*)) + (unwind-protect + (prog2 + (setq *auto-commit* t) + (let ( + (sc1 (open-store *test-spec-primary*)) + (sc2 (open-store *test-spec-secondary*))) + (let* ((f1 (make-instance 'pfoo :sc sc1)) + (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) + (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) + ) + (let ((fm1 (migrate sc2 f1)) + (fm2 (migrate sc2 f2)) + (bm1 (migrate sc2 b1))) + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 bm1) (slot2 b1))) + )))) + (setq *auto-commit* *prev-commit*)))) t) -(deftest migrate5 +(defpclass ipfoo () + ((slot1 :accessor slot1 :initarg :slot1 :index t))) + +;; Simple test of persistent classes with indexed slots +(deftest migrate-ipclass (if (or (not (boundp '*test-spec-secondary*) ) (null *test-spec-secondary*)) (progn (format t "~%Single store mode: ignoring") t) (let ((*prev-commit* *auto-commit*)) - (prog2 - (setq *auto-commit* t) - (let ( - (sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*))) - (let* ((f1 (make-instance 'pfoo :sc sc1)) - (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) - (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) - ) - (let ((fm1 - (migrate ;; (ele::migraten-pobj - sc2 f1 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) - (fm2 - (migrate ;; (ele::migraten-pobj - sc2 f2 - #'(lambda (dst src) - (if (slot-boundp src 'slot1) - (setf (slot1 dst) (slot1 src)))))) - (bm1 (migrate ;; (ele::migraten-pobj - sc2 b1 - #'(lambda (dst src) - (if (slot-boundp src 'slot2) - (setf (slot2 dst) (slot2 src)))))) - ) - (and - (and (not (slot-boundp fm1 'slot1)) - (not (slot-boundp f1 'slot1))) -;; (equal (slot1 fm2) (slot1 f2)) -;; (equal (slot2 bm1) (slot2 b1)) - )))) - (setq *auto-commit* *prev-commit*)))) - t) + (unwind-protect + (prog2 + (setq *auto-commit* t) + (let ((sc1 (open-store *test-spec-primary*)) + (sc2 (open-store *test-spec-secondary*))) + ;; ensure class index is initialized in sc1 + (find-class-index 'ipfoo :sc sc1) + (let* ((f1 (make-instance 'ipfoo :sc sc1)) + (f2 (make-instance 'ipfoo :slot1 10)) + (f3 (make-instance 'ipfoo :slot1 20))) + (format t "Made instances") + (let ((fm1 (migrate sc2 f1)) + (fm2 (migrate sc2 f2)) + (fm3 (migrate sc2 f3))) + (format t "Migrated instances") + (values + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 fm3) (slot2 f3))) + (length (get-instances-by-class 'ipfoo))) + )))) + (setq *auto-commit* *prev-commit*)))) + t 2 ) + + + From ieslick at common-lisp.net Mon Feb 20 21:19:41 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 15:19:41 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-acache Message-ID: <20060220211941.86CA27800E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-acache In directory common-lisp:/tmp/cvs-serv10513/db-acache Log Message: Directory /project/elephant/cvsroot/elephant/src/db-acache added to the repository From ieslick at common-lisp.net Mon Feb 20 21:21:40 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 15:21:40 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060220212140.E80E72A032@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv10634 Modified Files: TODO Added Files: ele-acache.asd Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/TODO 2006/02/19 20:06:03 1.14 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/20 21:21:40 1.15 @@ -6,15 +6,16 @@ 0.6.0 - Adding default class/slot indexing - Finish indexing tests (Ian) +- Finish migration (Ian) - Documentation update (Robert) -* Make sure library path push happens in build - process and not sql-controller... -* Finish CLSQL debug -* Finish migration port and tests -? Make elephant thread bound variables dynamic and modifiable by backends +- Finish CLSQL backend debug (Robert) 0.6.1 - performance, safety and portability +Multi-threading operation: +- Make elephant thread bound variables dynamic and modifiable by backends +- Verify that operations such as indexing are thread safe + Stability: - Think about dynamic vs. object based store & transaction resolution? - Error checking when mixed --- /project/elephant/cvsroot/elephant/ele-acache.asd 2006/02/20 21:21:40 NONE +++ /project/elephant/cvsroot/elephant/ele-acache.asd 2006/02/20 21:21:40 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-acache.asd -- ASDF file for allegrocache backend ;;; ;;; Initial version 2/18/2006 by Ian Eslick ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defsystem ele-acache :name "elephant" :author "Ben Lee " :version "0.6.0" :maintainer "Ben Lee " :licence "LLGPL" :description "Allegro cache backend for elephant" :components ((:module :src :components ((:module :db-acache :components ((:file "package") (:file "acache-controller") (:file "acache-transactions") (:file "acache-collections")) :serial t)))) :depends-on (:elephant)) From ieslick at common-lisp.net Mon Feb 20 21:21:41 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 15:21:41 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-acache Message-ID: <20060220212141.429E52A032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-acache In directory common-lisp:/tmp/cvs-serv10634/src/db-acache Added Files: README acache-collections.lisp acache-controller.lisp acache-transactions.lisp package.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/src/db-acache/README 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/README 2006/02/20 21:21:41 1.1 This directory contains a quick and dirty sketch of an allegrocache backend, mostly to test out the new backend abstraction. Too bad we can't use allegroserve directly behind the metaclass protocol...the apis are a little too different for that. --- /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp 2006/02/20 21:21:41 1.1 (in-package :elephant-acache) ;; BTREE (defclass acache-btree (btree) ()) (defmethod build-btree ((sc acache-store-controller)) (make-instance 'acache-btree :sc sc)) (defmethod get-value (key (bt acache-btree)) (map-value (controller-btrees (get-con bt)) (cons (oid bt) key))) (defmethod (setf get-value) (value key (bt acache-btree)) (setf (map-value (controller-btrees (get-con bt)) (cons (oid bt) key)) value)) (defmethod existsp (key (bt acache-btree)) (when (get-value key bt) t)) (defmethod remove-kv (key (bt acache-btree)) (remove-from-map (controller-btrees (get-con bt)) (cons (oid bt) key))) (defmethod map-btree (fn (bt acache-btree)) (map-map fn bt)) ;; ;; Cursors need to have their own model of where they are ;; ;; INDEXED BTREE ;; How to handle add-index? Have to hack it up on btrees just like slot ;; values...which means solving the complex key problem--- /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp 2006/02/20 21:21:41 1.1 (in-package :elephant-acache) (defclass acache-store-controller (store-controller) ((db :accessor controller-db :initform nil) (slots :accessor controller-slots :initform nil) (btrees :accessor controller-btrees :initform nil) (oidrec :accessor controller-oidrec :initform nil))) (defun acache-constructor (spec) (make-instance 'acache-store-controller :spec spec)) (eval-when (:compile-toplevel :load-toplevel) (register-backend-con-init :acache 'acache-constructor)) (defclass oid-record () ((counter :accessor oid-record-counter :initform 0)) (:metaclass db.allegrocache:persistent-class)) (defmethod open-controller ((sc acache-store-controller) &key (recover t) (recover-fatal nil) (thread nil)) (declare (ignore recover thread recover-fatal)) (let ((db (db.allegrocache:open-file-database (second (controller-spec sc)) :if-does-not-exist :create :if-exists :open :use :memory))) (when (not db) (error "Unable to open astore database for ~A" (controller-spec sc))) ;; Main DB ref (setf (controller-db sc) db) ;; Slots and Btree storage (let ((slotmap (retrieve-from-index 'ac-map 'ac-map-name "slots"))) (setf (controller-slots sc) (if slotmap slotmap (make-instance 'db.allegrocache:ac-map :ac-map-name "slots")))) (let ((btreemap (retrieve-from-index 'ac-map 'ac-map-name "btrees"))) (setf (controller-btrees sc) (if btreemap btreemap (make-instance 'db.allegrocache:ac-map :ac-map-name "btrees")))) ;; OIDS (let ((oidrec (doclass (inst (find-class 'oid-record) :db db) (when inst (return inst))))) (setf (controller-oidrec sc) (if oidrec oidrec (make-instance 'oid-record)))) ;; Construct the roots (setf (slot-value sc 'root) (make-instance 'acache-btree :from-oid -1)) (setf (slot-value sc 'class-root) (make-instance 'acache-btree :from-oid -2)) sc)) (defmethod next-oid ((sc acache-store-controller)) (db.allegrocache:with-transaction-restart () (incf (oid-record-counter (controller-oidrec sc))) (commit))) (defmethod close-controller ((sc acache-store-controller)) ;; Ensure deletion of common (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) (db.allegrocache:close-database :db (controller-db sc))) (defmethod connection-is-indeed-open ((sc acache-store-controller)) (db.allegrocache::database-open-p (controller-db sc))) ;; Slot writing ;; This is not thread-safe, but could be a thread-local when we fix that... ;; to avoid extra consing. Is consing less/more expensive than dynamic ;; var lookups? (defvar *index-cons* (cons nil nil)) (defmacro fast-key (oid name) `(rplacd (rplaca *index-cons* ,oid) ,name)) (defmethod persistent-slot-reader ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (multiple-value-bind (val valid?) (map-value (controller-slots sc) (fast-key (oid instance) name)) (if valid? val (error "Slot ~A unbound in ~A" name instance)))) (defmethod persistent-slot-writer ((sc acache-store-controller) value instance name) (declare (optimize (speed 3) (safety 1))) (setf (map-value (controller-slots sc) (fast-key (oid instance) name)) value)) (defmethod persistent-slot-boundp ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (when (map-value (controller-slots sc) (fast-key (oid instance) name)) t)) (defmethod persistent-slot-makunbound ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (remove-from-map (controller-slots sc) (fast-key (oid instance) name))) --- /project/elephant/cvsroot/elephant/src/db-acache/acache-transactions.lisp 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-transactions.lisp 2006/02/20 21:21:41 1.1 (in-package :elephant-acache) (defmethod controller-start-transaction ((sc acache-store-controller) &key parent &allow-other-keys) "Allegrocache has implicit transactions whenever there's a write" (when parent (error "ACache backend does not allow nested transactions...a commit will commit everything since the last commit")) t) (defmethod controller-commit-transaction ((sc acache-store-controller) &key &allow-other-keys) (db.allegrocache:commit :db (controller-db sc))) (defmethod controller-abort-transaction ((sc acache-store-controller) &key &allow-other-keys) (db.allegrocache:rollback :db (controller-db sc))) (defmethod execute-transaction ((sc acache-store-controller) closure &key parent retries &allow-other-keys) (db.allegrocache:with-transaction-restart (:count retries) (funcall closure) (db.allegrocache:commit :db sc)))--- /project/elephant/cvsroot/elephant/src/db-acache/package.lisp 2006/02/20 21:21:41 NONE +++ /project/elephant/cvsroot/elephant/src/db-acache/package.lisp 2006/02/20 21:21:41 1.1 (in-package :cl-user) (eval-when (:load-toplevel :compile-toplevel) (require :acache)) (eval-when (:load-toplevel) (warn "Allegrocache support is incomplete and should be considered as an example only")) (defpackage elephant-acache (:documentation "A low-level UFFI-based interface to Berkeley DB / Sleepycat to implement the elephant front-end framework. Uses the libsleepycat.c wrapper. Partly intended to be usable outside Elephant, but with some magic for Elephant. In general there is a 1-1 mapping from functions here and functions in Sleepycat, so refer to their documentation for details.") (:use common-lisp elephant elephant-backend) (:import-from #:db.allegrocache #:ac-map #:ac-map-name #:doclass #:commit #:retrieve-from-index #:map-map #:map-value #:remove-from-map)) From ieslick at common-lisp.net Mon Feb 20 21:21:41 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 15:21:41 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060220212141.84C472A032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv10634/src/db-bdb Modified Files: bdb-transactions.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/02/20 21:21:41 1.2 @@ -79,7 +79,7 @@ dirty-read degree-2 &allow-other-keys) - (db-transaction-begin (controller-environment sc) + (db-transaction-begin (controller-environment sc) :parent parent :txn-nosync txn-nosync :txn-nowait txn-nowait From ieslick at common-lisp.net Mon Feb 20 21:21:41 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 15:21:41 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060220212141.D4DB92A032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv10634/src/db-clsql Modified Files: sql-controller.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/20 15:45:37 1.5 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/20 21:21:41 1.6 @@ -24,6 +24,15 @@ (in-package "ELEPHANT-CLSQL") +;; ISE NOTE: Putting this here results in users having to +;; modify source code to run which is inadvisable. My strategy +;; is to asdf resolve references to local libraries and require +;; that the user properly install clsql for their chosen SQL +;; backend. If you really want to allow local configuration +;; for SQL then stick it into ele-sql.asd just as we did for +;; BDB in ele-bdb.asd. This note and code should get removed +;; in 0.6.1 if we have a reasonable strategy +;; ;;; other clsql packages would have to be added for ;;; non-postgresql databases, see the CL-SQL documentation ;; (eval-when (:compile-toplevel :load-toplevel) @@ -33,7 +42,6 @@ ;; (clsql:push-library-path *clsql-foreign-lib-path*) ;; (clsql:push-library-path *elephant-lib-path*)) - ;; ;; The main SQL Controller Class ;; From ieslick at common-lisp.net Mon Feb 20 21:21:44 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 15:21:44 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060220212144.9085579012@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv10634/src/elephant Modified Files: collections.lisp controller.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 15:45:37 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/02/20 21:21:42 1.3 @@ -324,8 +324,8 @@ (progn , at body) (cursor-close ,var)))) -(defun map-btree (fn btree) - "Like maphash." +(defmethod map-btree (fn (btree btree)) + "Like maphash. Default implementation - overridable" (with-btree-cursor (curs btree) (loop (multiple-value-bind (more k v) (cursor-next curs) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 15:45:37 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 21:21:44 1.5 @@ -30,9 +30,11 @@ ;; Dynamic tracking of active connections -(defvar *elephant-backends* +(defparameter *elephant-backends* '((:bdb (:ele-bdb)) - (:clsql (:ele-clsql))) + (:clsql (:ele-clsql)) + (:acache (:ele-acache)) + ) "Entries have the form of (backend-type asdf-depends-list") (defvar *elephant-controller-init* (make-hash-table)) @@ -53,20 +55,31 @@ cached? That might be dangerous so for now we error" (declare (ignore sc)) (let ((con (gethash (:dbcn-spc-pst instance) *dbconnection-spec*))) - (cond((not con) - ;; NOTE: Create a new one here & warn instead? - (error "Object's store controller was lost")) - ((and con (connection-is-indeed-open con)) - con) - (t (open-controller con))))) + (cond ((not con) + ;; ISE NOTE: Create a new one here & warn instead? + ;; (get-controller spec) + (error "Object's store controller was lost")) + ;; If it's valid and open + ((and con (connection-is-indeed-open con)) + con) + ;; If the object exists but is closed, reopen + (t (open-controller con))) + con)) (defun get-controller (spec) + "This is used by open-store to fetch or open a controller. + This maintains the dbconnection-spec table so should be + the only point of entry for getting access to controllers + from specs. Get-con is used to validate connections and + reopen if necessary and perhaps these two should be combined + at some point" (let ((cached-sc (gethash spec *dbconnection-spec*))) (if (and cached-sc (connection-is-indeed-open cached-sc)) cached-sc (build-controller spec)))) (defun build-controller (spec) + "Actually construct the controller & load dependencies" (assert (and (consp spec) (symbolp (first spec)))) (load-backend (first spec)) (let ((init (lookup-backend-con-init (first spec)))) From ieslick at common-lisp.net Mon Feb 20 21:21:46 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 20 Feb 2006 15:21:46 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060220212146.9EF842A032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv10634/tests Modified Files: testmigration.lisp Log Message: A quick AllegroCache backend based on the allegrocache map and compound keys - functionality is only partial but the basics work --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 15:45:38 1.8 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 21:21:45 1.9 @@ -175,7 +175,7 @@ t) (let ((*prev-commit* *auto-commit*)) (unwind-protect - (prog2 + (progn (setq *auto-commit* t) (let ((sc1 (open-store *test-spec-primary*)) (sc2 (open-store *test-spec-secondary*))) From ieslick at common-lisp.net Tue Feb 21 19:40:02 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 21 Feb 2006 13:40:02 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-acache Message-ID: <20060221194002.DBCCC78004@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-acache In directory common-lisp:/tmp/cvs-serv12650/src/db-acache Modified Files: README acache-collections.lisp acache-controller.lisp Log Message: Migration tests pass on BDB. Only migrate ipclass failes under SQLite 3 (May be due to other current failures under SQLite 3) Significant improvements in transaction stability, stability with mutiple open stores, bdb processing speed, and various bug fixes turned up by getting these tests to pass. --- /project/elephant/cvsroot/elephant/src/db-acache/README 2006/02/20 21:21:41 1.1 +++ /project/elephant/cvsroot/elephant/src/db-acache/README 2006/02/21 19:40:02 1.2 @@ -1,6 +1,14 @@ - This directory contains a quick and dirty sketch of an allegrocache -backend, mostly to test out the new backend abstraction. Too bad we -can't use allegroserve directly behind the metaclass protocol...the -apis are a little too different for that. +backend, mostly to test out the new backend abstraction. + +Basic btrees work fine but iteration (cursors) are very limited. +I think the best way to go is reverse engineer the db.btree API +and just implement the elephant backend on top of that API. I +may do this at some point, but not today... + +Or better yet, find someone willing to write a btree library in +lisp. John Fedaro said it wasn't a huge amount of work and can +be done with very high performance in all Common Lisp. + +Ian --- /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp 2006/02/20 21:21:41 1.1 +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-collections.lisp 2006/02/21 19:40:02 1.2 @@ -26,11 +26,32 @@ (defmethod map-btree (fn (bt acache-btree)) (map-map fn bt)) + + +;; INDEXED BTREE + +(defclass acache-indexed-btree (indexed-btree acache-btree) + ((indices :accessor indices :initarg :indices :initform (make-hash-table)) + (indices-cache :accessor indices-cache :initarg :indicies-cache :initform nil :transient t)) + (:metaclass persistent-metaclass)) + +(defmethod build-indexed-btree ((sc acache-store-controller)) + (make-instance 'acache-indexed-btree :sc sc)) + +(defclass acache-btree-index (btree-index acache-btree) + () + (:metaclass persistent-metaclass)) + +(defmethod build-btree-index ((sc acache-store-controller) &key primary key-form) + (make-instance 'acache-btree-index :primary primary :key-form :sc sc)) + ;; -;; Cursors need to have their own model of where they are +;; CURSORS ;; -;; INDEXED BTREE +(defclass acache-cursor (cursor) + ()) + +(defmethod make-cursor ((bt acache-btree)) + (make-instance 'acache-cursor)) -;; How to handle add-index? Have to hack it up on btrees just like slot -;; values...which means solving the complex key problem \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp 2006/02/20 21:21:41 1.1 +++ /project/elephant/cvsroot/elephant/src/db-acache/acache-controller.lisp 2006/02/21 19:40:02 1.2 @@ -51,9 +51,7 @@ (defmethod next-oid ((sc acache-store-controller)) - (db.allegrocache:with-transaction-restart () - (incf (oid-record-counter (controller-oidrec sc))) - (commit))) + (incf (oid-record-counter (controller-oidrec sc)))) (defmethod close-controller ((sc acache-store-controller)) ;; Ensure deletion of common From ieslick at common-lisp.net Tue Feb 21 19:40:03 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 21 Feb 2006 13:40:03 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060221194003.2A89578003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv12650/src/db-bdb Modified Files: bdb-collections.lisp Log Message: Migration tests pass on BDB. Only migrate ipclass failes under SQLite 3 (May be due to other current failures under SQLite 3) Significant improvements in transaction stability, stability with mutiple open stores, bdb processing speed, and various bug fixes turned up by getting these tests to pass. --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/19 20:06:03 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/21 19:40:03 1.3 @@ -90,9 +90,6 @@ (defmethod build-indexed-btree ((sc bdb-store-controller)) (make-instance 'bdb-indexed-btree :sc sc)) -(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) - (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) - (defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) (let ((sc (get-con bt))) ;; Setting the value of *store-controller* is unfortunately @@ -209,6 +206,9 @@ (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) +(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) + (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) + (defmethod get-value (key (bt bdb-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3))) From ieslick at common-lisp.net Tue Feb 21 19:40:08 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 21 Feb 2006 13:40:08 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060221194008.69FAF7E008@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv12650/src/elephant Modified Files: classes.lisp classindex.lisp controller.lisp elephant.lisp metaclasses.lisp migrate.lisp Log Message: Migration tests pass on BDB. Only migrate ipclass failes under SQLite 3 (May be due to other current failures under SQLite 3) Significant improvements in transaction stability, stability with mutiple open stores, bdb processing speed, and various bug fixes turned up by getting these tests to pass. --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/21 19:40:03 1.2 @@ -174,7 +174,7 @@ (when (and (indexed class) (not from-oid)) (let ((class-index (find-class-index (class-of instance)))) (when class-index - (with-transaction () + (with-transaction (:store-controller (get-con class-index)) (setf (get-value oid class-index) instance))))) )))) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/21 19:40:03 1.2 @@ -28,7 +28,7 @@ (defgeneric find-inverted-index (persistent-metaclass index-name &key null-on-fail) (:documentation "This method finds an inverted index defined on - the class described by persistent-metaclass.")) + the class described by an instance of persistent-metaclass.")) (defgeneric enable-class-indexing (persistent-metaclass slot-names &rest rest) (:documentation "Enable a class instance index for this object. It's @@ -68,19 +68,20 @@ the dependant indices in synch. Only classes with derived indices need to update on writes to non-indexed slots." (let ((slot-name (slot-definition-name slot-def)) - (oid (oid instance))) + (oid (oid instance)) + (con (get-con instance))) (declare (type fixnum oid)) (if (no-indexing-needed? class instance slot-def oid) - (with-transaction () - (persistent-slot-writer (get-con instance) new-value instance slot-name)) + (with-transaction (:store-controller con) + (persistent-slot-writer con new-value instance slot-name)) (let ((class-idx (find-class-index class)) (*auto-commit* nil)) ;; (format t "Indexing object: ~A oid: ~A~%" instance oid) - (with-transaction () + (with-transaction (:store-controller con) ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement (when (get-value oid class-idx) (remove-kv oid class-idx)) - (persistent-slot-writer (get-con instance) new-value instance slot-name) + (persistent-slot-writer con new-value instance slot-name) (setf (get-value oid class-idx) instance)))))) @@ -164,7 +165,9 @@ (when (controller-class-root sc) (map-btree (lambda (class-name index) (declare (ignore index)) - (setf (%index-cache (find-class class-name)) nil)) + (let ((class (find-class class-name :errorp nil))) + (when class + (setf (%index-cache class) nil)))) (controller-class-root sc)))) ;; ============================= @@ -215,7 +218,7 @@ (remove-class-slot-index class name) (with-transaction (:store-controller sc) (remove-index class-idx name))))) - ;; Drop the class instance index from the class root + ;; Drop the class instance index from the class root (with-transaction (:store-controller sc) (remove-kv (class-name class) (controller-class-root sc))) (setf (%index-cache class) nil) @@ -398,10 +401,9 @@ (when instances (assert (consp instances)) (with-transaction (:store-controller sc) - (let ((class-idx (find-class-index (class-of (first instances))))) - (mapc (lambda (instance) - (remove-kv (oid instance) class-idx)) - instances))))) + (mapc (lambda (instance) + (remove-kv (oid instance) (find-class-index (class-of instance)))) + instances)))) ;; ============================= ;; CLASS / DB SYNCHRONIZATION --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/20 21:21:44 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/02/21 19:40:03 1.6 @@ -33,7 +33,7 @@ (defparameter *elephant-backends* '((:bdb (:ele-bdb)) (:clsql (:ele-clsql)) - (:acache (:ele-acache)) +;; (:acache (:ele-acache)) ) "Entries have the form of (backend-type asdf-depends-list") @@ -96,7 +96,12 @@ (satisfy-asdf-dependencies (second record)))) (defun satisfy-asdf-dependencies (dep-list) - (mapc #'(lambda (dep) (asdf:operate 'asdf:load-op dep)) dep-list)) + (mapc #'(lambda (dep) + ;; Only load the first time, after that it's the + ;; users fault if they edit source code + (unless (asdf::system-registered-p dep) + (asdf:operate 'asdf:load-op dep))) + dep-list)) ;; ================================================ ;; @@ -173,7 +178,7 @@ (let ((obj (get-cache oid (instance-cache sc)))) (if obj obj ;; Should get cached since make-instance calls cache-instance - (make-instance class-name :from-oid oid)))) + (make-instance class-name :from-oid oid :sc sc)))) (defmethod flush-instance-cache ((sc store-controller)) "Reset the instance cache (flush object lookups). Useful --- /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp 2006/02/19 04:53:00 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/elephant.lisp 2006/02/21 19:40:03 1.2 @@ -46,7 +46,7 @@ #:primary #:key-form #:key-fn #:btree-differ - #:migrate + #:migrate #:*inhibit-slot-copy* #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:cursor-close #:cursor-init --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/19 20:06:04 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/21 19:40:03 1.3 @@ -358,14 +358,20 @@ (make-persistent-slot-boundp name))) slot-def) -(defun persistent-slot-names (class) +(defun persistent-slot-defs (class) (let ((slot-definitions (class-slots class))) - (loop for slot-definition in slot-definitions - when (subtypep (type-of slot-definition) 'persistent-effective-slot-definition) - collect (slot-definition-name slot-definition)))) + (loop for slot-def in slot-definitions + when (subtypep (type-of slot-def) 'persistent-effective-slot-definition) + collect slot-def))) -(defun transient-slot-names (class) +(defun transient-slot-defs (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)))) + (loop for slot-def in slot-definitions + unless (persistent-p slot-def) + collect slot-def))) + +(defun persistent-slot-names (class) + (mapcar #'slot-definition-name (persistent-slot-defs class))) + +(defun transient-slot-names (class) + (mapcar #'slot-definition-name (transient-slot-defs class))) \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/20 15:45:37 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/02/21 19:40:06 1.3 @@ -27,17 +27,28 @@ ;; NOTES AND LIMITATIONS: ;; - Migrate currently will not handle circular list objects ;; - Migrate does not support arrays with nested persistent objects +;; +;; +;; - Indexed classes only have their class index copied if you use the +;; top level migration. Objects will be copied without slot data if you +;; try to migrate an object outside of a store-to-store migration due to +;; the class object belonging to one store or another ;; - Migrate assumes that after migration, indexed classes belong to the ;; target store. +;; ;; - In general, migration is a one-time activity and afterwards (or after ;; a validation test) the source store should be closed. Any failures ;; in migration should then be easy to catch +;; ;; - Each call to migration will be good about keeping track of already ;; copied objects to avoid duplication. Duplication _shouldn't_ screw -;; up the semantics, just cost storage but is to be avoided. However -;; this information is not saved between calls and there's no other -;; way to do comparisons between objects across stores (different oid -;; namespaces) so user beware of the pitfalls of partial migrations... +;; up the semantics, just add storage overhead but is to be avoided. +;; However this information is not saved between calls and there's no +;; other way to do comparisons between objects across stores (different +;; oid namespaces) so user beware of the pitfalls of partial migrations... +;; - Migration does not maintain OID equivalence so any datastructures which +;; index into those will have to have a way to reconstruct themselves (better +;; to keep the object references themselves rather than oids) ;; ;; CUSTOMIZE MIGRATION: ;; - To customize migration overload a version of migrate to specialize on @@ -48,8 +59,9 @@ ;; In the body of this method you can call (call-next-method) ;; to get a destination repository object with all the slots copied over ;; to the target repository which you can then overwrite. To avoid the -;; slot copying, bind the dynamic variable *inhibit-slot-writes* in your -;; user method using (with-inhibited-slot-copy () ...) a convenience macro +;; default persistent slot copying, bind the dynamic variable +;; *inhibit-slot-writes* in your user method using +;; (with-inhibited-slot-copy () ...) a convenience macro ;; @@ -84,7 +96,9 @@ (let ((*migrating* t)) (declare (special *migrating*)) (reset-migrate-duplicate-detection) - (call-next-method)))) + (let ((result (call-next-method))) + (reset-migrate-duplicate-detection) + result)))) (defmethod migrate :before ((dst store-controller) (src persistent)) "This provides some sanity checking that we aren't trying to copy @@ -103,18 +117,56 @@ "Perform a wholesale repository migration from the root. Also acts as a poor man's GC if you copy to another store of the same type!" + ;; Indexed class slots can only be copied once the class metaobject is + ;; pointing at the new indices...but we know that class indices only contain + ;; indexed persistent objects which (see below) are not copied by default + ;; so we do the slot updates here + (map-btree (lambda (classname classidx) + ;; Class indexes should never be copied already + (assert (not (object-was-copied-p classidx))) + (let ((newcidx + (with-transaction (:store-controller dst) + (build-indexed-btree dst)))) + ;; Add inverse indices to new main class index + (map-indices (lambda (name srciidx) + (with-transaction (:store-controller dst) + (add-index newcidx + :index-name name + :key-form (key-form srciidx) + :populate nil))) + classidx) + ;; Add the class index to the class root + (with-transaction (:store-controller dst) + (setf (get-value classname (controller-class-root dst)) newcidx)) + ;; Update the class to point at all it's new objects in the new store + (setf (%index-cache (find-class classname)) newcidx) + ;; Migrate the indexes' objects + (copy-cindex-contents newcidx classidx) + ;; And remember the class index just incase it's indexed elswhere + ;; (and trips the assert above) + (register-copied-object classidx newcidx))) + (controller-class-root src)) + ;; Copy all other reachable objects (map-btree (lambda (key value) (let ((newval (migrate dst value))) (with-transaction (:store-controller dst :txn-nosync t) (add-to-root key newval :store-controller dst)))) (controller-root src)) - (map-btree (lambda (classname classidx) - (declare (ignore classidx)) - (when (find-class classname nil) - (migrate dst (find-class classname)))) - (controller-class-root src)) dst) +(defun copy-cindex-contents (new old) + (let ((sc (get-con new))) + (map-btree (lambda (oldoid oldinst) + (declare (ignore oldoid)) + (let ((newinst (migrate sc oldinst))) + (with-transaction (:store-controller sc) + ;; This isn't redundant in most cases, but we may have + ;; indexed objects without slots and without a slot + ;; write the new index won't be updated in that case + (setf (get-value (oid newinst) new) newinst)))) + old))) + + ;; PERSISTENT OBJECTS THAT AREN'T INDICES (defvar *inhibit-slot-copy* nil) @@ -132,24 +184,22 @@ a function that calls the default copy and then does stuff with the slot values. A dynamic variable: *inhibit-slot-copy* can be bound in the caller to keep the new object from having it's slots copied" - (let ((class (class-of src))) - (migrate dst class) - ;; Copy or lookup persistent object - (if (object-was-copied-p src) - (retrieve-copied-object src) - (copy-persistent-object dst src)))) - -(defmethod migrate ((dst store-controller) (class persistent-metaclass)) - ;; Migrate classes with indices - (return-from migrate) - (unless (or (not (indexed class)) - (equal (controller-spec dst) - (:dbcn-spc-pst (%index-cache class)))) - (format t "Migrating class~A~%" (class-name class)) - (let ((new-cidx (migrate dst (%index-cache class)))) - (setf (get-value (class-name class) (controller-class-root dst)) new-cidx) - (setf (%index-cache class) new-cidx))) - class) + ;; Copy or lookup persistent object + (if (object-was-copied-p src) + (retrieve-copied-object src) + (copy-persistent-object dst src))) + +;; (defmethod migrate ((dst store-controller) (class persistent-metaclass)) +;; "Migrate classes with indices" +;; (let ((dstcidx (get-value (class-name class) (controller-class-root dst)))) +;; (when (and (indexed class) ;; indexed +;; (not dstcidx) ;; hasn't been copied +;; (%index-cache class)) ;; we have a valid reference +;; (format t "Migrating class~A~%" (class-name class)) +;; (let ((new-cidx (migrate dst (%index-cache class) +;; (setf (get-value (class-name class) (controller-class-root dst)) new-cidx) +;; (setf (%index-cache class) new-cidx))) +;; class) (defun reset-migrate-duplicate-detection () (setf *migrate-copied-oids* (make-hash-table))) @@ -164,24 +214,30 @@ (defun retrieve-copied-object (src) (gethash (oid src) *migrate-copied-oids*)) -;; (make-instance (class-of src) -;; :sc dstsc -;; :from-oid (gethash (oid src) *migrate-copied-oids*))) (defun copy-persistent-object (dstsc src) - (let ((dst (make-instance (class-of src) :sc dstsc))) + "Copy the persistent object reference by making a new one and + potentially copy over the slot values as well" + (let* ((class (class-of src)) + (dst (make-instance (class-of src) :sc dstsc))) (register-copied-object src dst) - (unless *inhibit-slot-copy* + (when (and (not *inhibit-slot-copy*) + (not (inhibit-indexed-slot-copy? dstsc class))) (copy-persistent-slots dstsc (class-of src) src dst)) dst)) +(defun inhibit-indexed-slot-copy? (sc class) + (and (indexed class) + (not (equal (controller-spec sc) + (:dbcn-spc-pst (%index-cache class)))))) + (defun copy-persistent-slots (dstsc class src dst) - "Copy all slots from src to dst - transient and persistent - so we maintain any active data" - (loop for slot-def in (class-slots class) do + "Copy only persistent slots from src to dst" + (loop for slot-def in (persistent-slot-defs class) do (when (slot-boundp-using-class class src slot-def) - (setf (slot-value-using-class class dst slot-def) - (migrate dstsc (slot-value-using-class class src slot-def)))))) + (let ((value (migrate dstsc (slot-value-using-class class src slot-def)))) + (with-transaction (:store-controller dstsc) + (setf (slot-value-using-class class dst slot-def) value)))))) ;; MIGRATE INDICES (Override normal persistent copies) @@ -190,8 +246,9 @@ "Copy an index and it's contents to the target repository" (if (object-was-copied-p src) (retrieve-copied-object src) - (let ((newbtree (build-btree dst))) - (copy-btree-contents dst newbtree src) + (let ((newbtree (build-btree dst))) + (with-transaction (:store-controller dst :txn-nosync t) + (copy-btree-contents dst newbtree src)) (register-copied-object src newbtree) newbtree))) @@ -199,19 +256,19 @@ "Also copy the inverse indices for indexed btrees" (if (object-was-copied-p src) (retrieve-copied-object src) - (let ((newbtree (build-indexed-btree dst))) - (copy-btree-contents dst newbtree src) - (map-indices (lambda (name srciidx) - (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t)) - newbtree) - (register-copied-object src newbtree) - newbtree))) + (with-transaction (:store-controller dst :txn-nosync t) + (let ((newbtree (build-indexed-btree dst))) + (copy-btree-contents dst newbtree src) + (map-indices (lambda (name srciidx) + (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t)) + src) + (register-copied-object src newbtree) + newbtree)))) (defmethod copy-btree-contents ((sc store-controller) dst src) (map-btree (lambda (key value) (let ((newval (migrate sc value))) - (with-transaction (:store-controller sc :txn-nosync t) - (setf (get-value key dst) newval)))) + (setf (get-value key dst) newval))) src)) From ieslick at common-lisp.net Tue Feb 21 19:40:08 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 21 Feb 2006 13:40:08 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060221194008.BE4947E008@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv12650/tests Modified Files: elephant-tests.lisp testindexing.lisp testmigration.lisp Log Message: Migration tests pass on BDB. Only migrate ipclass failes under SQLite 3 (May be due to other current failures under SQLite 3) Significant improvements in transaction stability, stability with mutiple open stores, bdb processing speed, and various bug fixes turned up by getting these tests to pass. --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/20 15:45:38 1.16 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/21 19:40:08 1.17 @@ -80,7 +80,7 @@ '(:clsql (:postgresql "localhost.localdomain" "test" "postgres" ""))) (defvar *testsqlite3-spec* - '(:clsql (:sqlite3 "sqlite3-test.db")) + '(:clsql (:sqlite3 "tests/sqlite3-test.db")) "This is of the form '(filename &optional init-function),") (defvar *testsqlite3-memory-spec* @@ -132,8 +132,8 @@ (print (do-test 'migrate-basic)) (print (do-test 'migrate-btree)) (print (do-test 'migrate-idx-btree)) - (print (do-test 'migrate-pclass)))) -;; (print (do-test 'migrate-ipclass)))) + (print (do-test 'migrate-pclass)) + (print (do-test 'migrate-ipclass)))) (defun do-migration-test-spec (test spec1 spec2) (let ((*test-spec-primary* spec1) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/19 04:53:02 1.5 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/21 19:40:08 1.6 @@ -30,8 +30,9 @@ ;;(format t "Global vars:~%") ;;(format t "~%basic store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) ;;(format t "auto-commit: ~A~%" *auto-commit*) - (disable-class-indexing 'idx-one :errorp nil) - (setf (find-class 'idx-one) nil) + (when (find-class 'idx-one nil) + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-one) nil)) (defclass idx-one () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) @@ -55,28 +56,33 @@ (deftest indexing-inherit (progn ;; (format t "inherit store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) - (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil) - (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil) - (setf (find-class 'idx-one) nil) - (setf (find-class 'idx-two) nil) - (defclass idx-one () + (when (find-class 'idx-two nil) + (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil) + (setf (find-class 'idx-two) nil)) + + (when (find-class 'idx-three nil) + (disable-class-indexing 'idx-three :sc *store-controller* :errorp nil) + (setf (find-class 'idx-three) nil)) + + (defclass idx-two () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t) (slot3 :initarg :slot3 :initform 3 :accessor slot3) (slot4 :initarg :slot4 :initform 4 :accessor slot4 :transient t)) (:metaclass persistent-metaclass)) - (defclass idx-two (idx-one) + (defclass idx-three (idx-two) ((slot2 :initarg :slot2 :initform 20 :accessor slot2) (slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t) (slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t)) (:metaclass persistent-metaclass)) + (progn (with-transaction () - (setq inst1 (make-instance 'idx-one :sc *store-controller*)) - (setq inst2 (make-instance 'idx-two :sc *store-controller*))) + (setq inst1 (make-instance 'idx-two :sc *store-controller*)) + (setq inst2 (make-instance 'idx-three :sc *store-controller*))) (values (slot1 inst1) (slot2 inst1) @@ -86,47 +92,48 @@ (slot2 inst2) (slot3 inst2) (slot4 inst2) - (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-one))) - '(slot1 slot2)) (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-two))) + '(slot1 slot2)) + (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-three))) '(slot1 slot3 slot4))))) 1 2 3 4 1 20 30 40 t t) (deftest indexing-range (progn ;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) - (disable-class-indexing 'idx-two :errorp nil) - (disable-class-indexing 'idx-one :errorp nil) - (setf (find-class 'idx-two) nil) - (setf (find-class 'idx-one) nil) + (when (find-class 'idx-four nil) + (disable-class-indexing 'idx-four :errorp nil) + (setf (find-class 'idx-four) nil)) - (defclass idx-one () + (defclass idx-four () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) (:metaclass persistent-metaclass)) - (defun make-idx-one (val) - (make-instance 'idx-one :slot1 val)) + (defun make-idx-four (val) + (make-instance 'idx-four :slot1 val)) (with-transaction () - (mapc #'make-idx-one '(1 1 1 2 2 4 5 5 5 6 10))) + (mapc #'make-idx-four '(1 1 1 2 2 4 5 5 5 6 10))) ;; Range should get multiple & single keys inclusive of ;; start and end - (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6)) + (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 2 6)) '(2 2 4 5 5 5 6)) ;; interior range - (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 0 2)) + (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 0 2)) '(1 1 1 2 2)) - (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 6 15)) + (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 6 15)) '(6 10)))) t t t) (deftest indexing-reconnect-db (progn - (disable-class-indexing 'idx-two :errorp nil) - (setf (find-class 'idx-two) nil) ;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + + (when (find-class 'idx-five nil) + (disable-class-indexing 'idx-two :errorp nil) + (setf (find-class 'idx-two) nil)) - (defclass idx-two () + (defclass idx-five () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) (slot2 :initarg :slot2 :initform 2 :accessor slot2) (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) @@ -136,13 +143,13 @@ (*default-indexed-class-synch-policy* :db)) (with-transaction () - (make-instance 'idx-two)) + (make-instance 'idx-five)) ;; Wipe out the class so it's not a redefinition - (setf (find-class 'idx-two) nil) + (setf (find-class 'idx-five) nil) ;; Assume our db is out of synch with our class def - (defclass idx-two () + (defclass idx-five () ((slot1 :initarg :slot1 :initform 1 :accessor slot1) (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t) (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) @@ -150,34 +157,37 @@ ;; Add an instance of the new class (with-transaction () - (make-instance 'idx-two)) + (make-instance 'idx-five)) ;; DB should dominate (if set as default) - (values (length (get-instances-by-value 'idx-two 'slot3 3)) - (length (get-instances-by-value 'idx-two 'slot1 1)) - (signals-error (length (get-instances-by-value 'idx-two 'slot2 2)))))) + (values (length (get-instances-by-value 'idx-five 'slot3 3)) + (length (get-instances-by-value 'idx-five 'slot1 1)) + (signals-error (length (get-instances-by-value 'idx-five 'slot2 2)))))) 2 2 t) (deftest indexing-change-class (progn - (disable-class-indexing 'idx-one :errorp nil) - (disable-class-indexing 'idx-two :errorp nil) - (setf (find-class 'idx-one) nil) - (setf (find-class 'idx-two) nil) - (defclass idx-one () + (when (find-class 'idx-six nil) + (disable-class-indexing 'idx-six :errorp nil) + (setf (find-class 'idx-six) nil)) + (when (find-class 'idx-seven nil) + (disable-class-indexing 'idx-seven :errorp nil) + (setf (find-class 'idx-seven) nil)) + + (defclass idx-six () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t)) (:metaclass persistent-metaclass)) - (defclass idx-two () + (defclass idx-seven () ((slot1 :initarg :slot1 :initform 10 :accessor slot1 :index nil) (slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t) (slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t)) (:metaclass persistent-metaclass)) - (defmethod update-instance-for-different-class :before ((old idx-one) - (new idx-two) + (defmethod update-instance-for-different-class :before ((old idx-six) + (new idx-seven) &key) (setf (slot3 new) (slot2 old))) @@ -185,8 +195,8 @@ (foo nil)) (declare (special *auto-commit*) (dynamic-extent *auto-commit*)) - (setf foo (make-instance 'idx-one)) - (change-class foo 'idx-two) + (setf foo (make-instance 'idx-six)) + (change-class foo 'idx-seven) (values ;; shared data from original slot @@ -197,12 +207,12 @@ (slot3 foo) (slot4 foo) ;; verify proper indexing changes (none should lookup a value) - (get-instances-by-class 'idx-one) - (get-instances-by-value 'idx-one 'slot1 1) - (get-instances-by-value 'idx-one 'slot2 2) + (get-instances-by-class 'idx-six) + (get-instances-by-value 'idx-six 'slot1 1) + (get-instances-by-value 'idx-six 'slot2 2) ;; new indexes - (length (get-instances-by-class 'idx-two)) - (length (get-instances-by-value 'idx-two 'slot3 2)) + (length (get-instances-by-class 'idx-seven)) + (length (get-instances-by-value 'idx-seven 'slot3 2)) ))) 1 t 2 40 nil nil nil 1 1) --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/20 21:21:45 1.9 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/02/21 19:40:08 1.10 @@ -42,27 +42,19 @@ (progn (format t "~%Single store mode: ignoring") t) - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil) - (sc1 nil) - (sc2 nil)) + (let* ((*store-controller*) + (*auto-commit* t) + (sc1 (open-store *test-spec-primary* :recover t)) + (sc2 (open-store *test-spec-secondary* :recover t))) (unwind-protect (progn - (setf sc1 (open-store *test-spec-primary* :recover t)) - (setf sc2 (open-store *test-spec-secondary* :recover t)) (add-to-root "x" "y" :store-controller sc1) (migrate sc2 sc1) - (setf rv (equal (get-from-root "x" :store-controller sc1) - (get-from-root "x" :store-controller sc2)))) - (progn - (when sc1 (close-store sc1)) - (when sc2 (close-store sc2)) - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))) - rv)) - t) + (equal (get-from-root "x" :store-controller sc1) + (get-from-root "x" :store-controller sc2))) + (close-store sc1) + (close-store sc2)))) + t) ;; Simple test of a btree (deftest migrate-btree @@ -71,23 +63,21 @@ (progn (format t "~%Single store mode: ignoring") nil) - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil)) - (unwind-protect - (let - ((sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*))) - (let ((ibt (make-btree sc1))) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) - (let ((mig (migrate sc2 ibt))) - (btree-differ ibt mig)))) - (progn - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))))) + (let ((*store-controller* nil) + (*auto-commit* t) + (sc1 (open-store *test-spec-primary* :recover t)) + (sc2 (open-store *test-spec-secondary* :recover t))) + (declare (special *store-controller* *auto-commit*)) + (unwind-protect + (let ((ibt (make-btree sc1))) + (with-transaction (:store-controller sc1) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i)))) + (let ((mig (migrate sc2 ibt))) + (btree-differ ibt mig))) + (close-store sc1) + (close-store sc2)))) nil) ;; Simple test of indexed btrees @@ -97,40 +87,41 @@ (progn (format t "~%Single store mode: ignoring") t) - (let ((old-store *store-controller*) - (*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil)) - (unwind-protect - (let ((sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*)) - ) - (let* ((ibt (make-indexed-btree sc1))) - (let ((index - (add-index ibt :index-name 'crunch :key-form 'crunch - :populate t))) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) - (let* ((mig (migrate sc2 ibt)) - (nindex (get-index ibt 'crunch))) - (loop for i from 0 to 10 - do - (if (not - (equal - (get-value i index) - (get-value i nindex) - )) - (progn - (format t "YIKES ~A ~%" i) - ))) - (setf rv (not (btree-differ ibt mig))) - )))) - (progn - (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*))) - rv - )) + (let ((old-store *store-controller*) + (*store-controller* nil) + (*prev-commit* *auto-commit*) + (*auto-commit* t) + (rv nil) + (sc1 (open-store *test-spec-primary* :recover t)) + (sc2 (open-store *test-spec-secondary* :recover t))) + (declare (special *auto-commit*)) + (unwind-protect + (let* ((ibt (make-indexed-btree sc1))) + (let ((index + (add-index ibt :index-name 'crunch :key-form 'crunch + :populate t))) + (with-transaction (:store-controller sc1) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i)))) + (let* ((mig (migrate sc2 ibt)) + (nindex (get-index ibt 'crunch))) + (loop for i from 0 to 10 + do + (if (not + (equal + (get-value i index) + (get-value i nindex) + )) + (progn + (format t "YIKES ~A ~%" i) + ))) + (not (btree-differ ibt mig))))) + (progn + (setq *store-controller* old-store) + (setq *auto-commit* *prev-commit*) + (close-store sc1) + (close-store sc2))))) t) ;; Simple test of persistent classes @@ -140,27 +131,32 @@ (progn (format t "~%Single store mode: ignoring") t) - (let ((*prev-commit* *auto-commit*)) + (let ((*auto-commit* t) + (*store-controller* nil) + (sc1 (open-store *test-spec-primary* :recover t)) + (sc2 (open-store *test-spec-secondary* :recover t))) + (declare (special *auto-commit* *store-controller*)) (unwind-protect - (prog2 - (setq *auto-commit* t) - (let ( - (sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*))) - (let* ((f1 (make-instance 'pfoo :sc sc1)) - (f2 (make-instance 'pfoo :slot1 "this is a string" :sc sc1)) - (b1 (make-instance 'pbar :slot2 "another string" :sc sc1)) - ) - (let ((fm1 (migrate sc2 f1)) - (fm2 (migrate sc2 f2)) - (bm1 (migrate sc2 b1))) - (and - (and (not (slot-boundp fm1 'slot1)) - (not (slot-boundp f1 'slot1))) - (equal (slot1 fm2) (slot1 f2)) - (equal (slot2 bm1) (slot2 b1))) - )))) - (setq *auto-commit* *prev-commit*)))) + (progn + ;; Make instances + (let* ((f1 (with-transaction (:store-controller sc1) + (make-instance 'pfoo :sc sc1))) + (f2 (with-transaction (:store-controller sc1) + (make-instance 'pfoo :slot1 "this is a string" :sc sc1))) + (b1 (with-transaction (:store-controller sc1) + (make-instance 'pbar :slot2 "another string" :sc sc1))) + ) + (let ((fm1 (migrate sc2 f1)) + (fm2 (migrate sc2 f2)) + (bm1 (migrate sc2 b1))) + (and + (and (not (slot-boundp fm1 'slot1)) + (not (slot-boundp f1 'slot1))) + (equal (slot1 fm2) (slot1 f2)) + (equal (slot2 bm1) (slot2 b1))) + ))) + (close-store sc1) + (close-store sc2)))) t) (defpclass ipfoo () @@ -168,37 +164,54 @@ ;; Simple test of persistent classes with indexed slots (deftest migrate-ipclass - (if (or (not (boundp '*test-spec-secondary*) ) + (if (or (not (boundp '*test-spec-secondary*)) (null *test-spec-secondary*)) (progn - (format t "~%Single store mode: ignoring") - t) - (let ((*prev-commit* *auto-commit*)) - (unwind-protect - (progn - (setq *auto-commit* t) - (let ((sc1 (open-store *test-spec-primary*)) - (sc2 (open-store *test-spec-secondary*))) - ;; ensure class index is initialized in sc1 - (find-class-index 'ipfoo :sc sc1) - (let* ((f1 (make-instance 'ipfoo :sc sc1)) - (f2 (make-instance 'ipfoo :slot1 10)) - (f3 (make-instance 'ipfoo :slot1 20))) - (format t "Made instances") - (let ((fm1 (migrate sc2 f1)) - (fm2 (migrate sc2 f2)) - (fm3 (migrate sc2 f3))) - (format t "Migrated instances") - (values - (and - (and (not (slot-boundp fm1 'slot1)) - (not (slot-boundp f1 'slot1))) - (equal (slot1 fm2) (slot1 f2)) - (equal (slot2 fm3) (slot2 f3))) - (length (get-instances-by-class 'ipfoo))) - )))) - (setq *auto-commit* *prev-commit*)))) - t 2 ) + (format t "~%Single store mode: ignoring ") + (values 3 1 1 1 1 10 20 )) + (progn +;; (format t "Opening store~%") + (let ((*auto-commit* nil) + (sc2 (open-store *test-spec-secondary* :recover t)) + (sc1 (open-store *test-spec-primary* :recover t))) + (declare (special *auto-commit*)) + (unwind-protect + ;; ensure class index is initialized in sc1 + (progn + (setf (elephant::%index-cache (find-class 'ipfoo)) nil) + (find-class-index 'ipfoo :sc sc1) +;; (format t "Making objects~%") + (with-transaction (:store-controller sc1) + (drop-instances (get-instances-by-class 'ipfoo) :sc sc1) + (make-instance 'ipfoo :slot1 1 :sc sc1) + (make-instance 'ipfoo :slot1 10 :sc sc1) + (make-instance 'ipfoo :slot1 20 :sc sc1)) +;; (format t "Migrating~%") + (migrate sc2 sc1) + ;; Make sure our ipfoo class now points at a cache in sc2! + (assert (equal (elephant::controller-spec sc2) + (:dbcn-spc-pst (elephant::%index-cache (find-class 'ipfoo))))) +;; (format t "Fetching~%") + (let ((fm1 (get-instances-by-value 'ipfoo 'slot1 1)) + (fm2 (get-instances-by-value 'ipfoo 'slot1 10)) + (fm3 (get-instances-by-value 'ipfoo 'slot1 20)) + (all (get-instances-by-class 'ipfoo))) +;; (format t "Clear & return~%") + (let ((insts (get-instances-by-class 'ipfoo))) + (with-transaction (:store-controller sc2) +;; (format t "Dropping instances~%") + (drop-instances insts :sc sc2))) + (values + (length all) + (length fm1) + (length fm2) + (length fm3) + (slot1 (car fm1)) + (slot1 (car fm2)) + (slot1 (car fm3))))) + (close-store sc1) + (close-store sc2))))) + 3 1 1 1 1 10 20 ) From ieslick at common-lisp.net Wed Feb 22 04:40:57 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 21 Feb 2006 22:40:57 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060222044057.52FAF73010@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv15680 Modified Files: TODO Log Message: Added final indexing test (redefine class) green under ACL (and shouldn't have a problem under SBCL). A little tweak here and there, updated the TODO list. --- /project/elephant/cvsroot/elephant/TODO 2006/02/20 21:21:40 1.15 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/22 04:40:57 1.16 @@ -5,8 +5,6 @@ Upcoming release ideas. 0.6.0 - Adding default class/slot indexing -- Finish indexing tests (Ian) -- Finish migration (Ian) - Documentation update (Robert) - Finish CLSQL backend debug (Robert) From ieslick at common-lisp.net Wed Feb 22 04:40:57 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 21 Feb 2006 22:40:57 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060222044057.99C1774001@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv15680/src/db-bdb Modified Files: bdb-collections.lisp Log Message: Added final indexing test (redefine class) green under ACL (and shouldn't have a problem under SBCL). A little tweak here and there, updated the TODO list. --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/21 19:40:03 1.3 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/22 04:40:57 1.4 @@ -90,6 +90,9 @@ (defmethod build-indexed-btree ((sc bdb-store-controller)) (make-instance 'bdb-indexed-btree :sc sc)) +(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) + (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) + (defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) (let ((sc (get-con bt))) ;; Setting the value of *store-controller* is unfortunately @@ -206,9 +209,6 @@ (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) -(defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) - (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) - (defmethod get-value (key (bt bdb-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3))) From ieslick at common-lisp.net Wed Feb 22 04:40:57 2006 From: ieslick at common-lisp.net (ieslick) Date: Tue, 21 Feb 2006 22:40:57 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060222044057.E336C75000@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv15680/tests Modified Files: testindexing.lisp Log Message: Added final indexing test (redefine class) green under ACL (and shouldn't have a problem under SBCL). A little tweak here and there, updated the TODO list. --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/21 19:40:08 1.6 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 04:40:57 1.7 @@ -217,14 +217,49 @@ 1 t 2 40 nil nil nil 1 1) (deftest indexing-redef-class - nil - nil) - -(deftest indexing-explicit-changes - nil + (progn + (when (find-class 'idx-eight nil) + (disable-class-indexing 'idx-eight :errorp nil) + (setf (find-class 'idx-six nil) nil)) + + (defclass idx-eight () + ((slot1 :accessor slot1 :initarg :slot1 :index t) + (slot2 :accessor slot2 :initarg :slot2) + (slot3 :accessor slot3 :initarg :slot3 :transient t) + (slot4 :accessor slot4 :initarg :slot4 :index t) + (slot5 :accessor slot5 :initarg :slot5))) + + (let ((o1 nil) + (o2 nil)) + (with-transaction () + (setf o1 (make-instance 'idx-eight :slot1 1 :slot2 2 :slot3 3 :slot4 4 :slot5 5)) + (setf o2 (make-instance 'idx-eight :slot1 10 :slot2 20 :slot3 30 :slot4 40 :slot5 50))) + + (defclass idx-eight () + ((slot1 :accessor slot1 :initarg :slot1 :initform 11) + (slot2 :accessor slot2 :initarg :slot2 :initform 12 :index t) + (slot3 :accessor slot3 :initarg :slot3 :initform 13) + (slot6 :accessor slot6 :initarg :slot6 :initform 14 :index t) + (slot7 :accessor slot7 :initarg :slot7))) + + (values + (and (eq (slot1 o1) 1) + (signals-error (get-instances-by-value 'idx-eight 'slot1 1))) + (and (eq (slot2 o1) 2) + (eq (length (get-instances-by-value 'idx-eight 'slot2 2)) 1)) + (eq (slot3 o1) 13) ;; transient values not preserved (would be inconsistent) + (and (not (slot-exists-p o1 'slot4)) + (not (slot-exists-p o1 'slot5)) + (signals-error (get-instances-by-value 'idx-eight 'slot4))) + (and (eq (slot6 o1) 14) + (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) + (and (not (slot-boundp o1 'slot7)))))) + t t t t t t) + + nil) -;; create 10k objects, write each object's slots +;; create 500 objects, write each object's slots (defclass stress-normal () ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil) From ieslick at common-lisp.net Wed Feb 22 17:15:49 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 11:15:49 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060222171549.5E7CC80B1@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv21166/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Bug fixes to indexing tests for failures under SBCL --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/20 15:45:37 1.3 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/22 17:15:49 1.4 @@ -150,6 +150,8 @@ ;; (defmethod persistent-slot-reader ((sc bdb-store-controller) instance name) + (declare (optimize (speed 3) (safety 1) (space 1)) + (type string name)) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf) @@ -162,6 +164,8 @@ (error 'unbound-slot :instance instance :name name))))) (defmethod persistent-slot-writer ((sc bdb-store-controller) new-value instance name) + (declare (optimize (speed 3) (safety 1) (space 1)) + (type string name)) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf) @@ -173,6 +177,8 @@ new-value)) (defmethod persistent-slot-boundp ((sc bdb-store-controller) instance name) + (declare (optimize (speed 3) (safety 1) (space 1)) + (type string name)) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf) @@ -181,6 +187,8 @@ (if buf t nil)))) (defmethod persistent-slot-makunbound ((sc bdb-store-controller) instance name) + (declare (optimize (speed 3) (safety 1) (space 1)) + (type string name)) (with-buffer-streams (key-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf) From ieslick at common-lisp.net Wed Feb 22 17:15:49 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 11:15:49 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060222171549.A372080B1@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv21166/src/elephant Modified Files: classindex.lisp Log Message: Bug fixes to indexing tests for failures under SBCL --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/21 19:40:03 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/22 17:15:49 1.3 @@ -165,7 +165,7 @@ (when (controller-class-root sc) (map-btree (lambda (class-name index) (declare (ignore index)) - (let ((class (find-class class-name :errorp nil))) + (let ((class (find-class class-name nil))) (when class (setf (%index-cache class) nil)))) (controller-class-root sc)))) From ieslick at common-lisp.net Wed Feb 22 17:15:50 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 11:15:50 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060222171550.19BB7C007@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv21166/tests Modified Files: testindexing.lisp Log Message: Bug fixes to indexing tests for failures under SBCL --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 04:40:57 1.7 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 17:15:49 1.8 @@ -130,8 +130,8 @@ ;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) (when (find-class 'idx-five nil) - (disable-class-indexing 'idx-two :errorp nil) - (setf (find-class 'idx-two) nil)) + (disable-class-indexing 'idx-five :errorp nil) + (setf (find-class 'idx-five) nil)) (defclass idx-five () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) @@ -220,14 +220,15 @@ (progn (when (find-class 'idx-eight nil) (disable-class-indexing 'idx-eight :errorp nil) - (setf (find-class 'idx-six nil) nil)) + (setf (find-class 'idx-eight nil) nil)) (defclass idx-eight () ((slot1 :accessor slot1 :initarg :slot1 :index t) (slot2 :accessor slot2 :initarg :slot2) (slot3 :accessor slot3 :initarg :slot3 :transient t) (slot4 :accessor slot4 :initarg :slot4 :index t) - (slot5 :accessor slot5 :initarg :slot5))) + (slot5 :accessor slot5 :initarg :slot5)) + (:metaclass persistent-metaclass)) (let ((o1 nil) (o2 nil)) @@ -240,7 +241,8 @@ (slot2 :accessor slot2 :initarg :slot2 :initform 12 :index t) (slot3 :accessor slot3 :initarg :slot3 :initform 13) (slot6 :accessor slot6 :initarg :slot6 :initform 14 :index t) - (slot7 :accessor slot7 :initarg :slot7))) + (slot7 :accessor slot7 :initarg :slot7)) + (:metaclass persistent-metaclass)) (values (and (eq (slot1 o1) 1) @@ -255,9 +257,6 @@ (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) (and (not (slot-boundp o1 'slot7)))))) t t t t t t) - - - nil) ;; create 500 objects, write each object's slots From rread at common-lisp.net Wed Feb 22 20:18:51 2006 From: rread at common-lisp.net (rread) Date: Wed, 22 Feb 2006 14:18:51 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060222201851.6D9FE69011@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv13327 Modified Files: INSTALL ele-clsql.asd elephant.asd Added Files: config.lisp Log Message: New Configuration mechanism. Minor test changes. At least to SQL-side fixes. --- /project/elephant/cvsroot/elephant/INSTALL 2006/02/20 15:45:36 1.16 +++ /project/elephant/cvsroot/elephant/INSTALL 2006/02/22 20:18:51 1.17 @@ -93,7 +93,7 @@ b) Also edit the variable *sleepycat-foreign-library-path* in - ele-bdb.asd + config.lisp to point to your local distribution of the Berkeley DB libraries --- /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/19 16:22:39 1.6 +++ /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/02/22 20:18:51 1.7 @@ -16,11 +16,35 @@ ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;; (eval-when (:compile-toplevel :load-toplevel :execute) +;; (unless (find-package 'clsql) +;; (asdf:operate 'asdf:load-op 'clsql))) + +;; ;; clsql needs to know how to find libaries to various databases.... +;; (defvar *clsql-foreign-lib-path* "/usr/lib") +;; (defvar *elephant-lib-path* "/usr/local/share/common-lisp/elephant/") +;; (clsql:push-library-path *clsql-foreign-lib-path*) +;; (clsql:push-library-path *elephant-lib-path*) +;; ) + +(defparameter *clsql-foreign-lib-path* #p"/usr/lib") +(defparameter *elephant-lib-path* #p"/usr/local/share/common-lisp/elephant/") + +(defmethod asdf:perform :after ((o asdf:load-op) + (c (eql (asdf:find-system 'clsql)))) + (let ((plp (find-symbol (symbol-name '#:push-library-path) + (find-package 'clsql)))) + (funcall plp + *clsql-foreign-lib-path*) + (funcall plp + *elephant-lib-path*) +)) + (defsystem ele-clsql :name "elephant" :author "Ben Lee " :version "0.6.0" - :maintainer "Ben Lee " + :maintainer "Robert L. Read " :licence "LLGPL" :description "SQL-based Object respository for Common Lisp" :long-description "An experimental CL-SQL based implementation of Elephant" --- /project/elephant/cvsroot/elephant/elephant.asd 2006/02/19 20:06:03 1.15 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/02/22 20:18:51 1.16 @@ -95,6 +95,7 @@ (:module elephant :components ((:file "elephant") + (:file "config" :pathname "../../config.lisp") (:file "variables") #+cmu (:file "cmu-mop-patches") #+openmcl (:file "openmcl-mop-patches") --- /project/elephant/cvsroot/elephant/config.lisp 2006/02/22 20:18:51 NONE +++ /project/elephant/cvsroot/elephant/config.lisp 2006/02/22 20:18:51 1.1 ;; CLSQL BACKEND ;; Make sure the libraries that CLSQL needs for a particular system ;; are pointed to by these libraries. ;; These values will be irrelevant if you don't use a CLSQL-based backend. (defparameter *clsql-foreign-lib-path* #p"/usr/local/share/common-lisp/elephant/") ;; BerkeleyDB ;; Make sure the libraries that CLSQL needs for a particular system ;; are pointed to by these libraries. (defparameter *sleepycat-foreign-library-path* ;; Sleepycat: this works on linux #+linux ;; "/db/ben/lisp/db43/lib/libdb.so" "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" ;; this works on FreeBSD #+(and (or bsd freebsd) (not (or darwin macosx))) "/usr/local/lib/db43/libdb.so" #+(or darwin macosx) ;; for Fink (OS X) -- but I will assume Linux more common... ;; "/sw/lib/libdb-4.3.dylib" ;; a possible manual install "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib") From rread at common-lisp.net Wed Feb 22 20:18:51 2006 From: rread at common-lisp.net (rread) Date: Wed, 22 Feb 2006 14:18:51 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060222201851.B551369012@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory common-lisp:/tmp/cvs-serv13327/src/db-clsql Modified Files: sql-collections.lisp sql-controller.lisp Log Message: New Configuration mechanism. Minor test changes. At least to SQL-side fixes. --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/19 20:06:03 1.3 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2006/02/22 20:18:51 1.4 @@ -98,6 +98,19 @@ (string< (format nil "~A" a) (format nil "~A" b))) )) +(defun my-generic-at-most (a b) + (cond + ((and (typep a 'persistent) (typep b 'persistent)) + (<= (oid a) (oid b)) + ) + ((and (numberp a ) (numberp b)) + (<= a b)) + ((and (stringp a) (stringp b)) + (string<= a b)) + (t + (string<= (format nil "~A" a) (format nil "~A" b))) + )) + (defmethod cursor-un-init ((cursor sql-cursor) &key (returnpk nil)) (setf (cursor-initialized-p cursor) nil) (if returnpk @@ -352,17 +365,17 @@ (let ((idx (position key (:sql-crsr-ks cursor)))) (if idx (progn - (setf (:sql-crsr-ck cursor) idx) - (setf (:dp-nmbr cursor) 0) - (cursor-current-x cursor :returnpk t)) + (setf (:sql-crsr-ck cursor) idx) + (setf (:dp-nmbr cursor) 0) + (cursor-current-x cursor :returnpk t)) (cursor-un-init cursor) - ))) + ))) (defun array-index-if (p a) (do ((i 0 (1+ i))) ((or (not (array-in-bounds-p a i)) (funcall p (aref a i))) - (if (funcall p (aref a i)) + (if (and (array-in-bounds-p a i) (funcall p (aref a i))) i -1))) ) @@ -371,7 +384,7 @@ (declare (optimize (speed 3))) (unless (cursor-initialized-p cursor) (cursor-init cursor)) - (let ((idx (array-index-if #'(lambda (x) (my-generic-less-than key x)) (:sql-crsr-ks cursor)))) + (let ((idx (array-index-if #'(lambda (x) (my-generic-at-most key x)) (:sql-crsr-ks cursor)))) (if (<= 0 idx) (progn (setf (:sql-crsr-ck cursor) idx) @@ -535,12 +548,16 @@ ) (defmethod cursor-next-dup-x ((cursor sql-secondary-cursor) &key (returnpk nil)) - (declare (optimize (speed 3))) +;; (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (let* ((cur-pk (aref (:sql-crsr-ks cursor) (:sql-crsr-ck cursor))) - (nxt-pk (aref (:sql-crsr-ks cursor) - (+ 1 (:sql-crsr-ck cursor)))) + (nint (+ 1 (:sql-crsr-ck cursor))) + (nxt-pk (if (array-in-bounds-p (:sql-crsr-ks cursor) nint) + (aref (:sql-crsr-ks cursor) + nint) + -1 + )) ) (if (equal cur-pk nxt-pk) (progn @@ -559,8 +576,12 @@ (if (cursor-initialized-p cursor) (let ((n (do ((i (:sql-crsr-ck cursor) (1+ i))) - ((not (equal (aref (:sql-crsr-ks cursor) i) - (aref (:sql-crsr-ks cursor) (+ 1 i)))) (+ 1 i))))) + ((or + (not (array-in-bounds-p (:sql-crsr-ks cursor) (+ i 1))) + (not + (equal (aref (:sql-crsr-ks cursor) i) + (aref (:sql-crsr-ks cursor) (+ 1 i))))) + (+ 1 i))))) (setf (:sql-crsr-ck cursor) n) (setf (:dp-nmbr cursor) 0) (has-key-value-scnd cursor :returnpk returnpk)) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/20 21:21:41 1.6 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/22 20:18:51 1.7 @@ -24,24 +24,6 @@ (in-package "ELEPHANT-CLSQL") -;; ISE NOTE: Putting this here results in users having to -;; modify source code to run which is inadvisable. My strategy -;; is to asdf resolve references to local libraries and require -;; that the user properly install clsql for their chosen SQL -;; backend. If you really want to allow local configuration -;; for SQL then stick it into ele-sql.asd just as we did for -;; BDB in ele-bdb.asd. This note and code should get removed -;; in 0.6.1 if we have a reasonable strategy -;; -;;; other clsql packages would have to be added for -;;; non-postgresql databases, see the CL-SQL documentation -;; (eval-when (:compile-toplevel :load-toplevel) -;; ;; NOTE: Integrate into load process -;; ;; Probably must be customized ... see documentation on installin postgres. -;; (defvar *clsql-foreign-lib-path* "/usr/lib") -;; (clsql:push-library-path *clsql-foreign-lib-path*) -;; (clsql:push-library-path *elephant-lib-path*)) - ;; ;; The main SQL Controller Class ;; From rread at common-lisp.net Wed Feb 22 20:18:52 2006 From: rread at common-lisp.net (rread) Date: Wed, 22 Feb 2006 14:18:52 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060222201852.112DC6A003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv13327/src/elephant Modified Files: classes.lisp classindex.lisp Log Message: New Configuration mechanism. Minor test changes. At least to SQL-side fixes. --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/21 19:40:03 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 20:18:51 1.3 @@ -18,6 +18,9 @@ ;;; (in-package "ELEPHANT") +(defvar *debug-si* nil) + + (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid @@ -128,7 +131,7 @@ aren't used. We also handle writing any indices after the class is fully initialized. Calls the next method for the transient slots." - (let* ((class (class-of instance)) + (let* ((class (find-class (class-name (class-of instance)))) (oid (oid instance)) (persistent-slot-names (persistent-slot-names class))) (flet ((persistent-slot-p (item) @@ -172,7 +175,7 @@ ;; via a cursor without going through the cursor abstraction. There has to be a ;; better way to do this. (when (and (indexed class) (not from-oid)) - (let ((class-index (find-class-index (class-of instance)))) + (let ((class-index (find-class-index class))) (when class-index (with-transaction (:store-controller (get-con class-index)) (setf (get-value oid class-index) instance))))) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/22 17:15:49 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/22 20:18:51 1.4 @@ -354,8 +354,9 @@ (get-instances-by-value (find-class class) slot-name value)) (defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) - (declare (optimize (speed 3) (safety 1) (space 1)) - (type (or string symbol) slot-name)) + (declare + (optimize (speed 3) (safety 1) (space 1)) + (type (or string symbol) slot-name)) (let ((instances nil)) (with-btree-cursor (cur (find-inverted-index class slot-name)) (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) From rread at common-lisp.net Wed Feb 22 20:18:55 2006 From: rread at common-lisp.net (rread) Date: Wed, 22 Feb 2006 14:18:55 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060222201855.61F0C6B008@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv13327/tests Modified Files: BerkeleyDB-tests.lisp SQLDB-tests.lisp testindexing.lisp Log Message: New Configuration mechanism. Minor test changes. At least to SQL-side fixes. --- /project/elephant/cvsroot/elephant/tests/BerkeleyDB-tests.lisp 2006/02/05 23:46:41 1.1 +++ /project/elephant/cvsroot/elephant/tests/BerkeleyDB-tests.lisp 2006/02/22 20:18:52 1.2 @@ -5,17 +5,11 @@ ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -(asdf:operate 'asdf:load-op :elephant) -(asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :elephant-tests) (in-package "ELEPHANT-TESTS") -;; The primary and secondary test-paths are -;; use for the migration tests. -;; -(setq *test-path-primary* *testdb-path*) -(setq *test-path-secondary* nil) +(setf *default-spec* *testbdb-spec*) -(do-all-tests-spec *test-path-primary*) +(do-backend-tests) --- /project/elephant/cvsroot/elephant/tests/SQLDB-tests.lisp 2006/02/05 23:46:41 1.1 +++ /project/elephant/cvsroot/elephant/tests/SQLDB-tests.lisp 2006/02/22 20:18:52 1.2 @@ -11,26 +11,11 @@ ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -(asdf:operate 'asdf:load-op :elephant) -(asdf:operate 'asdf:load-op :ele-clsql) (asdf:operate 'asdf:load-op :elephant-tests) -;; For postgres use this... -(asdf:oos 'asdf:load-op :clsql-postgresql-socket) -;; For sqllite3... use this... -;; (asdf:operate 'asdf:load-op :ele-sqlite3) - (in-package "ELEPHANT-TESTS") -;; The primary and secondary test-paths are -;; use for the migration tests. -;; You may have to change these from the defaults set in -;; elephant-tests.lisp to point to your database. -(setq *test-path-primary* *testpg-path*) - -;; This is an alternative -;; (setq *test-path-primary* *testsqlite3-path*) +(setf *default-spec* *testpg-spec*) -(setq *test-path-secondary* nil) +(do-backend-tests) -(do-all-tests-spec *test-path-primary*) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 17:15:49 1.8 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 20:18:54 1.9 @@ -24,15 +24,35 @@ (defvar inst2) (defvar inst3) +(deftest indexing-basic-trivial + (progn + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-one) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) + (:metaclass persistent-metaclass)) + (length (get-instances-by-class 'idx-one)) + (with-transaction (:store-controller *store-controller*) + (setq inst1 (make-instance 'idx-one :slot1 1 :sc *store-controller*))) +;; The real problem is that this call doesn't seem to see it, and the make-instance +;; doesn't seem to think it needs to write anything! + (length (get-instances-by-class 'idx-one)) + (length (get-instances-by-class 'idx-one)) + ) + 1) + ;; put list of objects, retrieve on value, range and by class (deftest indexing-basic (progn ;;(format t "Global vars:~%") ;;(format t "~%basic store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) ;;(format t "auto-commit: ~A~%" *auto-commit*) - (when (find-class 'idx-one nil) - (disable-class-indexing 'idx-one :errorp nil) - (setf (find-class 'idx-one) nil)) + + (disable-class-indexing 'idx-one :errorp nil) + +;; Possibly under SBCL this really hoses things up! +;; (setf (find-class 'idx-one) nil) (defclass idx-one () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) @@ -40,16 +60,16 @@ (progn (with-transaction (:store-controller *store-controller*) - (setq inst1 (make-instance 'idx-one :slot1 1 :sc *store-controller*)) - (setq inst2 (make-instance 'idx-one :slot1 1 :sc *store-controller*)) - (setq inst3 (make-instance 'idx-one :slot1 3 :sc *store-controller*))) + (setq inst1 (make-instance 'idx-one :slot1 40 :sc *store-controller*)) + (setq inst2 (make-instance 'idx-one :slot1 40 :sc *store-controller*)) + (setq inst3 (make-instance 'idx-one :slot1 41 :sc *store-controller*))) ;; (format t "Starting gathering of instances~%") (values (length (get-instances-by-class 'idx-one)) - (length (get-instances-by-value 'idx-one 'slot1 1)) - (length (get-instances-by-value 'idx-one 'slot1 3)) - (eq (first (get-instances-by-value 'idx-one 'slot1 3)) inst3) - (length (get-instances-by-range 'idx-one 'slot1 1 3))))) + (length (get-instances-by-value 'idx-one 'slot1 40)) + (length (get-instances-by-value 'idx-one 'slot1 41)) + (equal (first (get-instances-by-value 'idx-one 'slot1 41)) inst3) + (length (get-instances-by-range 'idx-one 'slot1 40 41))))) 3 2 1 t 3) ;; test inherited slots @@ -100,7 +120,7 @@ (deftest indexing-range (progn -;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + ;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) (when (find-class 'idx-four nil) (disable-class-indexing 'idx-four :errorp nil) (setf (find-class 'idx-four) nil)) @@ -115,19 +135,26 @@ (with-transaction () (mapc #'make-idx-four '(1 1 1 2 2 4 5 5 5 6 10))) - ;; Range should get multiple & single keys inclusive of - ;; start and end - (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 2 6)) - '(2 2 4 5 5 5 6)) ;; interior range - (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 0 2)) - '(1 1 1 2 2)) - (equal (mapcar #'slot1 (get-instances-by-range 'idx-four 'slot1 6 15)) - '(6 10)))) + (let ((x1 (get-instances-by-range 'idx-four 'slot1 2 6)) + (x2 (get-instances-by-range 'idx-four 'slot1 0 2)) + (x3 (get-instances-by-range 'idx-four 'slot1 6 15)) + ) + ;; (format t " x1 = ~A~%" (mapcar #'slot1 x1)) + ;; (format t " x2 = ~A~%" (mapcar #'slot1 x2)) + ;; (format t " x3 = ~A~%" (mapcar #'slot1 x3)) + (values (equal (mapcar #'slot1 x1) + '(2 2 4 5 5 5 6)) ;; interior range + (equal (mapcar #'slot1 x2) + '(1 1 1 2 2)) + (equal (mapcar #'slot1 x3) + '(6 10)) + )) + ) t t t) (deftest indexing-reconnect-db (progn -;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + (format t "connect store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) (when (find-class 'idx-five nil) (disable-class-indexing 'idx-five :errorp nil) @@ -142,7 +169,8 @@ (let ((*old-default* *default-indexed-class-synch-policy*) (*default-indexed-class-synch-policy* :db)) - (with-transaction () + (format t "connect store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) + (with-transaction (:store-controller *store-controller*) (make-instance 'idx-five)) ;; Wipe out the class so it's not a redefinition From ieslick at common-lisp.net Wed Feb 22 21:03:47 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 15:03:47 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060222210347.5E72D2A03B@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv18474 Modified Files: TODO config.lisp Log Message: Quick fix for config.lisp not having a package designator. Also my tweaks to fix a BDB bug, adding transacctions to btree writes for increased safety and various tweaks I made trying to fix the slot-boundp bug in indexing-redef-class --- /project/elephant/cvsroot/elephant/TODO 2006/02/22 04:40:57 1.16 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/22 21:03:47 1.17 @@ -5,8 +5,9 @@ Upcoming release ideas. 0.6.0 - Adding default class/slot indexing -- Documentation update (Robert) +- Resolve stubbed out slot-boundp bug in indexing-reconnect-db test (Ian) - Finish CLSQL backend debug (Robert) +- Documentation update (Robert) 0.6.1 - performance, safety and portability @@ -14,25 +15,37 @@ - Make elephant thread bound variables dynamic and modifiable by backends - Verify that operations such as indexing are thread safe -Stability: +Stability +--------- +- Review all the NOTE comments in the code +- Remove build gensym warnings in sleepycat +- Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) +- (From Ben's e-mail) We are storing persistent objects incorrectly. They should be + stored only as OIDs, and we should have a separate OID->class table. This way + change-class can be handled correctly (Ian) ??? +- Delete persistent slot values from the slot store with remove-kv to ensure that + there's no data left lying around if you define then redefine a class and add + back a persistent slot name that you thought was deleted and it gets the old + value + +Stores: - Think about dynamic vs. object based store & transaction resolution? - Error checking when mixed - Current store specific *current-transaction* stack -- Throw condition when store spec is invalid, etc - Think through default vs. explicit store referencing all over the APIs (Both) +- Throw condition when store spec is invalid, etc + +Transactionalism: - Cleaner failure modes if operations are performed without repository or without transaction or auto-commit (Both) -- Add asserts if *auto-index* is false and we're not in a transaction - to help users avoid lockups in bdb? Should be able to turn off for - performance but it will help catch missing with-transaction statemetns - in user code. (Both) +- Trace all paths to db-put or db-delete and ensure that there is a check or a + default with-transaction around the primitive components - write a document + clarifying transaction design & assumptions in the backend] Add asserts if + *auto-index* is false and we're not in a transaction to help users avoid lockups + in bdb? Should be able to turn off for performance but it will help catch + missing with-transaction statemetns in user code. (Both) - BDB: determine how to detect deadlock conditions as an optional run-safe mode? (?) Does BDB have timeouts enabled on select? (Ian) -- Remove build gensym warnings -- Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) -- (From Ben's e-mail) We are storing persistent objects incorrectly. They should be - stored only as OIDs, and we should have a separate OID->class table. This way - change-class can be handled correctly (Ian) ??? Performance: - Metering and understanding locking issues. Large transactions seem @@ -58,6 +71,7 @@ 0.6.3 - Query & indexing expansion - simple object query language (Ian - orthogonal, on main branch) - Add needed support (if any) for persistent graph structures & queries (Ian on a branch) + - A wrapper around migration that emulates a stop-and-copy GC 0.6.4 - Compliance & Documentation - Update to support BDB 4.4 @@ -92,8 +106,7 @@ - NoSynch - allow transactions to be lost on failure but maintains consistency instead of performance 0.8 - Lisp Backend? - - + - A native BTree implementation in CommonLisp (prototype on Allegro's BTree implementation for ACache) Feb. 4, 2006 --- /project/elephant/cvsroot/elephant/config.lisp 2006/02/22 20:18:51 1.1 +++ /project/elephant/cvsroot/elephant/config.lisp 2006/02/22 21:03:47 1.2 @@ -1,3 +1,6 @@ + +(in-package :elephant) + ;; CLSQL BACKEND ;; Make sure the libraries that CLSQL needs for a particular system ;; are pointed to by these libraries. From ieslick at common-lisp.net Wed Feb 22 21:03:47 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 15:03:47 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060222210347.A5B322A03B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory common-lisp:/tmp/cvs-serv18474/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp Log Message: Quick fix for config.lisp not having a package designator. Also my tweaks to fix a BDB bug, adding transacctions to btree writes for increased safety and various tweaks I made trying to fix the slot-boundp bug in indexing-redef-class --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/22 04:40:57 1.4 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/02/22 21:03:47 1.5 @@ -56,22 +56,24 @@ (defmethod (setf get-value) (value key (bt bdb-btree)) (declare (optimize (speed 3) (safety 0) (space 0))) - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (serialize value value-buf) - (db-put-buffered (controller-btrees (get-con bt)) - key-buf value-buf - :auto-commit *auto-commit*) - value)) + (with-transaction (:store-controller (get-con bt)) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid bt) key-buf) + (serialize key key-buf) + (serialize value value-buf) + (db-put-buffered (controller-btrees (get-con bt)) + key-buf value-buf + :auto-commit *auto-commit*) + value))) (defmethod remove-kv (key (bt bdb-btree)) (declare (optimize (speed 3) (space 0) (safety 0))) - (with-buffer-streams (key-buf) - (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (db-delete-buffered (controller-btrees (get-con bt)) - key-buf :auto-commit *auto-commit*))) + (with-transaction (:store-controller (get-con bt)) + (with-buffer-streams (key-buf) + (buffer-write-int (oid bt) key-buf) + (serialize key key-buf) + (db-delete-buffered (controller-btrees (get-con bt)) + key-buf :auto-commit *auto-commit*)))) ;; Secondary indices --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/22 17:15:49 1.4 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/02/22 21:03:47 1.5 @@ -150,8 +150,7 @@ ;; (defmethod persistent-slot-reader ((sc bdb-store-controller) instance name) - (declare (optimize (speed 3) (safety 1) (space 1)) - (type string name)) +;; (declare (optimize (speed 3) (safety 1) (space 1))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf) @@ -164,8 +163,8 @@ (error 'unbound-slot :instance instance :name name))))) (defmethod persistent-slot-writer ((sc bdb-store-controller) new-value instance name) - (declare (optimize (speed 3) (safety 1) (space 1)) - (type string name)) +;; (declare (optimize (speed 3) (safety 1) (space 1))) +;; (format t "psw -- sc: ~A ct: ~A ac: ~A~%" *store-controller* *current-transaction* *auto-commit*) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf) @@ -177,8 +176,7 @@ new-value)) (defmethod persistent-slot-boundp ((sc bdb-store-controller) instance name) - (declare (optimize (speed 3) (safety 1) (space 1)) - (type string name)) +;; (declare (optimize (speed 3) (safety 1) (space 1))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf) @@ -187,8 +185,7 @@ (if buf t nil)))) (defmethod persistent-slot-makunbound ((sc bdb-store-controller) instance name) - (declare (optimize (speed 3) (safety 1) (space 1)) - (type string name)) +;; (declare (optimize (speed 3) (safety 1) (space 1))) (with-buffer-streams (key-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf) From ieslick at common-lisp.net Wed Feb 22 21:03:47 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 15:03:47 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060222210347.ED1AB2A03B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv18474/src/elephant Modified Files: classes.lisp metaclasses.lisp Log Message: Quick fix for config.lisp not having a package designator. Also my tweaks to fix a BDB bug, adding transacctions to btree writes for increased safety and various tweaks I made trying to fix the slot-boundp bug in indexing-redef-class --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 20:18:51 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 21:03:47 1.4 @@ -42,6 +42,10 @@ automatically inherited if you use the persistent-metaclass metaclass.")) +;; ================================================ +;; METACLASS INITIALIZATION AND CHANGES +;; ================================================ + (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) @@ -54,59 +58,8 @@ direct-superclasses) args) (call-next-method)))) -#+allegro -(defun make-persistent-reader (name slot-definition class class-name) - (eval `(defmethod ,name ((instance ,class-name)) - (slot-value-using-class ,class instance ,slot-definition)))) - -#+allegro -(defun make-persistent-writer (name slot-definition class class-name) - (let ((name (if (and (consp name) - (eq (car name) 'setf)) - name - `(setf ,name)))) - (eval `(defmethod ,name ((instance ,class-name) value) - (setf (slot-value-using-class ,class instance ,slot-definition) - value))))) - -#+allegro -(defmethod initialize-accessors ((slot-definition persistent-slot-definition) class) - (let ((readers (slot-definition-readers slot-definition)) - (writers (slot-definition-writers slot-definition)) - (class-name (class-name class))) - (loop for reader in readers - do (make-persistent-reader reader slot-definition class class-name)) - (loop for writer in writers - do (make-persistent-writer writer slot-definition class class-name)))) - -#+allegro -(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (prog1 - (call-next-method) - (when (class-finalized-p instance) - (update-persistent-slots instance (persistent-slot-names instance)) - (update-indexed-record instance (indexed-slot-names-from-defs instance)) - (set-db-synch instance :class) - (loop with persistent-slots = (persistent-slots instance) - for slot-def in (class-direct-slots instance) - when (member (slot-definition-name slot-def) persistent-slots) - do (initialize-accessors slot-def instance)) - (make-instances-obsolete instance)))) - -#+(or cmu sbcl openmcl) -(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (prog1 - (call-next-method) - (when (class-finalized-p instance) - (update-persistent-slots instance (persistent-slot-names instance)) - (update-indexed-record instance (indexed-slot-names-from-defs instance)) - (set-db-synch instance :class) - (make-instances-obsolete instance)))) - -;; #+allegro (defmethod finalize-inheritance :around ((instance persistent-metaclass)) + "Update the persistent slot records in the metaclass" (prog1 (call-next-method) (when (not (slot-boundp instance '%persistent-slots)) @@ -115,13 +68,9 @@ (when (not (slot-boundp instance '%indexed-slots)) (update-indexed-record instance (indexed-slot-names-from-defs instance))))) -;; #+(or cmu sbcl) -;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) -;; (prog1 -;; (call-next-method) -;; (if (not (slot-boundp instance '%persistent-slots)) -;; (setf (%persistent-slots instance) -;; (cons (persistent-slot-names instance) nil))))) +;; ================================================ +;; PERSISTENT OBJECT MAINTENANCE +;; ================================================ (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys) "Initializes the persistent slots via initargs or forms. @@ -151,9 +100,10 @@ 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)))) + (setf (slot-value-using-class class instance slot-def) + (getf initargs initarg)) + (return t)))) + (with-transaction (:store-controller (get-con instance)) (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) @@ -162,7 +112,7 @@ (let ((initfun (slot-definition-initfunction slot-def))) (when initfun (setf (slot-value-using-class class instance slot-def) - (funcall initfun))))) + (funcall initfun)))))) ;; (format t "transient-slot-inits ~A~%" transient-slot-inits) ;; (format t "indices boundp ~A~%" (slot-boundp instance 'indices)) ;; (format t "indices-caches boundp ~A~%" (slot-boundp instance 'indices-cache)) @@ -177,12 +127,12 @@ (when (and (indexed class) (not from-oid)) (let ((class-index (find-class-index class))) (when class-index - (with-transaction (:store-controller (get-con class-index)) - (setf (get-value oid class-index) instance))))) + (setf (get-value oid class-index) instance)))) )))) -(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) +(defmethod update-instance-for-redefined-class ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; NOTE: probably should delete discarded slots, but we'll worry about that later + ;; (also will want to delete discarded indices since we don't have a good GC) (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) @@ -210,14 +160,15 @@ ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) - (loop for slot-def in (class-slots new-class) - when (member (slot-definition-name slot-def) retained-persistent-slots) - do (setf (slot-value-using-class new-class - current - slot-def) - (slot-value-using-class old-class - previous - (find-slot-def-by-name old-class (slot-definition-name slot-def))))) + (with-transaction (:store-controller (get-con current)) + (loop for slot-def in (class-slots new-class) + when (member (slot-definition-name slot-def) retained-persistent-slots) + do (setf (slot-value-using-class new-class + current + slot-def) + (slot-value-using-class old-class + previous + (find-slot-def-by-name old-class (slot-definition-name slot-def)))))) ;; Delete this instance from its old class index, if exists (when (indexed old-class) (remove-kv (oid previous) (find-class-index old-class))) @@ -229,14 +180,6 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-reader (get-con instance) instance name))) -;; ORIGINAL METHOD -;; (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) -;; "Set the slot value in the database." -;; (declare (optimize (speed 3))) -;; (let ((name (slot-definition-name slot-def))) -;; (persistent-slot-writer new-value instance name))) - -;; SUPPORT FOR INVERTED INDEXES (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (declare (optimize (speed 3))) @@ -270,7 +213,15 @@ (unregister-indexed-slot class (slot-definition-name slot-def))) (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def))) -;; NOTE: Closer to MOP will fix this +;; ====================================================== +;; Handling metaclass overrides of normal slot operation +;; NOTE: Closer to MOP should replace this need... +;; ====================================================== + +;; +;; ALLEGRO +;; + #+allegro (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) (loop for slot in (class-slots class) @@ -278,3 +229,93 @@ finally (return (if (typep slot 'persistent-slot-definition) (slot-makunbound-using-class class instance slot) (call-next-method))))) + + +#+allegro +(defun make-persistent-reader (name slot-definition class class-name) + (eval `(defmethod ,name ((instance ,class-name)) + (slot-value-using-class ,class instance ,slot-definition)))) + +#+allegro +(defun make-persistent-writer (name slot-definition class class-name) + (let ((name (if (and (consp name) + (eq (car name) 'setf)) + name + `(setf ,name)))) + (eval `(defmethod ,name ((instance ,class-name) value) + (setf (slot-value-using-class ,class instance ,slot-definition) + value))))) + +#+allegro +(defmethod initialize-accessors ((slot-definition persistent-slot-definition) class) + (let ((readers (slot-definition-readers slot-definition)) + (writers (slot-definition-writers slot-definition)) + (class-name (class-name class))) + (loop for reader in readers + do (make-persistent-reader reader slot-definition class class-name)) + (loop for writer in writers + do (make-persistent-writer writer slot-definition class class-name)))) + +#+allegro +(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) + (loop with persistent-slots = (persistent-slots instance) + for slot-def in (class-direct-slots instance) + when (member (slot-definition-name slot-def) persistent-slots) + do (initialize-accessors slot-def instance)) + (make-instances-obsolete instance)))) + +;; +;; CMU / SBCL +;; + +#+(or cmu sbcl) +(defun make-persistent-reader (name) + (lambda (instance) + (declare (optimize (speed 3)) + (type persistent-object instance)) + (persistent-slot-reader (get-con instance) instance name))) + +#+(or cmu sbcl) +(defun make-persistent-writer (name) + (lambda (new-value instance) + (declare (optimize (speed 3)) + (type persistent-object instance)) + (persistent-slot-writer (get-con instance) new-value instance name))) + +#+(or cmu sbcl) +(defun make-persistent-slot-boundp (name) + (lambda (instance) + (declare (optimize (speed 3)) + (type persistent-object instance)) + (persistent-slot-boundp (get-con instance) instance name))) + +#+(or cmu sbcl) +(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition)) + (let ((name (slot-definition-name slot-def))) + (setf (slot-definition-reader-function slot-def) + (make-persistent-reader name)) + (setf (slot-definition-writer-function slot-def) + (make-persistent-writer name)) + (setf (slot-definition-boundp-function slot-def) + (make-persistent-slot-boundp name))) + slot-def) + +#+(or cmu sbcl openmcl) +(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) +;; (initialize-internal-slot-functions + (make-instances-obsolete instance)))) + --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/21 19:40:03 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/22 21:03:47 1.4 @@ -326,37 +326,6 @@ when (eq (slot-definition-name slot-def) slot-name) do (return slot-def))) -#+(or cmu sbcl) -(defun make-persistent-reader (name) - (lambda (instance) - (declare (optimize (speed 3)) - (type persistent-object instance)) - (persistent-slot-reader (get-con instance) instance name))) - -#+(or cmu sbcl) -(defun make-persistent-writer (name) - (lambda (new-value instance) - (declare (optimize (speed 3)) - (type persistent-object instance)) - (persistent-slot-writer (get-con instance) new-value instance name))) - -#+(or cmu sbcl) -(defun make-persistent-slot-boundp (name) - (lambda (instance) - (declare (optimize (speed 3)) - (type persistent-object instance)) - (persistent-slot-boundp (get-con instance) instance name))) - -#+(or cmu sbcl) -(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition)) - (let ((name (slot-definition-name slot-def))) - (setf (slot-definition-reader-function slot-def) - (make-persistent-reader name)) - (setf (slot-definition-writer-function slot-def) - (make-persistent-writer name)) - (setf (slot-definition-boundp-function slot-def) - (make-persistent-slot-boundp name))) - slot-def) (defun persistent-slot-defs (class) (let ((slot-definitions (class-slots class))) @@ -374,4 +343,7 @@ (mapcar #'slot-definition-name (persistent-slot-defs class))) (defun transient-slot-names (class) - (mapcar #'slot-definition-name (transient-slot-defs class))) \ No newline at end of file + (mapcar #'slot-definition-name (transient-slot-defs class))) + + + From ieslick at common-lisp.net Wed Feb 22 21:03:48 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 15:03:48 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060222210348.4F82C2A03B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv18474/tests Modified Files: elephant-tests.lisp testindexing.lisp Log Message: Quick fix for config.lisp not having a package designator. Also my tweaks to fix a BDB bug, adding transacctions to btree writes for increased safety and various tweaks I made trying to fix the slot-boundp bug in indexing-redef-class --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/21 19:40:08 1.17 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/22 21:03:48 1.18 @@ -155,7 +155,6 @@ (print (do-test 'indexing-reconnect-db)) (print (do-test 'indexing-change-class)) (print (do-test 'indexing-redef-class)) - (print (do-test 'indexing-explicit-changes)) (print (do-test 'indexing-timing)))) (defun do-crazy-pg-tests() --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 20:18:54 1.9 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 21:03:48 1.10 @@ -47,12 +47,11 @@ (progn ;;(format t "Global vars:~%") ;;(format t "~%basic store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) - ;;(format t "auto-commit: ~A~%" *auto-commit*) +;; (format t "auto-commit: ~A~%" *auto-commit*) - (disable-class-indexing 'idx-one :errorp nil) - -;; Possibly under SBCL this really hoses things up! -;; (setf (find-class 'idx-one) nil) + (when (find-class 'idx-one nil) + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-one nil) nil)) (defclass idx-one () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) @@ -76,7 +75,7 @@ (deftest indexing-inherit (progn ;; (format t "inherit store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) - + (when (find-class 'idx-two nil) (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil) (setf (find-class 'idx-two) nil)) @@ -123,7 +122,7 @@ ;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) (when (find-class 'idx-four nil) (disable-class-indexing 'idx-four :errorp nil) - (setf (find-class 'idx-four) nil)) + (setf (find-class 'idx-four nil) nil)) (defclass idx-four () ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) @@ -166,8 +165,7 @@ (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) (:metaclass persistent-metaclass)) - (let ((*old-default* *default-indexed-class-synch-policy*) - (*default-indexed-class-synch-policy* :db)) + (let ((*default-indexed-class-synch-policy* :db)) (format t "connect store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) (with-transaction (:store-controller *store-controller*) @@ -250,6 +248,8 @@ (disable-class-indexing 'idx-eight :errorp nil) (setf (find-class 'idx-eight nil) nil)) +;; (format t "sc: ~A ct: ~A~%" *store-controller* *current-transaction*) + (defclass idx-eight () ((slot1 :accessor slot1 :initarg :slot1 :index t) (slot2 :accessor slot2 :initarg :slot2) @@ -268,8 +268,8 @@ ((slot1 :accessor slot1 :initarg :slot1 :initform 11) (slot2 :accessor slot2 :initarg :slot2 :initform 12 :index t) (slot3 :accessor slot3 :initarg :slot3 :initform 13) - (slot6 :accessor slot6 :initarg :slot6 :initform 14 :index t) - (slot7 :accessor slot7 :initarg :slot7)) + (slot7 :accessor slot7 :initarg :slot7) + (slot6 :accessor slot6 :initarg :slot6 :index t)) (:metaclass persistent-metaclass)) (values @@ -280,10 +280,13 @@ (eq (slot3 o1) 13) ;; transient values not preserved (would be inconsistent) (and (not (slot-exists-p o1 'slot4)) (not (slot-exists-p o1 'slot5)) - (signals-error (get-instances-by-value 'idx-eight 'slot4))) + (signals-error (get-instances-by-value 'idx-eight 'slot4 4))) (and (eq (slot6 o1) 14) (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) - (and (not (slot-boundp o1 'slot7)))))) + (and (slot-exists-p o1 'slot7) + (not (slot-boundp o1 'slot7))) + (and (slot-exists-p o2 'slot7) + (not (slot-boundp o2 'slot7)))))) t t t t t t) ;; create 500 objects, write each object's slots From ieslick at common-lisp.net Wed Feb 22 22:01:44 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 16:01:44 -0600 (CST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060222220144.D194263002@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv26639 Modified Files: TODO Log Message: Fixed a bug I introduced while exploring. Fixed some issues in testindexing that reduce failures. Please update if you're hacking on bug fixes. --- /project/elephant/cvsroot/elephant/TODO 2006/02/22 21:03:47 1.17 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/22 22:01:44 1.18 @@ -1,3 +1,6 @@ +Written support +Poster - vision + concrete value + Feb 6, 2006 Release plan in-discussion with Robert and Ian From ieslick at common-lisp.net Wed Feb 22 22:01:45 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 16:01:45 -0600 (CST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060222220145.0C8D363002@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory common-lisp:/tmp/cvs-serv26639/src/elephant Modified Files: classes.lisp Log Message: Fixed a bug I introduced while exploring. Fixed some issues in testindexing that reduce failures. Please update if you're hacking on bug fixes. --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 21:03:47 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 22:01:44 1.5 @@ -130,7 +130,7 @@ (setf (get-value oid class-index) instance)))) )))) -(defmethod update-instance-for-redefined-class ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) +(defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; NOTE: probably should delete discarded slots, but we'll worry about that later ;; (also will want to delete discarded indices since we don't have a good GC) (declare (ignore property-list discarded-slots added-slots)) From ieslick at common-lisp.net Wed Feb 22 22:01:45 2006 From: ieslick at common-lisp.net (ieslick) Date: Wed, 22 Feb 2006 16:01:45 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060222220145.5398C63002@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv26639/tests Modified Files: elephant-tests.lisp testindexing.lisp Log Message: Fixed a bug I introduced while exploring. Fixed some issues in testindexing that reduce failures. Please update if you're hacking on bug fixes. --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/22 21:03:48 1.18 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/22 22:01:45 1.19 @@ -80,7 +80,7 @@ '(:clsql (:postgresql "localhost.localdomain" "test" "postgres" ""))) (defvar *testsqlite3-spec* - '(:clsql (:sqlite3 "tests/sqlite3-test.db")) + '(:clsql (:sqlite3 "sqlite3-test.db")) "This is of the form '(filename &optional init-function),") (defvar *testsqlite3-memory-spec* --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 21:03:48 1.10 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 22:01:45 1.11 @@ -268,8 +268,8 @@ ((slot1 :accessor slot1 :initarg :slot1 :initform 11) (slot2 :accessor slot2 :initarg :slot2 :initform 12 :index t) (slot3 :accessor slot3 :initarg :slot3 :initform 13) - (slot7 :accessor slot7 :initarg :slot7) - (slot6 :accessor slot6 :initarg :slot6 :index t)) + (slot6 :accessor slot6 :initarg :slot6 :initform 14 :index t) + (slot7 :accessor slot7 :initarg :slot7)) (:metaclass persistent-metaclass)) (values @@ -283,11 +283,11 @@ (signals-error (get-instances-by-value 'idx-eight 'slot4 4))) (and (eq (slot6 o1) 14) (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) - (and (slot-exists-p o1 'slot7) + (and ;;(slot-exists-p o1 'slot7) (not (slot-boundp o1 'slot7))) - (and (slot-exists-p o2 'slot7) + (and ;;(slot-exists-p o2 'slot7) (not (slot-boundp o2 'slot7)))))) - t t t t t t) + t t t t t t t) ;; create 500 objects, write each object's slots From rread at common-lisp.net Thu Feb 23 14:41:13 2006 From: rread at common-lisp.net (rread) Date: Thu, 23 Feb 2006 08:41:13 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060223144113.1D86B6000D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv11586/tests Modified Files: testindexing.lisp Log Message: Tweak. --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/22 22:01:45 1.11 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/23 14:41:13 1.12 @@ -26,7 +26,7 @@ (deftest indexing-basic-trivial (progn - (disable-class-indexing 'idx-one :errorp nil) + (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil) (setf (find-class 'idx-one) nil) (defclass idx-one () From rread at common-lisp.net Thu Feb 23 14:42:16 2006 From: rread at common-lisp.net (rread) Date: Thu, 23 Feb 2006 08:42:16 -0600 (CST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060223144216.7083462003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv11608/tests Modified Files: MigrationTests.lisp Log Message: Matching the parameter names in this file --- /project/elephant/cvsroot/elephant/tests/MigrationTests.lisp 2006/02/05 23:46:41 1.1 +++ /project/elephant/cvsroot/elephant/tests/MigrationTests.lisp 2006/02/23 14:42:16 1.2 @@ -34,14 +34,16 @@ ;; use for the migration tests. ;; This this configuration for testing between BDB and SQL.... -(setq *test-path-primary* *testpg-path*) +(setq *test-path-primary* *testpg-spec*) ;; (setq *test-path-primary* *testsqlite3-path*) -(setq *test-path-secondary* *testdb-path*) +(setq *test-path-secondary* *testbdb-spec*) ;; This this configuration for testing from one BDB repository to another... -(setq *test-path-primary* *testdb-path*) +(setq *test-path-primary* *testbdb-spec*) ;; (setq *test-path-primary* *testsqlite3-path*) -(setq *test-path-secondary* *testdb-path2*) +(setq *test-path-secondary* *testbdb-spec2*) + +(do-migration-tests *testbdb-spec* *testbdb-spec2*) +(do-migration-tests *testbdb-spec2* *testpg-spec*) -(do-migrate-test-spec *test-path-primary*) From ieslick at common-lisp.net Sat Feb 25 17:04:56 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 25 Feb 2006 12:04:56 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060225170456.F0CB1762F4@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv29707 Modified Files: TODO Log Message: Exploring SBCL failures & incorporating Andrew Blumberg's SBCL MOP fix --- /project/elephant/cvsroot/elephant/TODO 2006/02/22 22:01:44 1.18 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/25 17:04:56 1.19 @@ -1,16 +1,15 @@ -Written support -Poster - vision + concrete value -Feb 6, 2006 +Feb 23, 2006 Release plan in-discussion with Robert and Ian -Upcoming release ideas. - -0.6.0 - Adding default class/slot indexing -- Resolve stubbed out slot-boundp bug in indexing-reconnect-db test (Ian) -- Finish CLSQL backend debug (Robert) -- Documentation update (Robert) +0.6.0 - Adding default class/slot indexing; modularize backends +Bugs (0 failures of test suite): +- Resolve stubbed out slot-boundp/MOP bug in indexing-reconnect-db test under SBCL +- Resolve SQL range query bug +Tasks: +- Documentation update +- Tutorial review 0.6.1 - performance, safety and portability @@ -19,7 +18,6 @@ - Verify that operations such as indexing are thread safe Stability ---------- - Review all the NOTE comments in the code - Remove build gensym warnings in sleepycat - Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) @@ -64,9 +62,6 @@ index without any secondary indices or indexed slots (Ian) - Add :inverse-reader to slot options to create a named method that indexes into objects based on slot values. Is this a GF or defun? Do we dispatch on class name or bake it in? -- On class change, new slots should have their initform values pushed - into the slot value as if the slot was being created the first time - (currently this doesn't happen) (Ian) Bugs: - anything else reported against 0.5.0/0.6.0 @@ -112,6 +107,11 @@ - A native BTree implementation in CommonLisp (prototype on Allegro's BTree implementation for ACache) +Resolved issues: +- On class change, new slots should have their initform values pushed + into the slot value as if the slot was being created the first time + (currently this doesn't happen) [fixed in 0.6.0-rc1] + Feb. 4, 2006 As of 0.5.0, we have seem to have a stable suite on From ieslick at common-lisp.net Sat Feb 25 17:04:57 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 25 Feb 2006 12:04:57 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060225170457.15BFD200A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv29707/src/elephant Modified Files: classes.lisp Log Message: Exploring SBCL failures & incorporating Andrew Blumberg's SBCL MOP fix --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/22 22:01:44 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/25 17:04:56 1.6 @@ -142,8 +142,7 @@ ;; Update new persistent slots, the others we get for free (same oid!) ;; Isn't this done by the default call-next-method? (apply #'shared-initialize instance new-persistent-slots initargs)) - ) - ) + )) (defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key) (let* ((old-class (class-of previous)) @@ -174,6 +173,7 @@ (remove-kv (oid previous) (find-class-index old-class))) (call-next-method))) + (defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." (declare (optimize (speed 3))) @@ -296,7 +296,18 @@ (type persistent-object instance)) (persistent-slot-boundp (get-con instance) instance name))) -#+(or cmu sbcl) +#+sbcl ;; CMU also? Old code follows... +(defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition)) + (let ((name (slot-definition-name slot-def))) + (setf (slot-definition-reader-function slot-def) + (make-persistent-reader name)) + (setf (slot-definition-writer-function slot-def) + (make-persistent-writer name)) + (setf (slot-definition-boundp-function slot-def) + (make-persistent-slot-boundp name))) + (call-next-method)) ;; slot-def) + +#+cmu (defmethod initialize-internal-slot-functions ((slot-def persistent-slot-definition)) (let ((name (slot-definition-name slot-def))) (setf (slot-definition-reader-function slot-def) From ieslick at common-lisp.net Sat Feb 25 20:53:57 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 25 Feb 2006 15:53:57 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20060225205357.28D3BA0E7@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv26146/src/db-clsql Modified Files: sql-controller.lisp Log Message: Fixed indexing bugs and SQL backend secondary index abstraction --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/22 20:18:51 1.7 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/02/25 20:53:57 1.8 @@ -154,10 +154,12 @@ ;; This is a slow, DB cycle intensive operation. It could chunked somehow, ;; I think, probably making it 10 times faster. (when index? - (sql-add-to-clcn (oid index) - secondary-key - k - sc con :insert-only t) + (unless (sql-from-clcn-key-and-value-existsp + (oid index) secondary-key k con) + (sql-add-to-clcn (oid index) + secondary-key + k + sc con :insert-only t)) ))) bt)))) index) @@ -175,10 +177,13 @@ (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? - (sql-add-to-clcn (oid index) - secondary-key - key - sc con :insert-only t) + ;; This duplicates values that are already there... + (unless (sql-from-clcn-key-and-value-existsp + (oid index) secondary-key key con) + (sql-add-to-clcn (oid index) + secondary-key + key + sc con :insert-only t)) ))) indices) ;; Now we place the actual value @@ -475,6 +480,20 @@ nil) )) + +(defun sql-from-clcn-key-and-value-existsp (clcn key value con) + (assert (integerp clcn)) + (let* ((kbs (serialize-to-base64-string key)) + (vbs (serialize-to-base64-string value)) + (tuples (clsql::select [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs] + [= [value] vbs]] + :database con))) + (if tuples + t + nil))) + (defun sql-remove-from-root (key sc con) (sql-remove-from-clcn 0 key sc con) ) From ieslick at common-lisp.net Sat Feb 25 20:53:57 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 25 Feb 2006 15:53:57 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060225205357.68189A0E6@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv26146/src/elephant Modified Files: classes.lisp classindex.lisp metaclasses.lisp Log Message: Fixed indexing bugs and SQL backend secondary index abstraction --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/25 17:04:56 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/02/25 20:53:57 1.7 @@ -20,7 +20,6 @@ (defvar *debug-si* nil) - (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid @@ -68,10 +67,35 @@ (when (not (slot-boundp instance '%indexed-slots)) (update-indexed-record instance (indexed-slot-names-from-defs instance))))) +(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) + (prog1 + (call-next-method) + (when (class-finalized-p instance) + (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (if (removed-indexing? instance) + (progn + (let ((class-idx (get-value (class-name instance) (controller-class-root *store-controller*)))) + (when class-idx + (wipe-class-indexing instance class-idx))) + (setf (%index-cache instance) nil)) + (set-db-synch instance :class)) + #+allegro + (loop with persistent-slots = (persistent-slots instance) + for slot-def in (class-direct-slots instance) + when (member (slot-definition-name slot-def) persistent-slots) + do (initialize-accessors slot-def instance)) + (make-instances-obsolete instance)))) + ;; ================================================ ;; PERSISTENT OBJECT MAINTENANCE ;; ================================================ +;; +;; CLASS INSTANCE INITIALIZATION +;; + (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key from-oid &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for @@ -90,45 +114,51 @@ (transient-slot-names class) (remove-if #'persistent-slot-p slot-names))) (persistent-slot-inits - (if (eq slot-names t) persistent-slot-names + (if (eq slot-names t) + persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) (inhibit-indexing oid) (unwind-protect - ;; initialize the persistent slots - (flet ((initialize-from-initarg (slot-def) - (loop for initarg in initargs - with slot-initargs = (slot-definition-initargs slot-def) - when (member initarg slot-initargs :test #'eq) - do - (setf (slot-value-using-class class instance slot-def) - (getf initargs initarg)) - (return t)))) - (with-transaction (:store-controller (get-con instance)) - (loop for slot-def in (class-slots class) - unless (initialize-from-initarg slot-def) - when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq) - unless (slot-boundp-using-class class instance slot-def) - do - (let ((initfun (slot-definition-initfunction slot-def))) - (when initfun - (setf (slot-value-using-class class instance slot-def) - (funcall initfun)))))) -;; (format t "transient-slot-inits ~A~%" transient-slot-inits) -;; (format t "indices boundp ~A~%" (slot-boundp instance 'indices)) -;; (format t "indices-caches boundp ~A~%" (slot-boundp instance 'indices-cache)) - ;; let the implementation initialize the transient slots - (apply #'call-next-method instance transient-slot-inits initargs)) + (progn + ;; initialize the persistent slots ourselves + (initialize-persistent-slots class instance persistent-slot-inits initargs) + ;; let the implementation initialize the transient slots + (apply #'call-next-method instance transient-slot-inits initargs)) (uninhibit-indexing oid)) - ;; Inhibit indexing altogether if the object already was defined (ie being created - ;; from an oid) as it should be indexed already. This hack avoids a deadlock - ;; situation where we write the class or index page that we are currently reading - ;; via a cursor without going through the cursor abstraction. There has to be a - ;; better way to do this. - (when (and (indexed class) (not from-oid)) - (let ((class-index (find-class-index class))) - (when class-index - (setf (get-value oid class-index) instance)))) - )))) + ;; Inhibit indexing altogether if the object already was defined (ie being created + ;; from an oid) as it should be indexed already. This hack avoids a deadlock + ;; situation where we write the class or index page that we are currently reading + ;; via a cursor without going through the cursor abstraction. There has to be a + ;; better way to do this. + (when (and (indexed class) (not from-oid)) + (let ((class-index (find-class-index class))) + (when class-index + (setf (get-value oid class-index) instance)))) + )))) + +(defun initialize-persistent-slots (class instance persistent-slot-inits initargs) + (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-transaction (:store-controller (get-con instance)) + (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)))))))) + +;; +;; CLASS REDEFINITION PROTOCOL +;; (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; NOTE: probably should delete discarded slots, but we'll worry about that later @@ -144,6 +174,10 @@ (apply #'shared-initialize instance new-persistent-slots initargs)) )) +;; +;; CLASS CHANGE PROTOCOL +;; + (defmethod update-instance-for-different-class :around ((previous persistent) (current persistent) &rest initargs &key) (let* ((old-class (class-of previous)) (new-class (class-of current)) @@ -174,6 +208,10 @@ (call-next-method))) +;; +;; SLOT ACCESS PROTOCOLS +;; + (defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." (declare (optimize (speed 3))) @@ -256,21 +294,6 @@ (loop for writer in writers do (make-persistent-writer writer slot-definition class class-name)))) -#+allegro -(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (prog1 - (call-next-method) - (when (class-finalized-p instance) - (update-persistent-slots instance (persistent-slot-names instance)) - (update-indexed-record instance (indexed-slot-names-from-defs instance)) - (set-db-synch instance :class) - (loop with persistent-slots = (persistent-slots instance) - for slot-def in (class-direct-slots instance) - when (member (slot-definition-name slot-def) persistent-slots) - do (initialize-accessors slot-def instance)) - (make-instances-obsolete instance)))) - ;; ;; CMU / SBCL ;; @@ -318,15 +341,3 @@ (make-persistent-slot-boundp name))) slot-def) -#+(or cmu sbcl openmcl) -(defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) - (declare (ignore initargs)) - (prog1 - (call-next-method) - (when (class-finalized-p instance) - (update-persistent-slots instance (persistent-slot-names instance)) - (update-indexed-record instance (indexed-slot-names-from-defs instance)) - (set-db-synch instance :class) -;; (initialize-internal-slot-functions - (make-instances-obsolete instance)))) - --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/22 20:18:51 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/02/25 20:53:57 1.5 @@ -175,12 +175,14 @@ ;; ============================= (defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*)) + (assert (not (= 0 (length indexed-slot-names)))) (let ((croot (controller-class-root sc))) (multiple-value-bind (btree found) (get-value (class-name class) croot) (declare (ignore btree)) (when found (error "Class is already enabled for indexing! Run disable class indexing to clean up."))) ;; Put class instance index into the class root & cache it in the class object + (update-indexed-record class indexed-slot-names) (with-transaction (:store-controller sc) (let ((class-idx (build-indexed-btree sc))) (setf (get-value (class-name class) croot) class-idx) @@ -200,31 +202,40 @@ (disable-class-indexing class :sc sc)))) (defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp nil)) + "Disable any class indices from the database, even if the current class object is not + officially indexed. This ensures there is no persistent trace of a class index. Storage + is reclaimed also" (let ((class-idx (find-class-index class :sc sc :errorp errorp))) - (unless class-idx (return-from disable-class-indexing nil)) - ;; Remove all instance key/value data from the class index (& secondary indices) - (with-transaction (:store-controller sc) - (with-btree-cursor (cur class-idx) - (when (cursor-first cur) - (loop while (cursor-delete cur))))) - ;; Get the names of all indices & remove them - (let ((names nil)) - (map-indices (lambda (name secondary-index) - (declare (ignore secondary-index)) - (push name names)) - class-idx) - (dolist (name names) - (if (member name (class-slots class)) - (remove-class-slot-index class name) - (with-transaction (:store-controller sc) - (remove-index class-idx name))))) - ;; Drop the class instance index from the class root - (with-transaction (:store-controller sc) - (remove-kv (class-name class) (controller-class-root sc))) - (setf (%index-cache class) nil) - ;; Clear out the current class - (update-indexed-record class nil) - )) + (if class-idx + (progn + (wipe-class-indexing class class-idx :sc sc) + (update-indexed-record class nil)) + (when errorp + (error "No class index exists in persistent store ~A" sc) + (return-from disable-class-indexing nil))))) + +(defmethod wipe-class-indexing ((class persistent-metaclass) class-idx &key (sc *store-controller*)) + ;; Clear out the current class record + (with-transaction (:store-controller sc) + (with-btree-cursor (cur class-idx) + (when (cursor-first cur) + (loop while (cursor-delete cur))))) + ;; Get the names of all indices & remove them + (let ((names nil)) + (map-indices (lambda (name secondary-index) + (declare (ignore secondary-index)) + (push name names)) + class-idx) + (dolist (name names) + (if (member name (class-slots class)) + (remove-class-slot-index class name) + (with-transaction (:store-controller sc) + (remove-index class-idx name))))) + ;; Drop the class instance index from the class root + (with-transaction (:store-controller sc) + (remove-kv (class-name class) (controller-class-root sc))) + (setf (%index-cache class) nil) + ) (defmethod add-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) (add-class-slot-index (find-class class) slot-name :sc sc)) --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/22 21:03:47 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/25 20:53:57 1.5 @@ -116,11 +116,14 @@ (defmethod indexed-record ((class standard-class)) nil) + (defmethod indexed-record ((class persistent-metaclass)) - (car (%indexed-slots class))) + (when (slot-boundp class '%indexed-slots) + (car (%indexed-slots class)))) (defmethod old-indexed-record ((class persistent-metaclass)) - (cdr (%indexed-slots class))) + (when (slot-boundp class '%indexed-slots) + (cdr (%indexed-slots class)))) (defmethod update-indexed-record ((class persistent-metaclass) new-slot-list) (let ((oldrec (if (slot-boundp class '%indexed-slots) @@ -132,6 +135,10 @@ :derived (when oldrec (indexing-record-derived oldrec))) (if oldrec oldrec nil))))) +(defmethod removed-indexing? ((class persistent-metaclass)) + (and (not (indexed class)) + (previously-indexed class))) + (defun indexed-slot-names-from-defs (class) (let ((slot-definitions (class-slots class))) (loop for slot-definition in slot-definitions @@ -188,6 +195,14 @@ (or (indexing-record-slots (indexed-record class)) (indexing-record-derived (indexed-record class))))) +(defmethod previously-indexed ((class persistent-metaclass)) + (and (slot-boundp class '%indexed-slots) + (not (null (%indexed-slots class))) + (let ((old (old-indexed-record class))) + (when (not (null old)) + (or (indexing-record-slots old) + (indexing-record-derived old)))))) + (defmethod indexed ((slot standard-slot-definition)) nil) (defmethod indexed ((class standard-class)) nil) From ieslick at common-lisp.net Sat Feb 25 20:53:57 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 25 Feb 2006 15:53:57 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060225205357.9A9EAF28D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv26146/tests Modified Files: testindexing.lisp Log Message: Fixed indexing bugs and SQL backend secondary index abstraction --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/23 14:41:13 1.12 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/25 20:53:57 1.13 @@ -151,10 +151,33 @@ ) t t t) -(deftest indexing-reconnect-db +(deftest indexing-wipe-index (progn - (format t "connect store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) + (when (find-class 'idx-five-del nil) + (disable-class-indexing 'idx-five :errorp nil) + (setf (find-class 'idx-five) nil)) + + (defclass idx-five-del () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) + (:metaclass persistent-metaclass)) + + (with-transaction (:store-controller *store-controller*) + (make-instance 'idx-five-del)) + + (let ((r1 (get-instances-by-value 'idx-five-del 'slot1 1))) + (defclass idx-five-del () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1)) + (:metaclass persistent-metaclass)) + + (values + (eq (length r1) 1) + (signals-error (get-instances-by-value 'idx-five-del 'slot1 1)) + (null (get-value 'idx-five-del (elephant::controller-class-root *store-controller*)))))) + t t t) + +(deftest indexing-reconnect-db + (progn (when (find-class 'idx-five nil) (disable-class-indexing 'idx-five :errorp nil) (setf (find-class 'idx-five) nil)) @@ -166,8 +189,6 @@ (:metaclass persistent-metaclass)) (let ((*default-indexed-class-synch-policy* :db)) - - (format t "connect store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) (with-transaction (:store-controller *store-controller*) (make-instance 'idx-five)) @@ -281,13 +302,13 @@ (and (not (slot-exists-p o1 'slot4)) (not (slot-exists-p o1 'slot5)) (signals-error (get-instances-by-value 'idx-eight 'slot4 4))) - (and (eq (slot6 o1) 14) - (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) + (eq (slot6 o1) 14) + (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) (and ;;(slot-exists-p o1 'slot7) (not (slot-boundp o1 'slot7))) (and ;;(slot-exists-p o2 'slot7) (not (slot-boundp o2 'slot7)))))) - t t t t t t t) + t t t t t t t t) ;; create 500 objects, write each object's slots From ieslick at common-lisp.net Sat Feb 25 22:05:08 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 25 Feb 2006 17:05:08 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060225220508.F1E9119004@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv3222 Modified Files: metaclasses.lisp Log Message: A patch caused by a stale file in my buffer --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/25 20:53:57 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/02/25 22:05:08 1.6 @@ -192,6 +192,7 @@ (defmethod indexed ((class persistent-metaclass)) (and (slot-boundp class '%indexed-slots ) + (not (null (%indexed-slots class))) (or (indexing-record-slots (indexed-record class)) (indexing-record-derived (indexed-record class))))) From ieslick at common-lisp.net Sat Feb 25 22:06:13 2006 From: ieslick at common-lisp.net (ieslick) Date: Sat, 25 Feb 2006 17:06:13 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20060225220613.B24EE23007@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv3702 Modified Files: TODO Log Message: Update the TODO list --- /project/elephant/cvsroot/elephant/TODO 2006/02/25 17:04:56 1.19 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/25 22:06:13 1.20 @@ -4,10 +4,6 @@ Release plan in-discussion with Robert and Ian 0.6.0 - Adding default class/slot indexing; modularize backends -Bugs (0 failures of test suite): -- Resolve stubbed out slot-boundp/MOP bug in indexing-reconnect-db test under SBCL -- Resolve SQL range query bug -Tasks: - Documentation update - Tutorial review From rread at common-lisp.net Mon Feb 27 16:49:49 2006 From: rread at common-lisp.net (rread) Date: Mon, 27 Feb 2006 11:49:49 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20060227164949.2E91E50005@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv14083/tests Modified Files: testindexing.lisp Log Message: Apparently a misplaced parenthesis... --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/25 20:53:57 1.13 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/27 16:49:49 1.14 @@ -269,8 +269,7 @@ (disable-class-indexing 'idx-eight :errorp nil) (setf (find-class 'idx-eight nil) nil)) -;; (format t "sc: ~A ct: ~A~%" *store-controller* *current-transaction*) - + ;; (format t "sc: ~A ct: ~A~%" *store-controller* *current-transaction*) (defclass idx-eight () ((slot1 :accessor slot1 :initarg :slot1 :index t) (slot2 :accessor slot2 :initarg :slot2) @@ -303,11 +302,11 @@ (not (slot-exists-p o1 'slot5)) (signals-error (get-instances-by-value 'idx-eight 'slot4 4))) (eq (slot6 o1) 14) - (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) + (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2) (and ;;(slot-exists-p o1 'slot7) - (not (slot-boundp o1 'slot7))) + (not (slot-boundp o1 'slot7))) (and ;;(slot-exists-p o2 'slot7) - (not (slot-boundp o2 'slot7)))))) + (not (slot-boundp o2 'slot7)))))) t t t t t t t t) ;; create 500 objects, write each object's slots