X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=3505a1bdf754c72113855cebbd510907d3e89cbc;hb=90c2e4c13bd89c48de9fe0da126547447b7b9e01;hp=528c99f58c77d311270ab78f796fa0ded9b4dd22;hpb=0817a8721cbefca2205dcde535ff6b164033abef;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 528c99f..3505a1b 100644 --- a/mop.lisp +++ b/mop.lisp @@ -13,9 +13,9 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file is Copyright (c) 2000-2003 by Kevin M. Rosenberg +;;;; This file is Copyright (c) 2000-2006 by Kevin M. Rosenberg ;;;; ************************************************************************* - + (in-package #:hyperobject) ;; Main class @@ -47,10 +47,13 @@ ;;; The remainder of these fields are calculated one time ;;; in finalize-inheritence. - + (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 @@ -64,6 +67,8 @@ :documentation "Unique ID for the class") (default-view :initform nil :initarg :default-view :accessor default-view :documentation "The default view for a class") + (documementation :initform nil :initarg :documentation + :documentation "Documentation string for hyperclass.") ;; SQL commands (create-table-cmd :initform nil :reader create-table-cmd) @@ -80,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)) @@ -110,13 +126,7 @@ t) (defmethod finalize-inheritance :after ((cl hyperobject-class)) - ;; Work-around needed for OpenMCL - #+ignore - (unless (find-class (class-name cl)) - (setf (find-class (class-name cl)) cl)) - - (init-hyperobject-class cl) - ) + (init-hyperobject-class cl)) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list @@ -124,29 +134,29 @@ 'compute-effective-slot-definition))) 3) (pushnew :ho-normal-cesd cl:*features*)) - + (when (>= (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew :ho-normal-dsdc cl:*features*)) - + (when (>= (length (generic-function-lambda-list (ensure-generic-function 'effective-slot-definition-class))) 3) (pushnew :ho-normal-esdc cl:*features*))) -;; Slot definitions (defmethod direct-slot-definition-class ((cl hyperobject-class) #+ho-normal-dsdc &rest iargs) + (declare (ignore iargs)) (find-class 'hyperobject-dsd)) -(defmethod effective-slot-definition-class ((cl hyperobject-class) +(defmethod effective-slot-definition-class ((cl hyperobject-class) #+ho-normal-esdc &rest iargs) + (declare (ignore iargs)) (find-class 'hyperobject-esd)) - ;;; Slot definitions (eval-when (:compile-toplevel :load-toplevel :execute) @@ -173,7 +183,7 @@ #-lispworks (declare (ignore slot-name)) ) - + (dolist (option *class-options*) (eval `(process-class-option ,option))) (dolist (option *slot-options*) @@ -231,6 +241,22 @@ (t t))) +(defmethod initialize-instance :around ((obj hyperobject-dsd) &rest initargs) + (do* ((parsed (list obj)) + (name (first initargs) (first initargs)) + (val (second initargs) (second initargs))) + ((null initargs) + (apply #'call-next-method parsed)) + (if (eql name :value-type) + (progn + (setq val (canonicalize-value-type val)) + (setq parsed (append parsed (list name val))) + (setq parsed (append parsed (list :type + (value-type-to-lisp-type + (canonicalize-value-type val)))))) + (setq parsed (append parsed (list name val)))) + (setq initargs (cddr initargs)))) + (defmethod compute-effective-slot-definition :around ((cl hyperobject-class) #+ho-normal-cesd name dsds) @@ -241,17 +267,14 @@ esd))) (defun compute-hyperobject-esd (esd dsds) - (let* ((dsd (car dsds)) - (value-type (canonicalize-value-type (slot-value dsd 'value-type)))) - (multiple-value-bind (sql-type sql-length) - (value-type-to-sql-type value-type) + (let* ((dsd (car dsds))) + (multiple-value-bind (sql-type sql-length) + (value-type-to-sql-type (dsd-value-type dsd)) (setf (esd-sql-type esd) sql-type) (setf (esd-sql-length esd) sql-length)) - (setf (slot-value esd 'type) (value-type-to-lisp-type value-type)) - (setf (esd-value-type esd) value-type) (setf (esd-user-name esd) (aif (dsd-user-name dsd) - it + it (string-downcase (symbol-name (slot-definition-name dsd))))) (setf (esd-sql-name esd) (aif (dsd-sql-name dsd) @@ -261,11 +284,12 @@ (aif (dsd-sql-name dsd) it (lisp-name-to-sql-name (slot-definition-name dsd)))) - (dolist (name '(print-formatter subobject hyperlink hyperlink-parameters + (dolist (name '(value-type print-formatter subobject hyperlink + hyperlink-parameters unbound-lookup 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)) @@ -309,6 +333,8 @@ SQL name" (case (base-value-type value-type) ((:string :cdata :varchar :char) '(or null string)) + (:datetime + '(or null integer)) (:character '(or null character)) (:fixnum @@ -345,6 +371,8 @@ SQL name" :single-float) (:double-float :double-float) + (:datetime + :long-integer) (otherwise :text)) length))) @@ -373,10 +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))))) @@ -385,41 +414,46 @@ 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" (unless (user-name cl) (setf (user-name cl) (format nil "~:(~A~)" (class-name cl)))) - + (setf (user-name-plural cl) (if (and (consp (user-name cl)) (cadr (user-name cl))) (cadr (user-name cl)) @@ -434,7 +468,7 @@ SQL name" (if (listp it) (car it) it)))) - + (unless (sql-name cl) (setf (sql-name cl) (lisp-name-to-sql-name (class-name cl)))) ) @@ -442,7 +476,7 @@ SQL name" (defun finalize-documentation (cl) "Calculate class documentation slot" (let ((*print-circle* nil)) - (setf (documentation (class-name cl) 'class) + (setf (documentation cl 'type) (format nil "Hyperobject~A~A~A~A" (aif (user-name cl) (format nil ": ~A" it "")) @@ -472,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)