[cl-prevalence-cvs] CVS update: cl-prevalence/src/managed-prevalence.lisp

[Sven Van Caekenberghe]

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)