qualifier
&allow-other-keys)
(let ((root-class (find-class 'standard-db-object nil))
- (vmc (find-class 'standard-db-class)))
+ (vmc 'standard-db-class))
(setf (view-class-qualifier class)
(car qualifier))
(if root-class
- (if (member-if #'(lambda (super)
- (eq (class-of super) vmc)) direct-superclasses)
+ (if (some #'(lambda (super) (typep super vmc))
+ direct-superclasses)
(call-next-method)
(apply #'call-next-method
class
direct-superclasses qualifier
&allow-other-keys)
(let ((root-class (find-class 'standard-db-object nil))
- (vmc (find-class 'standard-db-class)))
+ (vmc 'standard-db-class))
(setf (view-table class)
(table-name-from-arg (sql-escape (or (and base-table
(if (listp base-table)
(setf (view-class-qualifier class)
(car qualifier))
(if (and root-class (not (equal class root-class)))
- (if (member-if #'(lambda (super)
- (eq (class-of super) vmc)) direct-superclasses)
+ (if (some #'(lambda (super) (typep super vmc))
+ direct-superclasses)
(call-next-method)
(apply #'call-next-method
class
;; This function is called after the base compute-effective-slots is called.
;; OpenMCL sets the type-predicate based on the initial value of the slots type.
;; so we have to override the type-predicates here
- (cond
- ((consp specified-type)
- (cond
- ((and (symbolp (car specified-type))
- (string-equal (symbol-name (car specified-type)) "string"))
- 'string)
- ((and (symbolp (car specified-type))
- (string-equal (symbol-name (car specified-type)) "varchar"))
- 'string)
- ((and (symbolp (car specified-type))
- (string-equal (symbol-name (car specified-type)) "char"))
- 'string)
- (t
- specified-type)))
- ((eq (ensure-keyword specified-type) :bigint)
- 'integer)
- ((eq (ensure-keyword specified-type) :char)
- 'character)
- ((eq (ensure-keyword specified-type) :varchar)
- 'string)
- ((and specified-type
- (not (eql :not-null (slot-value slotd 'db-constraints))))
- `(or null ,specified-type))
- (t
- specified-type)))
+ (let ((type
+ (cond
+ ((consp specified-type)
+ (cond
+ ((and (symbolp (car specified-type))
+ (string-equal (symbol-name (car specified-type)) "string"))
+ 'string)
+ ((and (symbolp (car specified-type))
+ (string-equal (symbol-name (car specified-type)) "varchar"))
+ 'string)
+ ((and (symbolp (car specified-type))
+ (string-equal (symbol-name (car specified-type)) "char"))
+ 'string)
+ (t
+ specified-type)))
+ ((eq (ensure-keyword specified-type) :bigint)
+ 'integer)
+ ((eq (ensure-keyword specified-type) :char)
+ 'character)
+ ((eq (ensure-keyword specified-type) :varchar)
+ 'string)
+ (t
+ specified-type)))
+ (constraints (slot-value slotd 'db-constraints)))
+ (if (and type (not (member :not-null (listify constraints))))
+ `(or null ,type)
+ type)))
;; Compute the slot definition for slots in a view-class. Figures out
;; what kind of database value (if any) is stored there, generates and
(null (specified-type dsd)))
(setf (specified-type dsd)
(slot-definition-type dsd))
- (setf #-clisp (slot-value dsd 'type)
- #+clisp (slot-definition-type dsd)
+ (setf #-(or clisp sbcl) (slot-value dsd 'type)
+ #+(or clisp sbcl) (slot-definition-type dsd)
(compute-lisp-type-from-slot-specification
dsd (slot-definition-type dsd))))