cl-2sql

commit 72bd345286f2c395ff945235a11bc0370fd53091
parent 88caaac18fee707f5f051e0b63e9927cc6c0c717
Author: Tomas Hlavaty <tom@logand.com>
Date:   Mon, 29 Aug 2011 21:39:15 +0200

proxy for lazy loading of "foreign key" instances

Diffstat:
M
orm.lisp
 | 
36
+++++++++++++++++++++++-------------

1 file changed, 23 insertions(+), 13 deletions(-)
diff --git a/orm.lisp b/orm.lisp
@@ -211,24 +211,33 @@
   (unless (eq 'oid (c2mop:slot-definition-name slotd))
     (check-cached-instance a)))
 
-(defstruct proxy oid)
+(defstruct (proxy (:constructor make-proxy (oid))) oid)
+
+(defun load-instance (class-name oid)
+  (let ((x (2sql-orm:query (oid)
+             `(q:select ((instance ,class-name))
+                (q:from ,class-name)
+                (q:where (q:= oid (q:qvar oid)))))))
+    (assert (not (cdr x)))
+    (assert (car x))
+    (assert (not (cadr x)))
+    (assert (typep (caar x) class-name))
+    (caar x)))
 
 (defmethod c2mop:slot-value-using-class :around ((class persistent-class)
                                                  (a %persistent-object)
                                                  slotd)
-  (let ((a (call-next-method)))
-    a
-    #+nil ;; TODO only for proxy slots
-    (etypecase a
-      (proxy (error "TODO maybe-dereference-proxy ~s" a))
-      (%persistent-object a))))
+  (let ((s (call-next-method)))
+    (if (proxy-p s)
+        (load-instance (ltype slotd) (proxy-oid s))
+        s)))
 
 (defmethod (setf c2mop:slot-value-using-class) :around (value
                                                         (class persistent-class)
                                                         (a %persistent-object)
                                                         slotd)
-  (call-next-method)
-  #+nil(error "TODO (setf c2mop:slot-value-using-class) :around"))
+  ;; TODO ? enforce assert-type?
+  (call-next-method))
 
 ;;; persistent slots
 
@@ -484,7 +493,6 @@
                        (q:returning ,returning-cols))))
 
 (defun assert-type (value type)
-  ;;(print (list :assert-type1 value type (type-of value)))
   (unless (typep value type)
     (cond ;; TODO more cases
       ((typep value 'string)
@@ -496,9 +504,11 @@
                                                     (make-ptime hh mm ss ms)
                                                     nil))))
       ((subtypep type 'persistent-object)
-       (error "TODO assert-type persistent-object"))))
-  ;;(print (list :assert-type2 value type (type-of value)))
-  (assert (typep value type))
+       (setq value (or (gethash value *instance-cache*)
+                       (make-proxy value))))))
+  (assert (or (typep value type)
+              (when (subtypep type 'persistent-object)
+                (proxy-p value))))
   value)
 
 (defun cache-pinstance (a)