X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=701181da53a8bb3a4da0217511485eb1587ccb19;hp=d6d92b85ce3595aef251d63779212c3fe69753b1;hb=11261eca2090842638d1b3b7c12b7cc1f6d58f09;hpb=afe872863374de73b2f2ef767e742a40d7465e4a diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index d6d92b8..701181d 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -3,7 +3,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; CLSQL metaclass for standard-db-objects created in the OODDL. +;;;; CLSQL metaclass for standard-db-objects created in the OODDL. ;;;; ;;;; This file is part of CLSQL. ;;;; @@ -20,13 +20,13 @@ 'compute-effective-slot-definition))) 3) (pushnew :kmr-normal-cesd cl:*features*)) - + (when (>= (length (generic-function-lambda-list (ensure-generic-function 'direct-slot-definition-class))) 3) (pushnew :kmr-normal-dsdc cl:*features*)) - + (when (>= (length (generic-function-lambda-list (ensure-generic-function 'effective-slot-definition-class))) @@ -52,19 +52,21 @@ :accessor view-class-qualifier :initarg :qualifier :initform nil)) - (:documentation "VIEW-CLASS metaclass.")) + (:documentation "Metaclass for all CLSQL View Classes.")) ;;; Lispworks 4.2 and before requires special processing of extra slot and class options -(defvar +extra-slot-options+ '(:column :db-kind :db-reader :void-value :db-constraints +(defvar +extra-slot-options+ '(:column :db-kind :db-type :db-reader :void-value :db-constraints :db-writer :db-info)) (defvar +extra-class-options+ '(:base-table)) +#+lispworks (dolist (slot-option +extra-slot-options+) - (process-slot-option standard-db-class slot-option)) + (eval `(process-slot-option standard-db-class ,slot-option))) +#+lispworks (dolist (class-option +extra-class-options+) - (process-class-option standard-db-class class-option)) + (eval `(process-class-option standard-db-class ,class-option))) (defmethod validate-superclass ((class standard-db-class) (superclass standard-class)) @@ -76,7 +78,7 @@ ((typep arg 'sql-ident) (slot-value arg 'name)) ((stringp arg) - (intern (symbol-name-default-case arg))))) + (intern arg)))) (defun column-name-from-arg (arg) (cond ((symbolp arg) @@ -129,7 +131,7 @@ (defmethod reinitialize-instance :around ((class standard-db-class) &rest all-keys - &key base-table + &key base-table direct-superclasses qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) @@ -165,9 +167,9 @@ (defun describe-db-layout (class) (flet ((not-db-col (col) - (not (member (nth 2 col) '(nil :base :key)))) + (not (member (nth 2 col) '(nil :base :key)))) (frob-slot (slot) - (let ((type (slot-value slot 'type))) + (let ((type (slot-definition-type slot))) (if (eq type t) (setq type nil)) (list (slot-value slot 'name) @@ -190,23 +192,14 @@ (setq all-slots (remove-if #'not-db-col all-slots)) (setq all-slots (stable-sort all-slots #'string< :key #'car)) (setf (object-definition class) all-slots)) - #-(or allegro openmcl) + #-allegro (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) (ordered-class-slots class))))) -#+(or allegro openmcl) +#+allegro (defmethod finalize-inheritance :after ((class standard-db-class)) - ;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false - ;; for standard-db-class - #+openmcl - (mapcar - #'(lambda (s) - (if (eq 'ccl:false (slot-value s 'ccl::type-predicate)) - (setf (slot-value s 'ccl::type-predicate) 'ccl:true))) - (class-slots class)) - (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) @@ -246,7 +239,9 @@ the slot name.") :accessor view-class-slot-db-kind :initarg :db-kind :initform :base - :type keyword + ;; openmcl 0.14.2 stores the value as list in the DSD + ;; :type (or list keyword) + #-openmcl :type #-openmcl keyword :documentation "The kind of DB mapping which is performed for this slot. :base indicates the slot maps to an ordinary column of the DB view. :key @@ -286,13 +281,13 @@ column definition in the database.") :initarg :db-constraints :initform nil :documentation - "A single constraint or list of constraints for this column") + "A keyword symbol representing a single SQL column constraint or list of such symbols.") (void-value :accessor view-class-slot-void-value :initarg :void-value :initform nil :documentation - "Value to store is the SQL value is NULL. Default is NIL.") + "Value to store if the SQL value is NULL. Default is NIL.") (db-info :accessor view-class-slot-db-info :initarg :db-info @@ -310,11 +305,11 @@ column definition in the database.") (target-slot nil) (retrieval :immmediate) (set nil))) - + (defun parse-db-info (db-info-list) (destructuring-bind (&key join-class home-key key-join foreign-key (delete-rule nil) - (target-slot nil) (retrieval :deferred) (set nil)) + (target-slot nil) (retrieval :deferred) (set t)) db-info-list (let ((ih (make-hash-table :size 6))) (if join-class @@ -362,11 +357,12 @@ column definition in the database.") (find-class 'view-class-effective-slot-definition)) #+openmcl -(defun compute-class-precedence-list (class) - ;; safe to call this in openmcl - (class-precedence-list class)) +(when (not (symbol-function 'compute-class-precedence-list)) + (eval + (defun compute-class-precedence-list (class) + (class-precedence-list class)))) -#-(or sbcl cmu) +#-mop-slot-order-reversed (defmethod compute-slots ((class standard-db-class)) "Need to sort order of class slots so they are the same across implementations." @@ -387,7 +383,6 @@ implementations." (defun compute-lisp-type-from-slot-specification (slotd specified-type) "Computes the Lisp type for a user-specified type. Needed for OpenMCL which does type checking before storing a value in a slot." - #-openmcl (declare (ignore slotd)) ;; 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 @@ -396,101 +391,144 @@ which does type checking before storing a value in a slot." (cond ((and (symbolp (car specified-type)) (string-equal (symbol-name (car specified-type)) "string")) - #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'stringp) + '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 - #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true) specified-type))) - #+openmcl - ((null specified-type) - ;; setting this here is not enough since openmcl later sets the - ;; type-predicate to ccl:false. So, have to check slots again - ;; in finalize-inheritance - #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true) - t) + ((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 - ;; This can be improved for OpenMCL to set a more specific type - ;; predicate based on the value specified-type - #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true) specified-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 ;; verifies the column name. +(declaim (inline delistify)) +(defun delistify (list) + "Some MOPs, like openmcl 0.14.2, cons attribute values in a list." + (if (listp list) + (car list) + 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)) + +(defvar *impl-type-attrib-name* #-clisp 'type #+clisp 'clos::$type) + (defmethod compute-effective-slot-definition ((class standard-db-class) #+kmr-normal-cesd slot-name direct-slots) #+kmr-normal-cesd (declare (ignore slot-name)) - (let ((slotd (call-next-method)) - (sd (car direct-slots))) - - (typecase sd - (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 slotd 'column) - (column-name-from-arg - (if (slot-boundp sd 'column) - (view-class-slot-column sd) - (column-name-from-arg - (sql-escape (slot-definition-name sd)))))) - - (setf (slot-value slotd 'db-type) - (when (slot-boundp sd 'db-type) - (view-class-slot-db-type sd))) - - (setf (slot-value slotd 'void-value) - (view-class-slot-void-value sd)) - - ;; :db-kind slot value defaults to :base (store slot value in - ;; database) - - (setf (slot-value slotd 'db-kind) - (if (slot-boundp sd 'db-kind) - (view-class-slot-db-kind sd) - :base)) - - (setf (slot-value slotd 'db-writer) - (when (slot-boundp sd 'db-writer) - (view-class-slot-db-writer sd))) - (setf (slot-value slotd 'db-constraints) - (when (slot-boundp sd 'db-constraints) - (view-class-slot-db-constraints sd))) - - ;; 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 )? - - (setf (slot-value slotd 'db-info) - (when (slot-boundp sd 'db-info) - (if (listp (view-class-slot-db-info sd)) - (parse-db-info (view-class-slot-db-info sd)) - (view-class-slot-db-info sd)))) - - ;; KMR: store the user-specified type and then compute - ;; real Lisp type and store it - (setf (specified-type slotd) - (slot-definition-type slotd)) - (setf (slot-value slotd 'type) - (compute-lisp-type-from-slot-specification - slotd (slot-definition-type slotd))) - ) - ;; all other slots - (t - (change-class slotd 'view-class-effective-slot-definition - #+allegro :name - #+allegro (slot-definition-name sd)) - (setf (slot-value slotd 'column) - (column-name-from-arg - (sql-escape (slot-definition-name sd)))) - - (setf (slot-value slotd 'db-info) nil) - (setf (slot-value slotd 'db-kind) - :virtual))) - slotd)) + ;; KMR: store the user-specified type and then compute + ;; real Lisp type and store it + (let ((dsd (car direct-slots))) + (when (and (typep dsd 'view-class-slot-definition-mixin) + (null (specified-type dsd))) + (setf (specified-type dsd) + (slot-definition-type dsd)) + (setf #-clisp (slot-value dsd 'type) + #+clisp (slot-definition-type dsd) + (compute-lisp-type-from-slot-specification + dsd (slot-definition-type dsd)))) + + (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 )? + + (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 (specified-type esd) + (delistify-dsd (specified-type dsd))) + + ) + ;; all other slots + (t + (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate))) + #-openmcl (declare (ignore type-predicate)) + #-(or clisp sbcl) (change-class esd 'view-class-effective-slot-definition + #+allegro :name + #+allegro (slot-definition-name dsd)) + #+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)))) + + (setf (slot-value esd 'db-info) nil) + (setf (slot-value esd 'db-kind) :virtual) + (setf (specified-type esd) (slot-definition-type dsd))) + ) + esd))) (defun slotdefs-for-slots-with-class (slots class) (let ((result nil))