(key-slots
:accessor key-slots
:initform nil)
+ (normalizedp
+ :accessor normalizedp
+ :initform nil)
(class-qualifier
:accessor view-class-qualifier
:initarg :qualifier
base-table))
(class-name class)))))
+(defgeneric ordered-class-direct-slots (class))
+(defmethod ordered-class-direct-slots ((self standard-db-class))
+ (let ((direct-slot-names
+ (mapcar #'slot-definition-name (class-direct-slots self)))
+ (ordered-direct-class-slots '()))
+ (dolist (slot (ordered-class-slots self))
+ (let ((slot-name (slot-definition-name slot)))
+ (when (find slot-name direct-slot-names)
+ (push slot ordered-direct-class-slots))))
+ (nreverse ordered-direct-class-slots)))
+
(defmethod initialize-instance :around ((class standard-db-class)
&rest all-keys
&key direct-superclasses base-table
- qualifier
+ qualifier normalizedp
&allow-other-keys)
(let ((root-class (find-class 'standard-db-object nil))
(vmc 'standard-db-class))
(remove-keyword-arg all-keys :direct-superclasses)))
(call-next-method))
(set-view-table-slot class base-table)
+ (setf (normalizedp class) (car normalizedp))
(register-metaclass class (nth (1+ (position :direct-slots all-keys))
all-keys))))
(defmethod reinitialize-instance :around ((class standard-db-class)
&rest all-keys
- &key base-table
+ &key base-table normalizedp
direct-superclasses qualifier
&allow-other-keys)
(let ((root-class (find-class 'standard-db-object nil))
(vmc 'standard-db-class))
(set-view-table-slot class base-table)
+ (setf (normalizedp class) (car normalizedp))
(setf (view-class-qualifier class)
(car qualifier))
(if (and root-class (not (equal class root-class)))
(setf (key-slots class) (remove-if-not (lambda (slot)
(eql (slot-value slot 'db-kind)
:key))
- (ordered-class-slots class)))))
+ (if (normalizedp class)
+ (ordered-class-direct-slots class)
+ (ordered-class-slots class))))))
#+(or sbcl allegro)
(defmethod finalize-inheritance :after ((class standard-db-class))
(setf (key-slots class) (remove-if-not (lambda (slot)
(eql (slot-value slot 'db-kind)
:key))
- (ordered-class-slots class))))
+ (if (normalizedp class)
+ (ordered-class-direct-slots class)
+ (ordered-class-slots class)))))
;; return the deepest view-class ancestor for a given view class
specified-type))))
(if (and type (not (member :not-null (listify db-constraints))))
`(or null ,type)
- type)))
+ (or type t))))
;; Compute the slot definition for slots in a view-class. Figures out
;; what kind of database value (if any) is stored there, generates and
(slot-definition-name obj)))
(apply #'call-next-method obj
'specified-type type
- :type (compute-lisp-type-from-specified-type
- type db-constraints)
+ :type (if (and (eql db-kind :virtual) (null type))
+ t
+ (compute-lisp-type-from-specified-type
+ type db-constraints))
initargs))
(defmethod compute-effective-slot-definition ((class standard-db-class)