(key-slots
:accessor key-slots
:initform nil)
- (normalisedp
- :accessor normalisedp
+ (normalizedp
+ :accessor normalizedp
:initform nil)
(class-qualifier
:accessor view-class-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)))
(defmethod initialize-instance :around ((class standard-db-class)
&rest all-keys
&key direct-superclasses base-table
- qualifier normalisedp
+ 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 (normalisedp class) (car normalisedp))
+ (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 normalisedp
+ &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 (normalisedp class) (car normalisedp))
+ (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))
- (if (normalisedp class)
+ (if (normalizedp class)
(ordered-class-direct-slots class)
(ordered-class-slots class))))))
(setf (key-slots class) (remove-if-not (lambda (slot)
(eql (slot-value slot 'db-kind)
:key))
- (if (normalisedp class)
+ (if (normalizedp class)
(ordered-class-direct-slots class)
(ordered-class-slots 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)
(setf (specified-type esd)
(delistify-dsd (specified-type dsd)))
+ ;; In older SBCL's the type-check-function is computed at
+ ;; defclass expansion, which is too early for the CLSQL type
+ ;; conversion to take place. This gets rid of it. It's ugly
+ ;; but it's better than nothing -wcp10/4/10.
+ #+(and sbcl #.(cl:if (cl:find-symbol "%TYPE-CHECK-FUNCTION" :sb-pcl) '(and) '(or)))
+ (setf (slot-value esd 'sb-pcl::%type-check-function) nil)
)
;; all other slots