Commits

Anonymous committed 126c67f

merged in a contribution from randall randall: you can now create indexes on slots using index-on (or delete them using drop-index-on) and query using those indexes using find-object-with-slot

Comments (0)

Files changed (3)

src/managed-prevalence.lisp

   (let ((classname (if (symbolp class) (string class) (class-name class))))
     (intern (concatenate 'string classname "-ROOT") :keyword)))
 
-(defun get-objects-index-root-name (class)
-  "Return the keyword symbol naming the id index of instances of class"
-  (let ((classname (if (symbolp class) (string class) (class-name class))))
-    (intern (concatenate 'string classname "-ID-INDEX") :keyword)))
+(defun get-objects-slot-index-name (class &optional (slot 'id))
+  "Return the keyword symbol naming the specified index of instances of class."
+  (let ((classname (if (symbolp class) (string class) (class-name class)))
+        (slotname  (symbol-name slot)))
+    (intern (concatenate 'string classname "-" slotname "-INDEX") :keyword)))
 
 (defgeneric find-all-objects (system class)
   (:documentation "Return an unordered collection of all objects in system that are instances of class"))
 
 (defmethod find-object-with-id ((system prevalence-system) class id)
   "Find and return the object in system of class with id, null if not found"
-  (let* ((index-name (get-objects-index-root-name class))
+  (let* ((index-name (get-objects-slot-index-name class 'id))
 	 (index (get-root-object system index-name)))
     (when index
       (gethash id index))))
 
-(defun set-slot-values (instance slots-and-values)
-  "Set slots and values of instance"
-  (dolist (slot-and-value slots-and-values instance)
-    (setf (slot-value instance (first slot-and-value)) (second slot-and-value))))
+(defgeneric find-object-with-slot (system class slot value)
+  (:documentation "Find and return the object in system of class with slot, null if not found"))
 
-(defun tx-create-object (system &optional class slots-and-values)
+(defmethod find-object-with-slot ((system prevalence-system) class slot value)
+  "Find and return the object in system of class with slot, null if not found.
+   This constitutes some duplicated effort with FIND-OBJECT-WITH-ID."
+  (let* ((index-name (get-objects-slot-index-name class slot))
+	 (index (get-root-object system index-name)))
+    (when index
+      (find-object-with-id system class (gethash value index)))))
+
+(defun tx-create-objects-slot-index (system class slot &optional (test 'equalp))
+  "Create an index for this object on this slot, with an optional test for the hash table (add existing objects)"
+  (let ((index-name (get-objects-slot-index-name class slot)))
+    (unless (get-root-object system index-name)
+      (let ((index (make-hash-table :test test)))
+        (setf (get-root-object system index-name) index)
+        (dolist (object (find-all-objects system class))
+          (add-object-to-slot-index system class slot object))))))
+  
+(defun tx-remove-objects-slot-index (system class slot)
+  "Remove an index for this object on this slot"
+  (let ((index-name (get-objects-slot-index-name class slot)))
+    (unless (get-root-object system index-name)
+      (remove-root-object system index-name))))
+
+(defun add-object-to-slot-index (system class slot object)
+  "Add an index entry using this slot to this object"
+  (let* ((index-name (get-objects-slot-index-name class slot))
+	 (index (get-root-object system index-name)))
+    (when (and index  (slot-boundp object slot))
+      (setf (gethash (slot-value object slot) index) (get-id object)))))
+
+(defun remove-object-from-slot-index (system class slot object)
+  "Remove the index entry using this slot to this object"
+  (let* ((index-name (get-objects-slot-index-name class slot))
+	 (index (get-root-object system index-name)))
+    (when (and index (slot-boundp object slot))
+      (remhash (slot-value object slot) index))))
+
+(defun index-on (system class &optional slots (test 'equalp))
+  "Create indexes on each of the slots provided."
+  (dolist (slot slots)
+    (execute-transaction (tx-create-objects-slot-index system class slot test))))
+
+(defun drop-index-on (system class &optional slots)
+  "Drop indexes on each of the slots provided"
+  (dolist (slot slots)
+    (execute-transaction (tx-remove-objects-slot-index system class slot))))
+
+(defun slot-value-changed-p (object slot value)
+  "Return true when slot in object is not eql to value (or when the slot was unbound)"
+  (or (not (slot-boundp object slot))
+      (not (eql (slot-value object slot) value)))) 
+
+(defun tx-create-object (system class &optional slots-and-values)
   "Create a new object of class in system, assigning it a unique id, optionally setting some slots and values"
   (let* ((id (next-id system))
 	 (object (make-instance class :id id))
-	 (index-name (get-objects-index-root-name class))
+	 (index-name (get-objects-slot-index-name class 'id))
 	 (index (or (get-root-object system index-name)
 		    (setf (get-root-object system index-name) (make-hash-table)))))
-    (set-slot-values object slots-and-values)
     (push object (get-root-object system (get-objects-root-name class)))
-    (setf (gethash id index) object)))
+    (setf (gethash id index) object)
+    (tx-change-object-slots system class id slots-and-values)
+    object))
 
 (defun tx-delete-object (system class id)
-  "Delete the object of class with if from the system"
+  "Delete the object of class with id from the system"
   (let ((object (find-object-with-id system class id)))
     (if object
 	(let ((root-name (get-objects-root-name class))
-	      (index-name (get-objects-index-root-name class)))
+	      (index-name (get-objects-slot-index-name class 'id)))
 	  (setf (get-root-object system root-name) (delete object (get-root-object system root-name)))
 	  (remhash id (get-root-object system index-name)))
       (error "no object of class ~a with id ~d found in ~s" system class id))))
 (defun tx-change-object-slots (system class id slots-and-values)
   "Change some slots of the object of class with id in system using slots and values"
   (let ((object (find-object-with-id system class id)))
-    (if object
-	(set-slot-values object slots-and-values)
-      (error "no object of class ~a with id ~d found in ~s" system class id))))
-
+    (unless object (error "no object of class ~a with id ~d found in ~s" system class id))
+    (loop :for (slot value) :in slots-and-values
+          :do (when (slot-value-changed-p object slot value)
+                (remove-object-from-slot-index system class slot object)
+                (setf (slot-value object slot) value)
+                (add-object-to-slot-index system class slot object)))))
+                
 ;; We use a simple id counter to generate unique object identifiers
 
 (defun tx-create-id-counter (system)

test/test-managed-prevalence.lisp

+;;;; -*- mode: Lisp -*-
+;;;;
+;;;; $Id$
+;;;;
+;;;; Testing Managed Object Prevalence in Common Lisp
+;;;;
+;;;; Copyright (C) 2003, 2004 Sven Van Caekenberghe, Beta Nine BVBA.
+;;;; Altered for managed prevalence testing; Sept 2004, 
+;;;;  Randall Randall, RandallSquared
+;;;;
+;;;; You are granted the rights to distribute and use this software
+;;;; as governed by the terms of the Lisp Lesser General Public License
+;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
+
+(in-package :cl-prevalence)
+
+(defparameter *test-system-directory* (pathname "/tmp/test-managed-prevalence-system/"))
+
+(defvar *test-system* nil)
+
+;; Create a new prevalence system for testing purposes
+
+(let ((directory *test-system-directory*))
+  ;; Throw away any xml files that we find: we want to start from scratch
+  (when (probe-file directory)
+    (dolist (pathname (directory (merge-pathnames "*.xml" directory)))
+      (delete-file pathname)))
+  (setf *test-system* (make-prevalence-system directory)))
+
+;; A Test CLOS class
+
+(defclass person (object-with-id)
+  ((firstname :initarg :firstname :initform "" :accessor get-firstname)
+   (lastname  :initarg :lastname  :initform "" :accessor get-lastname)))
+
+(defmethod (setf get-firstname) (value (person person))
+  (execute-transaction 
+   (tx-change-object-slots *test-system* 'person (get-id person) (list (list 'firstname value)))))
+
+(defmethod (setf get-lastname) (value (person person))
+  (execute-transaction 
+   (tx-change-object-slots *test-system* 'person (get-id person) (list (list 'lastname value)))))
+
+(index-on *test-system* 'person '(firstname lastname) 'equal)
+
+;; convenience function
+
+(defun pairify (list)
+  (when list (concatenate 'list 
+                          (list (subseq list 0 2)) 
+                          (pairify (rest (rest list))))))
+
+;; Some basic functions to construct transactions from
+
+(defun make-person (&rest slots)
+  (let ((slots-and-values (pairify slots)))
+    (execute-transaction 
+     (tx-create-object *test-system* 'person slots-and-values))))
+
+(defun find-person (slot value)
+  (find-object-with-slot *test-system* 'person slot value))
+
+(defun delete-person (person)
+  (execute-transaction 
+   (tx-delete-object *test-system* 'person (get-id person))))
+
+;; Create a new id counter
+
+(execute-transaction (tx-create-id-counter *test-system*))
+
+(assert (zerop (get-root-object *test-system* :id-counter)))
+
+;; A place to store our test person's id outside of the system
+
+(defvar *jlp*)
+
+;; Create a new test person
+
+(let ((person (make-person 'firstname "Jean-Luc" 'lastname "Picard")))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard"))
+  (assert (equal (get-lastname (find-person 'firstname "Jean-Luc")) "Picard"))
+  (setf (get-firstname (find-person 'lastname "Picard")) "J-Lu")
+  (assert (equal (get-lastname (find-person 'firstname "J-Lu")) "Picard"))
+  (setf (get-firstname (find-person 'firstname "J-Lu")) "Jean-Luc")
+  (assert (equal (get-firstname (find-person 'lastname "Picard")) "Jean-Luc"))
+  (assert (eq NIL (find-person 'firstname "J-Lu")))
+  (setf *jlp* (get-id person)))
+
+(let ((person (find-object-with-id *test-system* 'person *jlp*)))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard"))
+  (assert (equal (get-lastname (find-person 'firstname "Jean-Luc")) "Picard"))
+  (setf (get-firstname (find-person 'lastname "Picard")) "J-Lu")
+  (assert (equal (get-lastname (find-person 'firstname "J-Lu")) "Picard"))
+  (setf (get-firstname (find-person 'firstname "J-Lu")) "Jean-Luc")
+  (assert (equal (get-firstname (find-person 'lastname "Picard")) "Jean-Luc"))
+  (assert (eq NIL (find-person 'firstname "J-Lu"))))
+
+;; Throw away the previous prevalence instance and start over,
+;; counting on a restore operation using the transaction log
+
+(close-open-streams *test-system*)
+(setf *test-system* (make-prevalence-system *test-system-directory*))
+
+(let ((person (find-object-with-id *test-system* 'person *jlp*)))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard"))
+  (assert (equal (get-lastname (find-person 'firstname "Jean-Luc")) "Picard"))
+  (setf (get-firstname (find-person 'lastname "Picard")) "J-Lu")
+  (assert (equal (get-lastname (find-person 'firstname "J-Lu")) "Picard"))
+  (setf (get-firstname (find-person 'firstname "J-Lu")) "Jean-Luc")
+  (assert (equal (get-firstname (find-person 'lastname "Picard")) "Jean-Luc"))
+  (assert (eq NIL (find-person 'firstname "J-Lu"))))
+
+;; Create a snapshot of our test system
+
+(snapshot *test-system*)
+
+(let ((person (find-object-with-id *test-system* 'person *jlp*)))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard"))
+  (assert (equal (get-lastname (find-person 'firstname "Jean-Luc")) "Picard"))
+  (setf (get-firstname (find-person 'lastname "Picard")) "J-Lu")
+  (assert (equal (get-lastname (find-person 'firstname "J-Lu")) "Picard"))
+  (setf (get-firstname (find-person 'firstname "J-Lu")) "Jean-Luc")
+  (assert (equal (get-firstname (find-person 'lastname "Picard")) "Jean-Luc"))
+  (assert (eq NIL (find-person 'firstname "J-Lu"))))
+
+;; Throw away the previous prevalence instance and start over,
+;; counting on a restore operation using the snapshot
+
+(close-open-streams *test-system*)
+(setf *test-system* (make-prevalence-system *test-system-directory*))
+
+(let ((person (find-object-with-id *test-system* 'person *jlp*)))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard"))
+  (assert (equal (get-lastname (find-person 'firstname "Jean-Luc")) "Picard"))
+  (setf (get-firstname (find-person 'lastname "Picard")) "J-Lu")
+  (assert (equal (get-lastname (find-person 'firstname "J-Lu")) "Picard"))
+  (setf (get-firstname (find-person 'firstname "J-Lu")) "Jean-Luc")
+  (assert (equal (get-firstname (find-person 'lastname "Picard")) "Jean-Luc"))
+  (assert (eq NIL (find-person 'firstname "J-Lu"))))
+
+;; Create another test person
+
+(defvar *kj*)
+
+(let ((person (make-person 'firstname "Kathryn" 'lastname "Janeway")))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Kathryn"))
+  (assert (equal (get-lastname person) "Janeway"))
+  (assert (equal (get-firstname (find-person 'lastname "Janeway")) "Kathryn"))
+  (assert (equal (get-lastname (find-person 'firstname "Kathryn")) "Janeway"))
+  (setf *kj* (get-id person)))
+
+(let ((person (find-object-with-id *test-system* 'person *kj*)))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Kathryn"))
+  (assert (equal (get-lastname person) "Janeway"))
+  (assert (equal (get-firstname (find-person 'lastname "Janeway")) "Kathryn"))
+  (assert (equal (get-lastname (find-person 'firstname "Kathryn")) "Janeway")))
+
+;; Throw away the previous prevalence instance and start over,
+;; counting on a restore operation using both the snapshot and the transaction log
+
+(close-open-streams *test-system*)
+(setf *test-system* (make-prevalence-system *test-system-directory*))
+
+(let ((person (find-object-with-id *test-system* 'person *jlp*)))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Jean-Luc"))
+  (assert (equal (get-lastname person) "Picard"))
+  (assert (equal (get-lastname (find-person 'firstname "Jean-Luc")) "Picard"))
+  (setf (get-firstname (find-person 'lastname "Picard")) "J-Lu")
+  (assert (equal (get-lastname (find-person 'firstname "J-Lu")) "Picard"))
+  (setf (get-firstname (find-person 'firstname "J-Lu")) "Jean-Luc")
+  (assert (equal (get-firstname (find-person 'lastname "Picard")) "Jean-Luc"))
+  (assert (eq NIL (find-person 'firstname "J-Lu"))))
+
+(let ((person (find-object-with-id *test-system* 'person *kj*)))
+  (assert (eq (class-of person) (find-class 'person)))
+  (assert (equal (get-firstname person) "Kathryn"))
+  (assert (equal (get-lastname person) "Janeway"))
+  (assert (equal (get-firstname (find-person 'lastname "Janeway")) "Kathryn"))
+  (assert (equal (get-lastname (find-person 'firstname "Kathryn")) "Janeway")))
+
+(mapcar #'(lambda (pair)
+           (make-person 'firstname (first pair) 'lastname (second pair)))
+	'(("Benjamin" "Sisko") ("James T." "Kirk") ("Jonathan" "Archer")))
+
+(assert (= (length (find-all-objects *test-system* 'person)) 5))
+
+
+;;; testing a guarded prevalence system
+;;; [Not sure that we need the below test here -- RRR]
+
+(defvar *guard*)
+
+(defun guard (thunk)
+  (setf *guard* t)
+  (funcall thunk))
+
+(close-open-streams *test-system*)
+(setf *test-system* (make-prevalence-system *test-system-directory* 
+                                            :prevalence-system-class 'guarded-prevalence-system))
+(setf (get-guard *test-system*) #'guard)
+
+(let (new-person)
+  (setf *guard* nil)
+  (setf new-person (make-person 'firstname "John" 'lastname "Doe"))
+  (assert *guard*)
+  (setf *guard* nil)
+  (delete-person new-person)
+  (assert *guard*))
+
+;;; eof

test/test-prevalence.lisp

 
 ;; Some basic functions to construct transactions from
 
-(defun tx-create-id-counter (system)
-  (setf (get-root-object system :id-counter) 0))
-
-(defun tx-get-next-id (system)
-  (incf (get-root-object system :id-counter)))
-
 (defun tx-create-persons-root (system)
   (setf (get-root-object system :persons) (make-hash-table)))