From 90c2e4c13bd89c48de9fe0da126547447b7b9e01 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Wed, 3 Jan 2007 09:49:11 +0000 Subject: [PATCH] r11442: add compute-cached-value slot option --- metaclass.lisp | 2 +- mop.lisp | 86 +++++++++++++++++++++++++++++++------------------- tests.lisp | 28 +++++++++++++--- 3 files changed, 77 insertions(+), 39 deletions(-) diff --git a/metaclass.lisp b/metaclass.lisp index e5655f0..a4d21f4 100644 --- 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 2ccf8d6..3505a1b 100644 --- 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 15dc082..5f698bd 100644 --- 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) + -- 2.34.1