;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id$
-;;;;
;;;; CLSQL metaclass for standard-db-objects created in the OODDL.
;;;;
;;;; This file is part of CLSQL.
(key-slots
:accessor key-slots
:initform nil)
+ (normalizedp
+ :accessor normalizedp
+ :initform nil)
(class-qualifier
:accessor view-class-qualifier
:initarg :qualifier
(defun table-name-from-arg (arg)
(cond ((symbolp arg)
- arg)
+ (intern (sql-escape arg)))
((typep arg 'sql-ident)
- (slot-value arg 'name))
+ (if (symbolp (slot-value arg 'name))
+ (intern (sql-escape (slot-value arg 'name)))
+ (sql-escape (slot-value arg 'name))))
((stringp arg)
- (intern arg))))
+ (sql-escape arg))))
(defun column-name-from-arg (arg)
(cond ((symbolp arg)
(pop-arg mylist))
newlist))
+(defun set-view-table-slot (class base-table)
+ (setf (view-table class)
+ (table-name-from-arg (or (and base-table
+ (if (listp base-table)
+ (car base-table)
+ 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))
direct-superclasses)
(remove-keyword-arg all-keys :direct-superclasses)))
(call-next-method))
- (setf (view-table class)
- (table-name-from-arg (sql-escape (or (and base-table
- (if (listp base-table)
- (car base-table)
- base-table))
- (class-name class)))))
+ (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))
- (setf (view-table class)
- (table-name-from-arg (sql-escape (or (and base-table
- (if (listp base-table)
- (car base-table)
- base-table))
- (class-name 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
:accessor specified-type
:initarg specified-type
:initform nil
- :documentation "Internal slot storing the :type specified by user.")))
+ :documentation "Internal slot storing the :type specified by user.")
+ (autoincrement-sequence
+ :accessor view-class-slot-autoincrement-sequence
+ :initarg :autoincrement-sequence
+ :initform nil
+ :documentation "A string naming the (possibly automatically generated) sequence
+for a slot with an :auto-increment constraint.")))
(defparameter *db-info-lambda-list*
'(&key join-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
(car list)
list))
-(defmethod initialize-instance :around ((obj view-class-direct-slot-definition)
- &rest initargs)
- (do* ((parsed (list obj))
- (name (first initargs) (first initargs))
- (val (second initargs) (second initargs))
- (type nil)
- (db-constraints nil))
- ((null initargs)
- (setq parsed
- (append parsed
- (list 'specified-type type
- :type (compute-lisp-type-from-specified-type
- type db-constraints))))
- (apply #'call-next-method parsed))
- (case name
- (:db-constraints
- (setq db-constraints val)
- (setq parsed (append parsed (list name val))))
- (:type
- (setq type val))
- (t
- (setq parsed (append parsed (list name val)))))
- (setq initargs (cddr initargs))))
+(defmethod initialize-instance :around
+ ((obj view-class-direct-slot-definition)
+ &rest initargs &key db-constraints db-kind type &allow-other-keys)
+ (when (and (not db-kind) (member :primary-key (listify db-constraints)))
+ (warn "Slot ~S constrained to be :primary-key, but not marked as :db-kind :key"
+ (slot-definition-name obj)))
+ (apply #'call-next-method obj
+ 'specified-type type
+ :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)
#+kmr-normal-cesd slot-name
(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:and (cl:find-package :sb-pcl)
+ (cl:find-symbol "%TYPE-CHECK-FUNCTION" :sb-pcl))
+ '(cl:and) '(cl:or)))
+ (setf (slot-value esd 'sb-pcl::%type-check-function) nil)
)
;; all other slots
projects / clsql.git / blobdiff