X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=mop.lisp;h=2ccf8d685a106ae8e51f3111781a90b495ce9442;hb=b5ae9d611ffe002ecdb5d19d926b952857cd26c4;hp=528c99f58c77d311270ab78f796fa0ded9b4dd22;hpb=0817a8721cbefca2205dcde535ff6b164033abef;p=hyperobject.git diff --git a/mop.lisp b/mop.lisp index 528c99f..2ccf8d6 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,7 +47,7 @@ ;;; 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.") @@ -64,6 +64,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) @@ -110,13 +112,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 +120,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 +169,7 @@ #-lispworks (declare (ignore slot-name)) ) - + (dolist (option *class-options*) (eval `(process-class-option ,option))) (dolist (option *slot-options*) @@ -231,6 +227,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 +253,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,7 +270,8 @@ (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 @@ -309,6 +319,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 +357,8 @@ SQL name" :single-float) (:double-float :double-float) + (:datetime + :long-integer) (otherwise :text)) length))) @@ -373,8 +387,9 @@ 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 subobj-class reader &rest reader-keys) + (declare (ignore class-name)) (setf (getf (gethash cl *lazy-readers*) slot-name) (aif subobj-class it @@ -419,7 +434,7 @@ SQL name" "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 +449,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 +457,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 ""))