r11442: add compute-cached-value slot option

diff --git a/metaclass.lisp b/metaclass.lisp
index e5655f00a3788c2d5756dba64af433f3b583a4be..a4d21f4a8c652f78165b97697f17436fd64c5daa 100644 (file)
--- a/metaclass.lisp
+++ b/metaclass.lisp
@@ -25,7 +25,7 @@
     :subobject :hyperlink :hyperlink-parameters :indexed :inverse :unique
     :sql-name :null-allowed :stored :input-filter :unbound-lookup
     :value-constraint :void-text :read-only-groups :hidden-groups :unit
-    :disable-predicate :view-type :list-of-values)
+    :compute-cached-value :disable-predicate :view-type :list-of-values)
   "Slot options that can appear as an initarg")
 
 (defparameter *slot-options-no-initarg*

diff --git a/mop.lisp b/mop.lisp
index 2ccf8d685a106ae8e51f3111781a90b495ce9442..3505a1bdf754c72113855cebbd510907d3e89cbc 100644 (file)
--- a/mop.lisp
+++ b/mop.lisp
@@ -51,6 +51,9 @@
    (subobjects :initform nil :accessor subobjects
               :documentation
               "List of fields that contain a list of subobjects objects.")
+   (compute-cached-values :initform nil :accessor compute-cached-values
+                         :documentation
+                         "List of fields that contain a list of compute-cached-value objects.")
    (hyperlinks :type list :initform nil :accessor hyperlinks
               :documentation "List of fields that have hyperlinks")
    (direct-rules :type list :initform nil :initarg :direct-rules
@@ -82,11 +85,22 @@
 (defclass subobject ()
   ((name-class :type symbol :initarg :name-class :reader name-class)
    (name-slot :type symbol :initarg :name-slot :reader name-slot)
-   (subobj-class :type symbol :initarg :subobj-class :reader subobj-class)
+   (lazy-class :type symbol :initarg :lazy-class :reader lazy-class)
    (lookup :type (or function symbol) :initarg :lookup :reader lookup)
    (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))
   (:documentation "subobject information")
-  (:default-initargs :name-class nil :name-slot nil :subobj-class nil
+  (:default-initargs :name-class nil :name-slot nil :lazy-class nil
+                    :lookup nil :lookup-keys nil))
+
+(defclass compute-cached-value ()
+  ((name-class :type symbol :initarg :name-class :reader name-class)
+   (name-slot :type symbol :initarg :name-slot :reader name-slot)
+   (lazy-class :type symbol :initarg :lazy-class
+                              :reader lazy-class)
+   (lookup :type (or function symbol) :initarg :lookup :reader lookup)
+   (lookup-keys :type list :initarg :lookup-keys :reader lookup-keys))
+  (:documentation "subobject information")
+  (:default-initargs :name-class nil :name-slot nil :lazy-class nil
                     :lookup nil :lookup-keys nil))
 
 
@@ -275,7 +289,7 @@
                    description value-constraint indexed null-allowed
                    unique short-description void-text read-only-groups
                    hidden-groups unit disable-predicate view-type
-                   list-of-values stored))
+                   list-of-values compute-cached-value stored))
       (setf (slot-value esd name) (slot-value dsd name)))
     esd))
 
@@ -387,11 +401,11 @@ SQL name"
 ;; The reader is a function and the reader-keys are slot names.  The slot is lazily set to
 ;; the result of applying the function to the slot-values of those slots, and that value
 ;; is also returned.
-(defun ensure-lazy-reader (cl class-name slot-name subobj-class reader
+(defun ensure-lazy-reader (cl class-name slot-name lazy-class reader
                           &rest reader-keys)
   (declare (ignore class-name))
   (setf (getf (gethash cl *lazy-readers*) slot-name)
-    (aif subobj-class
+    (aif lazy-class
         it
         (list* reader (copy-list reader-keys)))))
 
@@ -400,35 +414,40 @@ SQL name"
     nil))
 
 
+(defun store-lazily-computed-objects (cl slot esd-accessor obj-class)
+  (setf (slot-value cl slot)
+        (let ((objs '()))
+          (dolist (slot (class-slots cl))
+            (let-when
+             (def (funcall esd-accessor slot))
+             (let ((obj (make-instance obj-class
+                                       :name-class (class-name cl)
+                                       :name-slot (slot-definition-name slot)
+                                       :lazy-class (when (atom def)
+                                                     def)
+                                       :lookup (when (listp def)
+                                                 (car def))
+                                       :lookup-keys (when (listp def)
+                                                      (cdr def)))))
+               (unless (eq (lookup obj) t)
+                 (apply #'ensure-lazy-reader
+                  cl
+                  (name-class obj) (name-slot obj)
+                  (lazy-class obj)
+                  (lookup obj) (lookup-keys obj))
+                 (push obj objs)))))
+          ;; sbcl/cmu reverse class-slots compared to the defclass form
+          ;; so re-reverse on cmu/sbcl
+          #+(or cmu sbcl) objs
+          #-(or cmu sbcl) (nreverse objs)
+          )))
+
 (defun finalize-subobjects (cl)
-  "Process class subobjects slot"
-  (setf (subobjects cl)
-       (let ((subobjects '()))
-         (dolist (slot (class-slots cl))
-           (let-when
-            (subobj-def (esd-subobject slot))
-            (let ((subobject
-                   (make-instance 'subobject
-                                  :name-class (class-name cl)
-                                  :name-slot (slot-definition-name slot)
-                                  :subobj-class (when (atom subobj-def)
-                                                  subobj-def)
-                                  :lookup (when (listp subobj-def)
-                                            (car subobj-def))
-                                  :lookup-keys (when (listp subobj-def)
-                                                 (cdr subobj-def)))))
-              (unless (eq (lookup subobject) t)
-                (apply #'ensure-lazy-reader
-                       cl
-                       (name-class subobject) (name-slot subobject)
-                       (subobj-class subobject)
-                       (lookup subobject) (lookup-keys subobject))
-                (push subobject subobjects)))))
-         ;; sbcl/cmu reverse class-slots compared to the defclass form
-         ;; so re-reverse on cmu/sbcl
-         #+(or cmu sbcl) subobjects
-         #-(or cmu sbcl) (nreverse subobjects)
-         )))
+  (store-lazily-computed-objects cl 'subobjects 'esd-subobject 'subobject))
+
+(defun finalize-compute-cached (cl)
+  (store-lazily-computed-objects cl 'compute-cached-values 
+                                 'esd-compute-cached-value 'compute-cached-value))
 
 (defun finalize-class-slots (cl)
   "Make sure all class slots have an expected value"
@@ -487,6 +506,7 @@ SQL name"
 (defun init-hyperobject-class (cl)
   "Initialize a hyperobject class. Calculates all class slots"
   (finalize-subobjects cl)
+  (finalize-compute-cached cl)
   (finalize-views cl)
   (finalize-hyperlinks cl)
   (finalize-sql cl)

diff --git a/tests.lisp b/tests.lisp
index 15dc08203d0a69c3debf75a8d337b6d5a27b8e01..5f698bd69632e9bef3249918cf2f22f3a9fa467a 100644 (file)
--- a/tests.lisp
+++ b/tests.lisp
@@ -16,6 +16,9 @@
   (:use #:hyperobject #:cl #:rtest #:kmrcl))
 (in-package #:hyperobject-tests)
 
+(defvar *now* (get-universal-time))
+(defun get-now () *now*)
+
 (defclass person (hyperobject)
   ((first-name :initarg :first-name :accessor first-name
               :value-type (varchar 20)
@@ -38,7 +41,8 @@
           :value-constraint stringp)
    ;;   (addresses :value-type (list-of subobject) :initarg :addresses :accessor addresses))
    (addresses :initarg :addresses :accessor addresses
-              :subobject t))
+              :subobject t)
+   (create-time :accessor create-time :compute-cached-value (get-now)))
   (:metaclass hyperobject-class)
   (:default-initargs :first-name "" :last-name "" :dob 0 :resume nil)
   (:default-print-slots first-name last-name dob resume)
@@ -56,11 +60,14 @@
           :value-type (varchar 30)
           :value-constraint stringp)
    (phones :initarg :phones :accessor phones
-           :subobject t))
+           :subobject t)
+   (years-at-address :initarg :years-at-address :value-type fixnum
+                     :accessor years-at-address
+                     :value-constraint integerp))
   (:metaclass hyperobject-class)
   (:default-initargs :title nil :street nil)
   (:user-name "Address" "Addresses")
-  (:default-print-slots title street)
+  (:default-print-slots title street years-at-address)
   (:description "An address"))
 
 (defclass phone (hyperobject)
@@ -85,9 +92,11 @@
 (defparameter office-phone-3 (make-instance 'phone :title "Fax" :phone-number "123-0005"))
 
 (defparameter home (make-instance 'address :title "Home" :street "321 Shady Lane"
+                                  :years-at-address 10
                                  :phones (list home-phone-1 home-phone-2)))
 
 (defparameter office (make-instance 'address :title "Office" :street "113 Main St."
+                                    :years-at-address 5
                                    :phones (list office-phone-1 office-phone-2 office-phone-3)))
 
 
@@ -111,11 +120,11 @@
 (deftest :p2 (view-to-string mary :subobjects t :vid :compact-text) "Person:
   Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace
   Addresses:
-    Home 321 Shady Lane
+    Home 321 Shady Lane 10
     Phone Numbers:
       Voice 367-9812
       Fax 367-9813
-    Office 113 Main St.
+    Office 113 Main St. 5
     Phone Numbers:
       Main line 123-0001
       Staff line 123-0002
@@ -132,3 +141,12 @@
   Mary Jackson Thu, 4 May 2000 03:02:01 Style & Grace
 ")
 
+(deftest :s1 (years-at-address home)
+  10)
+
+(deftest :s2 (years-at-address office)
+  5)
+
+(deftest :cv1 (equal (create-time mary) *now*)
+  t)
+