X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=ddaee4f0dc1da84bd7276c1e0f7e17ecbdcbb0f9;hp=bed60eeea4825fca492dbd2ebc62cf0943dc07a3;hb=2edf7f68a1dc681db575cda999283cac7e290a77;hpb=5ed1f05543cbd24b3f2bb735f2cfc03ea85e51ec diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index bed60ee..ddaee4f 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -1,8 +1,6 @@ ;;;; -*- 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. @@ -48,6 +46,9 @@ (key-slots :accessor key-slots :initform nil) + (normalizedp + :accessor normalizedp + :initform nil) (class-qualifier :accessor view-class-qualifier :initarg :qualifier @@ -82,15 +83,6 @@ ((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 ())) @@ -103,10 +95,29 @@ (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)) @@ -122,28 +133,20 @@ direct-superclasses) (remove-keyword-arg all-keys :direct-superclasses))) (call-next-method)) - (setf (view-table class) - (table-name-from-arg (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))) @@ -198,14 +201,18 @@ (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 @@ -298,7 +305,13 @@ column definition in the database.") :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 @@ -409,7 +422,7 @@ implementations." 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 @@ -423,35 +436,31 @@ implementations." 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)) - -(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)))) +;; 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) + (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)) + +(defun compute-column-name (arg) + (database-identifier arg nil)) + +(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)))) (defmethod compute-effective-slot-definition ((class standard-db-class) #+kmr-normal-cesd slot-name @@ -464,42 +473,24 @@ implementations." (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)))) + (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)) ;; I wonder if this slot option and the previous could be merged, ;; so that :base and :key remain keyword options, but :db-kind @@ -520,6 +511,14 @@ implementations." (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 @@ -535,10 +534,8 @@ implementations." #+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))) @@ -553,8 +550,11 @@ implementations." 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-if #'(lambda (d) (eql slot (slot-definition-name d))) + (class-slots class))))) #+ignore (eval-when (:compile-toplevel :load-toplevel :execute) @@ -565,3 +565,24 @@ implementations." #+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))