((stringp arg)
(sql-escape arg))))
-(defun column-name-from-arg (arg)
- (cond ((symbolp arg)
- arg)
- ((typep arg 'sql-ident)
- (slot-value arg 'name))
- ((stringp arg)
- (intern (symbol-name-default-case arg)))))
-
-
(defun remove-keyword-arg (arglist akey)
(let ((mylist arglist)
(newlist ()))
base-table))
(class-name 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
(setf (key-slots class) (remove-if-not (lambda (slot)
(eql (slot-value slot 'db-kind)
:key))
- (if (normalizedp class)
- (ordered-class-direct-slots class)
- (ordered-class-slots class))))))
+ (slots-for-possibly-normalized-class 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))
- (if (normalizedp class)
- (ordered-class-direct-slots class)
- (ordered-class-slots class)))))
+ (slots-for-possibly-normalized-class 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
list))
(declaim (inline delistify-dsd))
-(defun delistify-dsd (list)
- "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
- (if (and (listp list) (null (cdr list)))
- (car list)
- list))
-
+;; there is an :after method below too
(defmethod initialize-instance :around
((obj view-class-direct-slot-definition)
&rest initargs &key db-constraints db-kind type &allow-other-keys)
(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))
+(defun compute-column-name (arg)
+ (database-identifier arg nil))
+
+(defun %convert-db-info-to-hash (slot-def)
+ ;; I wonder if this slot option and the previous could be merged,
+ ;; so that :base and :key remain keyword options, but :db-kind
+ ;; :join becomes :db-kind (:join <db info .... >)?
+ (setf (slot-value slot-def 'db-info)
+ (when (slot-boundp slot-def 'db-info)
+ (let ((info (view-class-slot-db-info slot-def)))
+ (etypecase info
+ (hash-table info)
+ (atom info)
+ (list
+ (cond ((and (> (length info) 1)
+ (atom (car info)))
+ (parse-db-info info))
+ ((and (= 1 (length info))
+ (listp (car info)))
+ (parse-db-info (car info)))
+ (t info))))))))
+
+(defmethod initialize-instance :after
+ ((obj view-class-direct-slot-definition)
+ &key &allow-other-keys)
+ (setf (view-class-slot-column obj) (compute-column-name obj)
+ (view-class-slot-autoincrement-sequence obj)
+ (dequote
+ (view-class-slot-autoincrement-sequence obj)))
+ (%convert-db-info-to-hash obj))
+
(defmethod compute-effective-slot-definition ((class standard-db-class)
#+kmr-normal-cesd slot-name
direct-slots)
(let ((esd (call-next-method)))
(typecase dsd
(view-class-slot-definition-mixin
- ;; Use the specified :column argument if it is supplied, otherwise
- ;; the column slot is filled in with the slot-name, but transformed
- ;; to be sql safe, - to _ and such.
- (setf (slot-value esd 'column)
- (column-name-from-arg
- (if (slot-boundp dsd 'column)
- (delistify-dsd (view-class-slot-column dsd))
- (column-name-from-arg
- (sql-escape (slot-definition-name dsd))))))
-
- (setf (slot-value esd 'db-type)
- (when (slot-boundp dsd 'db-type)
- (delistify-dsd
- (view-class-slot-db-type dsd))))
-
- (setf (slot-value esd 'void-value)
- (delistify-dsd
- (view-class-slot-void-value dsd)))
-
- ;; :db-kind slot value defaults to :base (store slot value in
- ;; database)
-
- (setf (slot-value esd 'db-kind)
- (if (slot-boundp dsd 'db-kind)
- (delistify-dsd (view-class-slot-db-kind dsd))
- :base))
-
- (setf (slot-value esd 'db-reader)
- (when (slot-boundp dsd 'db-reader)
- (delistify-dsd (view-class-slot-db-reader dsd))))
- (setf (slot-value esd 'db-writer)
- (when (slot-boundp dsd 'db-writer)
- (delistify-dsd (view-class-slot-db-writer dsd))))
- (setf (slot-value esd 'db-constraints)
- (when (slot-boundp dsd 'db-constraints)
- (delistify-dsd (view-class-slot-db-constraints dsd))))
-
- ;; I wonder if this slot option and the previous could be merged,
- ;; so that :base and :key remain keyword options, but :db-kind
- ;; :join becomes :db-kind (:join <db info .... >)?
-
- (setf (slot-value esd 'db-info)
- (when (slot-boundp dsd 'db-info)
- (let ((dsd-info (view-class-slot-db-info dsd)))
- (cond
- ((atom dsd-info)
- dsd-info)
- ((and (listp dsd-info) (> (length dsd-info) 1)
- (atom (car dsd-info)))
- (parse-db-info dsd-info))
- ((and (listp dsd-info) (= 1 (length dsd-info))
- (listp (car dsd-info)))
- (parse-db-info (car dsd-info)))))))
+ (setf (slot-value esd 'column) (compute-column-name dsd))
+
+ (macrolet
+ ((safe-copy-value (name &optional default)
+ (let ((fn (intern (format nil "~A~A" 'view-class-slot- name ))))
+ `(setf (slot-value esd ',name)
+ (or (when (slot-boundp dsd ',name)
+ (delistify-dsd (,fn dsd)))
+ ,default)))))
+ (safe-copy-value autoincrement-sequence)
+ (safe-copy-value db-type)
+ (safe-copy-value void-value)
+ (safe-copy-value db-reader)
+ (safe-copy-value db-writer)
+ ;; :db-kind slot value defaults to :base (store slot value in
+ ;; database)
+ (safe-copy-value db-kind :base)
+ (safe-copy-value db-constraints)
+ (safe-copy-value db-info)
+ (%convert-db-info-to-hash esd))
(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
#+openmcl (setf (slot-value esd 'ccl::type-predicate)
type-predicate)))
- (setf (slot-value esd 'column)
- (column-name-from-arg
- (sql-escape (slot-definition-name dsd))))
-
+ ;; has no column name if it is not a database column
+ (setf (slot-value esd 'column) nil)
(setf (slot-value esd 'db-info) nil)
(setf (slot-value esd 'db-kind) :virtual)
(setf (specified-type esd) (slot-definition-type dsd)))
result))
(defun slotdef-for-slot-with-class (slot class)
- (find-if #'(lambda (d) (eql slot (slot-definition-name d)))
- (class-slots class)))
+ (typecase slot
+ (standard-slot-definition slot)
+ (symbol (find-slot-by-name class slot))))
#+ignore
(eval-when (:compile-toplevel :load-toplevel :execute)
#+kmr-normal-esdc
(setq cl:*features* (delete :kmr-normal-esdc cl:*features*))
)
+
+(defmethod database-identifier ( (name standard-db-class)
+ &optional database find-class-p)
+ "the majority of this function is in expressions.lisp
+ this is here to make loading be less painful (try-recompiles) in SBCL"
+ (declare (ignore find-class-p))
+ (database-identifier (view-table name) database))
+
+(defmethod database-identifier ((name view-class-slot-definition-mixin)
+ &optional database find-class-p)
+ (declare (ignore find-class-p))
+ (database-identifier
+ (if (slot-boundp name 'column)
+ (delistify-dsd (view-class-slot-column name))
+ (slot-definition-name name))
+ database))
+
+(defun find-standard-db-class (name &aux cls)
+ (and (setf cls (ignore-errors (find-class name)))
+ (typep cls 'standard-db-class)
+ cls))
+
+(defun slots-for-possibly-normalized-class (class)
+ "Get the slots for this class, if normalized this is only the direct slots
+ otherwiese its all the slots"
+ (if (normalizedp class)
+ (ordered-class-direct-slots class)
+ (ordered-class-slots class)))
+
+
+(defun key-slot-p (slot-def)
+ "takes a slot def and returns whether or not it is a key"
+ (eql :key (view-class-slot-db-kind slot-def)))
+
+(defun join-slot-p (slot-def)
+ "takes a slot def and returns whether or not it is a join slot"
+ (eql :join (view-class-slot-db-kind slot-def)))
+
+(defun join-slot-info-value (slot-def key)
+ "Get the join-slot db-info value associated with a key"
+ (when (join-slot-p slot-def)
+ (let ((dbi (view-class-slot-db-info slot-def)))
+ (when dbi (gethash key dbi)))))
+
+(defun join-slot-retrieval-method (slot-def)
+ "if this is a join slot return the retrieval param in the db-info"
+ (join-slot-info-value slot-def :retrieval))
+
+(defun join-slot-class-name (slot-def)
+ "get the join class name for a given join slot"
+ (join-slot-info-value slot-def :join-class))
+
+(defun join-slot-class (slot-def)
+ "Get the join class for a given join slot"
+ (let ((c (join-slot-class-name slot-def)))
+ (when c (find-class c))))
+
+(defun key-or-base-slot-p (slot-def)
+ "takes a slot def and returns whether or not it is a key"
+ (member (view-class-slot-db-kind slot-def) '(:key :base)))
+
+(defun direct-normalized-slot-p (class slot-name)
+ "Is this a normalized class and if so is the slot one of our direct slots?"
+ (setf slot-name (to-slot-name slot-name))
+ (and (typep class 'standard-db-class)
+ (normalizedp class)
+ (member slot-name (ordered-class-direct-slots class)
+ :key #'slot-definition-name)))
+
+(defun not-direct-normalized-slot-p (class slot-name)
+ "Is this a normalized class and if so is the slot not one of our direct slots?"
+ (setf slot-name (to-slot-name slot-name))
+ (and (typep class 'standard-db-class)
+ (normalizedp class)
+ (not (member slot-name (ordered-class-direct-slots class)
+ :key #'slot-definition-name))))
+
+(defun slot-has-default-p (slot)
+ "returns nil if the slot does not have a default constraint"
+ (let* ((constraints
+ (when (typep slot '(or view-class-direct-slot-definition
+ view-class-effective-slot-definition))
+ (listify (view-class-slot-db-constraints slot)))))
+ (member :default constraints)))
+
projects / clsql.git / blobdiff