From scaekenberghe at common-lisp.net  Mon Oct  4 13:46:01 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 04 Oct 2004 15:46:01 +0200
Subject: [cl-prevalence-cvs] CVS update:
	cl-prevalence/src/serialization.lisp 
Message-ID: <E1CETA9-0004o5-00@common-lisp.net>

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv17983/src

Modified Files:
	serialization.lisp 
Log Message:
bugfix: serialization of an empty string is <string></string> but
deserialization of that XML construct was NIL which is not a string
we now return an empty string in that case
thanks to randall randall

Date: Mon Oct  4 15:45:57 2004
Author: scaekenberghe

Index: cl-prevalence/src/serialization.lisp
diff -u cl-prevalence/src/serialization.lisp:1.2 cl-prevalence/src/serialization.lisp:1.3
--- cl-prevalence/src/serialization.lisp:1.2	Tue Jun 22 10:37:23 2004
+++ cl-prevalence/src/serialization.lisp	Mon Oct  4 15:45:56 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: serialization.lisp,v 1.2 2004/06/22 08:37:23 scaekenberghe Exp $
+;;;; $Id: serialization.lisp,v 1.3 2004/10/04 13:45:56 scaekenberghe Exp $
 ;;;;
 ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS
 ;;;;
@@ -435,7 +435,7 @@
 	  ((:float :ratio :complex :symbol) (read-from-string seed))
 	  (:null nil)
 	  (:true t)
-	  (:string seed)
+	  (:string (or seed ""))
 	  (:key (car seed))
 	  (:value (car seed))
 	  (:entry (nreverse seed))




From scaekenberghe at common-lisp.net  Mon Oct  4 14:25:14 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 04 Oct 2004 16:25:14 +0200
Subject: [cl-prevalence-cvs] CVS update: cl-prevalence/src/package.lisp
	cl-prevalence/src/prevalence.lisp
	cl-prevalence/src/serialization.lisp 
Message-ID: <E1CETm6-0005Pb-00@common-lisp.net>

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv20795/src

Modified Files:
	package.lisp prevalence.lisp serialization.lisp 
Log Message:
added reset-class-slots

Date: Mon Oct  4 16:25:13 2004
Author: scaekenberghe

Index: cl-prevalence/src/package.lisp
diff -u cl-prevalence/src/package.lisp:1.4 cl-prevalence/src/package.lisp:1.5
--- cl-prevalence/src/package.lisp:1.4	Mon Jun 28 13:57:30 2004
+++ cl-prevalence/src/package.lisp	Mon Oct  4 16:25:13 2004
@@ -1,6 +1,6 @@
 ;;;; -*- Mode: LISP -*-
 ;;;;
-;;;; $Id: package.lisp,v 1.4 2004/06/28 11:57:30 scaekenberghe Exp $
+;;;; $Id: package.lisp,v 1.5 2004/10/04 14:25:13 scaekenberghe Exp $
 ;;;;
 ;;;; Package definitions for the CL-PREVALENCE project
 ;;;;
@@ -16,7 +16,8 @@
    #:serializable-slots
    #:serialize-xml #:serialize-sexp
    #:deserialize-xml #:deserialize-sexp
-   #:make-serialization-state)
+   #:make-serialization-state
+   #:reset-known-slots)
   (:documentation "XML and s-expression based serialization for Common Lisp and CLOS"))
 
 (defpackage :cl-prevalence


Index: cl-prevalence/src/prevalence.lisp
diff -u cl-prevalence/src/prevalence.lisp:1.6 cl-prevalence/src/prevalence.lisp:1.7
--- cl-prevalence/src/prevalence.lisp:1.6	Tue Jul 13 12:30:28 2004
+++ cl-prevalence/src/prevalence.lisp	Mon Oct  4 16:25:13 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: prevalence.lisp,v 1.6 2004/07/13 10:30:28 scaekenberghe Exp $
+;;;; $Id: prevalence.lisp,v 1.7 2004/10/04 14:25:13 scaekenberghe Exp $
 ;;;;
 ;;;; Object Prevalence in Common Lisp
 ;;;;
@@ -367,6 +367,11 @@
 	 (write-sequence buffer out :end read-count)
 	 (when (< read-count 4096) (return)))))))
   
+;;; from the serialization package 
+
+(defmethod reset-known-slots ((system prevalence-system) &optional class)
+  (reset-known-slots (get-serialization-state system) class))
+
 ;;; extra documentation
 
 (setf (documentation 'get-guard 'function) "Access the guard function of a sytem")


Index: cl-prevalence/src/serialization.lisp
diff -u cl-prevalence/src/serialization.lisp:1.3 cl-prevalence/src/serialization.lisp:1.4
--- cl-prevalence/src/serialization.lisp:1.3	Mon Oct  4 15:45:56 2004
+++ cl-prevalence/src/serialization.lisp	Mon Oct  4 16:25:13 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: serialization.lisp,v 1.3 2004/10/04 13:45:56 scaekenberghe Exp $
+;;;; $Id: serialization.lisp,v 1.4 2004/10/04 14:25:13 scaekenberghe Exp $
 ;;;;
 ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS
 ;;;;
@@ -52,6 +52,9 @@
   "Create a reusable serialization state to pass as optional argument to [de]serialize-xml"
   (make-instance 'serialization-state))
 
+(defgeneric reset-known-slots (serialization-state &optional class)
+  (:documentation "Clear the caching of known slots for class, or for all classes if class is nil"))
+
 ;;; Implementation
 
 ;; State and Support
@@ -74,6 +77,12 @@
   (with-slots (hashtable counter) serialization-state
     (clrhash hashtable)
     (setf counter 0)))
+
+(defmethod reset-known-slots ((serialization-state serialization-state) &optional class)
+  (with-slots (known-slots) serialization-state
+    (if class
+        (remhash (if (symbolp class) class (class-name class)) known-slots)
+      (clrhash known-slots))))
 
 (defmethod known-object-id ((serialization-state serialization-state) object)
   (gethash object (get-hashtable serialization-state)))




From scaekenberghe at common-lisp.net  Mon Oct  4 14:41:38 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 04 Oct 2004 16:41:38 +0200
Subject: [cl-prevalence-cvs] CVS update:
	cl-prevalence/src/serialization.lisp 
Message-ID: <E1CEU1y-0005ey-00@common-lisp.net>

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv21752/src

Modified Files:
	serialization.lisp 
Log Message:
added serializable-slots implementation for sbcl
thanks to Anthony W. Juckel

Date: Mon Oct  4 16:41:37 2004
Author: scaekenberghe

Index: cl-prevalence/src/serialization.lisp
diff -u cl-prevalence/src/serialization.lisp:1.4 cl-prevalence/src/serialization.lisp:1.5
--- cl-prevalence/src/serialization.lisp:1.4	Mon Oct  4 16:25:13 2004
+++ cl-prevalence/src/serialization.lisp	Mon Oct  4 16:41:37 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: serialization.lisp,v 1.4 2004/10/04 14:25:13 scaekenberghe Exp $
+;;;; $Id: serialization.lisp,v 1.5 2004/10/04 14:41:37 scaekenberghe Exp $
 ;;;;
 ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS
 ;;;;
@@ -124,7 +124,11 @@
   #+lispworks
   (structure:structure-class-slot-names (class-of object))
   #+allegro
-  (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))
+  (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object)))
+  #+sbcl
+  (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots (class-of object)))
+  #-(or openmcl cmu lispworks allegro sbcl)
+  (error "not yet implemented"))
 
 (defmethod serializable-slots ((object standard-object))
   #+openmcl
@@ -137,7 +141,11 @@
   #+lispworks
   (mapcar #'hcl:slot-definition-name (hcl:class-slots (class-of object)))
   #+allegro
-  (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))
+  (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object)))
+  #+sbcl
+  (mapcar #'sb-mop:slot-definition-name (sb-mop:class-slots (class-of object)))
+  #-(or openmcl cmu lispworks allegro sbcl)
+  (error "not yet implemented"))
 
 (defmethod get-serializable-slots ((serialization-state serialization-state) object)
   (with-slots (known-slots) serialization-state




From scaekenberghe at common-lisp.net  Mon Oct  4 14:52:53 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 04 Oct 2004 16:52:53 +0200
Subject: [cl-prevalence-cvs] CVS update:
	cl-prevalence/test/test-serialization.lisp 
Message-ID: <E1CEUCr-0005tl-00@common-lisp.net>

Update of /project/cl-prevalence/cvsroot/cl-prevalence/test
In directory common-lisp.net:/tmp/cvs-serv22666/test

Modified Files:
	test-serialization.lisp 
Log Message:
now testing xml and sexp serialization seperately, added empty string test
thanks to randall randall

Date: Mon Oct  4 16:52:52 2004
Author: scaekenberghe

Index: cl-prevalence/test/test-serialization.lisp
diff -u cl-prevalence/test/test-serialization.lisp:1.1.1.1 cl-prevalence/test/test-serialization.lisp:1.2
--- cl-prevalence/test/test-serialization.lisp:1.1.1.1	Sun Jun 20 21:13:42 2004
+++ cl-prevalence/test/test-serialization.lisp	Mon Oct  4 16:52:52 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: test-serialization.lisp,v 1.1.1.1 2004/06/20 19:13:42 scaekenberghe Exp $
+;;;; $Id: test-serialization.lisp,v 1.2 2004/10/04 14:52:52 scaekenberghe Exp $
 ;;;;
 ;;;; Testing XML and S-Expression based Serialization for Common Lisp and CLOS
 ;;;;
@@ -12,11 +12,13 @@
 
 (in-package :s-serialization)
 
-(defun serialize-and-deserialize (object)
+(defun serialize-and-deserialize-xml (object)
   (with-input-from-string
     (in (with-output-to-string (out)
 	  (serialize-xml object out)))
-    (deserialize-xml in))
+    (deserialize-xml in)))
+
+(defun serialize-and-deserialize-sexp (object)
   (with-input-from-string
     (in (with-output-to-string (out)
 	  (serialize-sexp object out)))
@@ -25,46 +27,97 @@
 ;; primitives
 
 (assert
- (null (serialize-and-deserialize nil)))
+ (null (serialize-and-deserialize-xml nil)))
+
+(assert
+ (null (serialize-and-deserialize-sexp nil)))
 
 (assert
- (eq (serialize-and-deserialize t)
+ (eq (serialize-and-deserialize-xml t)
      t))
 
 (assert
- (= (serialize-and-deserialize 100)
+ (eq (serialize-and-deserialize-sexp t)
+     t))
+
+(assert
+ (= (serialize-and-deserialize-xml 100)
+    100))
+
+(assert
+ (= (serialize-and-deserialize-sexp 100)
     100))
 
 (assert
- (= (serialize-and-deserialize (/ 3))
+ (= (serialize-and-deserialize-xml (/ 3))
     (/ 3)))
 
 (assert
- (= (serialize-and-deserialize pi)
+ (= (serialize-and-deserialize-sexp (/ 3))
+    (/ 3)))
+
+(assert
+ (= (serialize-and-deserialize-xml pi)
+    pi))
+
+(assert
+ (= (serialize-and-deserialize-sexp pi)
     pi))
 
 (assert
- (= (serialize-and-deserialize (complex 1.5 2.5))
+ (= (serialize-and-deserialize-xml (complex 1.5 2.5))
+    (complex 1.5 2.5)))
+
+(assert
+ (= (serialize-and-deserialize-sexp (complex 1.5 2.5))
     (complex 1.5 2.5)))
 
 (assert
- (eq (serialize-and-deserialize 'foo)
+ (eq (serialize-and-deserialize-xml 'foo)
+     'foo))
+
+(assert
+ (eq (serialize-and-deserialize-sexp 'foo)
      'foo))
 
 (assert
- (eq (serialize-and-deserialize :foo)
+ (eq (serialize-and-deserialize-xml :foo)
      :foo))
 
 (assert
- (eq (serialize-and-deserialize 'room)
+ (eq (serialize-and-deserialize-sexp :foo)
+     :foo))
+
+(assert
+ (eq (serialize-and-deserialize-xml 'room)
      'room))
 
 (assert
- (equal (serialize-and-deserialize "Hello")
+ (eq (serialize-and-deserialize-sexp 'room)
+     'room))
+
+(assert
+ (equal (serialize-and-deserialize-xml "Hello")
+	"Hello"))
+
+(assert
+ (equal (serialize-and-deserialize-sexp "Hello")
 	"Hello"))
 
+(assert 
+ (equal (serialize-and-deserialize-xml "")
+        ""))
+
+(assert 
+ (equal (serialize-and-deserialize-sexp "")
+        ""))
+
+(assert
+ (equal (serialize-and-deserialize-xml "Hello <foo> & </bar>!")
+	"Hello <foo> & </bar>!"))
+
 (assert
- (equal (serialize-and-deserialize "Hello <foo> & </bar>!")
+ (equal (serialize-and-deserialize-sexp "Hello <foo> & </bar>!")
 	"Hello <foo> & </bar>!"))
 
 ;; simple sequences
@@ -73,11 +126,22 @@
  (reduce #'(lambda (x &optional (y t)) (and x y))
 	 (map 'list
 	      #'eql
-	      (serialize-and-deserialize (list 1 2 3))
+	      (serialize-and-deserialize-xml (list 1 2 3))
 	      (list 1 2 3))))
 
 (assert
- (equal (serialize-and-deserialize (list 1 2 3))
+ (reduce #'(lambda (x &optional (y t)) (and x y))
+	 (map 'list
+	      #'eql
+	      (serialize-and-deserialize-sexp (list 1 2 3))
+	      (list 1 2 3))))
+
+(assert
+ (equal (serialize-and-deserialize-xml (list 1 2 3))
+	(list 1 2 3)))
+
+(assert
+ (equal (serialize-and-deserialize-sexp (list 1 2 3))
 	(list 1 2 3)))
 
 ;; simple objects
@@ -89,7 +153,13 @@
 (defparameter *foobar* (make-instance 'foobar :foo 100 :bar "Bar"))
 
 (assert
- (let ((foobar (serialize-and-deserialize *foobar*)))
+ (let ((foobar (serialize-and-deserialize-xml *foobar*)))
+   (and (equal (get-foo foobar) (get-foo *foobar*))
+	(equal (get-bar foobar) (get-bar *foobar*))
+	(eq (class-of foobar) (class-of *foobar*)))))
+
+(assert
+ (let ((foobar (serialize-and-deserialize-sexp *foobar*)))
    (and (equal (get-foo foobar) (get-foo *foobar*))
 	(equal (get-bar foobar) (get-bar *foobar*))
 	(eq (class-of foobar) (class-of *foobar*)))))
@@ -103,7 +173,13 @@
 (defparameter *foobaz* (make-foobaz :foo 100 :baz "Baz"))
 
 (assert
- (let ((foobaz (serialize-and-deserialize *foobaz*)))
+ (let ((foobaz (serialize-and-deserialize-xml *foobaz*)))
+   (and (foobaz-p foobaz)
+	(equal (foobaz-foo foobaz) (foobaz-foo *foobaz*))
+	(equal (foobaz-baz foobaz) (foobaz-baz *foobaz*)))))
+
+(assert
+ (let ((foobaz (serialize-and-deserialize-sexp *foobaz*)))
    (and (foobaz-p foobaz)
 	(equal (foobaz-foo foobaz) (foobaz-foo *foobaz*))
 	(equal (foobaz-baz foobaz) (foobaz-baz *foobaz*)))))
@@ -118,7 +194,12 @@
     hashtable))
 
 (let (h2)
-  (setf h2 (serialize-and-deserialize *hashtable*))
+  (setf h2 (serialize-and-deserialize-xml *hashtable*))
+  (maphash #'(lambda (k v) (assert (equal v (gethash k h2)))) *hashtable*) 
+  (maphash #'(lambda (k v) (assert (equal v (gethash k *hashtable*)))) h2))
+
+(let (h2)
+  (setf h2 (serialize-and-deserialize-sexp *hashtable*))
   (maphash #'(lambda (k v) (assert (equal v (gethash k h2)))) *hashtable*) 
   (maphash #'(lambda (k v) (assert (equal v (gethash k *hashtable*)))) h2))
 




From scaekenberghe at common-lisp.net  Mon Oct  4 15:13:16 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Mon, 04 Oct 2004 17:13:16 +0200
Subject: [cl-prevalence-cvs] CVS update:
	cl-prevalence/src/serialization.lisp 
Message-ID: <E1CEUWa-00069f-00@common-lisp.net>

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv23652/src

Modified Files:
	serialization.lisp 
Log Message:
added code to deal with unbound slots when serializing (noted by anthony juckel)
and code to deal with missing slots when deserializing

Date: Mon Oct  4 17:13:15 2004
Author: scaekenberghe

Index: cl-prevalence/src/serialization.lisp
diff -u cl-prevalence/src/serialization.lisp:1.5 cl-prevalence/src/serialization.lisp:1.6
--- cl-prevalence/src/serialization.lisp:1.5	Mon Oct  4 16:41:37 2004
+++ cl-prevalence/src/serialization.lisp	Mon Oct  4 17:13:15 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: serialization.lisp,v 1.5 2004/10/04 14:41:37 scaekenberghe Exp $
+;;;; $Id: serialization.lisp,v 1.6 2004/10/04 15:13:15 scaekenberghe Exp $
 ;;;;
 ;;;; XML and S-Expression based Serialization for Common Lisp and CLOS
 ;;;;
@@ -384,13 +384,13 @@
 	(write-string "\" CLASS=\"" stream)
 	(print-symbol-xml (class-name (class-of object)) stream)
 	(princ "\">" stream)
-	(mapc #'(lambda (slot)
-		  (write-string "<SLOT NAME=\"" stream)
-		  (print-symbol-xml slot stream)
-		  (write-string "\">" stream)
-		  (serialize-xml-internal (slot-value object slot) stream serialization-state)
-		  (write-string "</SLOT>" stream))
-	      (get-serializable-slots serialization-state object))
+	(loop :for slot :in (get-serializable-slots serialization-state object)
+              :do (when (slot-boundp object slot)
+                    (write-string "<SLOT NAME=\"" stream)
+                    (print-symbol-xml slot stream)
+                    (write-string "\">" stream)
+                    (serialize-xml-internal (slot-value object slot) stream serialization-state)
+                    (write-string "</SLOT>" stream)))
 	(write-string "</OBJECT>" stream)))))
 
 (defmethod serialize-sexp-internal ((object standard-object) stream serialization-state)
@@ -408,13 +408,13 @@
 	(print-symbol (class-name (class-of object)) stream)
         (when serializable-slots
           (princ " :SLOTS (" stream)
-          (mapc #'(lambda (slot)
-                    (write-string " (" stream)
-                    (print-symbol slot stream)
-                    (write-string " . " stream)
-                    (serialize-sexp-internal (slot-value object slot) stream serialization-state)
-                    (write-string ")" stream))
-                serializable-slots))
+          (loop :for slot :in serializable-slots
+                :do (when (slot-boundp object slot)
+                      (write-string " (" stream)
+                      (print-symbol slot stream)
+                      (write-string " . " stream)
+                      (serialize-sexp-internal (slot-value object slot) stream serialization-state)
+                      (write-string ")" stream))))
 	(write-string " ) )" stream)))))
 
 ;;; Deserialize CLOS instances and Lisp primitives from the XML representation
@@ -464,11 +464,13 @@
 	  (:object (let* ((id (parse-integer (get-attribute-value :id attributes)))
 			  (object (gethash id *deserialized-objects*)))
 		     (dolist (pair seed object)
-		       (setf (slot-value object (car pair)) (cdr pair)))))
+                       (when (slot-exists-p object (car pair))
+                         (setf (slot-value object (car pair)) (cdr pair))))))
 	  (:struct (let* ((id (parse-integer (get-attribute-value :id attributes)))
 			  (object (gethash id *deserialized-objects*)))
 		     (dolist (pair seed object)
-		       (setf (slot-value object (car pair)) (cdr pair)))))
+                       (when (slot-exists-p object (car pair))
+                         (setf (slot-value object (car pair)) (cdr pair))))))
 	  (:hash-table (let* ((id (parse-integer (get-attribute-value :id attributes)))
 			      (hash-table (gethash id *deserialized-objects*)))
 			 (dolist (pair seed hash-table)
@@ -505,16 +507,18 @@
                  (let ((object (make-instance class)))
                    (setf (gethash id deserialized-objects) object)
                    (dolist (slot slots)
-                     (setf (slot-value object (first slot)) 
-                           (deserialize-sexp-internal (rest slot) deserialized-objects)))
+                     (when (slot-exists-p object (first slot))
+                       (setf (slot-value object (first slot)) 
+                             (deserialize-sexp-internal (rest slot) deserialized-objects))))
                    object)))
       (:struct (destructuring-bind (id &key class slots) (rest sexp)
                  (let ((object (funcall (intern (concatenate 'string "MAKE-" (symbol-name class)) 
                                                 (symbol-package class)))))
                    (setf (gethash id deserialized-objects) object)
                    (dolist (slot slots)
-                     (setf (slot-value object (first slot)) 
-                           (deserialize-sexp-internal (rest slot) deserialized-objects)))
+                     (when (slot-exists-p object (first slot))
+                       (setf (slot-value object (first slot)) 
+                             (deserialize-sexp-internal (rest slot) deserialized-objects))))
                    object)))
       (:ref (gethash (rest sexp) deserialized-objects)))))
 




From scaekenberghe at common-lisp.net  Tue Oct  5 11:35:30 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Tue, 05 Oct 2004 13:35:30 +0200
Subject: [cl-prevalence-cvs] CVS update:
	cl-prevalence/src/managed-prevalence.lisp 
Message-ID: <E1CEnbO-0000SN-00@common-lisp.net>

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv1751/src

Modified Files:
	managed-prevalence.lisp 
Log Message:
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

Date: Tue Oct  5 13:35:28 2004
Author: scaekenberghe

Index: cl-prevalence/src/managed-prevalence.lisp
diff -u cl-prevalence/src/managed-prevalence.lisp:1.1.1.1 cl-prevalence/src/managed-prevalence.lisp:1.2
--- cl-prevalence/src/managed-prevalence.lisp:1.1.1.1	Sun Jun 20 21:13:38 2004
+++ cl-prevalence/src/managed-prevalence.lisp	Tue Oct  5 13:35:28 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: managed-prevalence.lisp,v 1.1.1.1 2004/06/20 19:13:38 scaekenberghe Exp $
+;;;; $Id: managed-prevalence.lisp,v 1.2 2004/10/05 11:35:28 scaekenberghe Exp $
 ;;;;
 ;;;; The code in this file adds another layer above plain object prevalence.
 ;;;; We manage objects with ids in an organized fashion, adding an id counter and preferences.
@@ -34,10 +34,11 @@
   (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"))
@@ -52,33 +53,84 @@
 
 (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"))
+
+(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 &optional class slots-and-values)
+(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))))
@@ -86,10 +138,13 @@
 (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)




From scaekenberghe at common-lisp.net  Tue Oct  5 11:35:32 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Tue, 05 Oct 2004 13:35:32 +0200
Subject: [cl-prevalence-cvs] CVS update:
	cl-prevalence/test/test-managed-prevalence.lisp
	cl-prevalence/test/test-prevalence.lisp 
Message-ID: <E1CEnbQ-0000Sb-00@common-lisp.net>

Update of /project/cl-prevalence/cvsroot/cl-prevalence/test
In directory common-lisp.net:/tmp/cvs-serv1751/test

Modified Files:
	test-prevalence.lisp 
Added Files:
	test-managed-prevalence.lisp 
Log Message:
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

Date: Tue Oct  5 13:35:31 2004
Author: scaekenberghe



Index: cl-prevalence/test/test-prevalence.lisp
diff -u cl-prevalence/test/test-prevalence.lisp:1.2 cl-prevalence/test/test-prevalence.lisp:1.3
--- cl-prevalence/test/test-prevalence.lisp:1.2	Fri Jun 25 18:19:05 2004
+++ cl-prevalence/test/test-prevalence.lisp	Tue Oct  5 13:35:30 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: Lisp -*-
 ;;;;
-;;;; $Id: test-prevalence.lisp,v 1.2 2004/06/25 16:19:05 scaekenberghe Exp $
+;;;; $Id: test-prevalence.lisp,v 1.3 2004/10/05 11:35:30 scaekenberghe Exp $
 ;;;;
 ;;;; Testing Object Prevalence in Common Lisp
 ;;;;
@@ -33,12 +33,6 @@
    (lastname :initarg :lastname :accessor get-lastname)))
 
 ;; 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)))




From scaekenberghe at common-lisp.net  Tue Oct  5 11:44:36 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Tue, 05 Oct 2004 13:44:36 +0200
Subject: [cl-prevalence-cvs] CVS update:
	cl-prevalence/src/managed-prevalence.lisp 
Message-ID: <E1CEnkC-0000T7-00@common-lisp.net>

Update of /project/cl-prevalence/cvsroot/cl-prevalence/src
In directory common-lisp.net:/tmp/cvs-serv1797/src

Modified Files:
	managed-prevalence.lisp 
Log Message:
added a fallback for find-object-with-slot in case there are no indexes

Date: Tue Oct  5 13:44:36 2004
Author: scaekenberghe

Index: cl-prevalence/src/managed-prevalence.lisp
diff -u cl-prevalence/src/managed-prevalence.lisp:1.2 cl-prevalence/src/managed-prevalence.lisp:1.3
--- cl-prevalence/src/managed-prevalence.lisp:1.2	Tue Oct  5 13:35:28 2004
+++ cl-prevalence/src/managed-prevalence.lisp	Tue Oct  5 13:44:36 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: managed-prevalence.lisp,v 1.2 2004/10/05 11:35:28 scaekenberghe Exp $
+;;;; $Id: managed-prevalence.lisp,v 1.3 2004/10/05 11:44:36 scaekenberghe Exp $
 ;;;;
 ;;;; The code in this file adds another layer above plain object prevalence.
 ;;;; We manage objects with ids in an organized fashion, adding an id counter and preferences.
@@ -58,18 +58,19 @@
     (when index
       (gethash id index))))
 
-(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"))
+(defgeneric find-object-with-slot (system class slot value &optional (test #'equalp))
+  (:documentation "Find and return the object in system of class with slot equal to value, null if not found"))
 
-(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."
+(defmethod find-object-with-slot ((system prevalence-system) class slot value &optional (test #'equalp))
+  "Find and return the object in system of class with slot equal to value, null if not found"
   (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)))))
+    (if index
+        (find-object-with-id system class (gethash value index))
+      (find value (find-all-objects system class) 
+            :key #'(lambda (object) (slot-value object slot)) :test test))))
 
-(defun tx-create-objects-slot-index (system class slot &optional (test 'equalp))
+(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)