X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=701181da53a8bb3a4da0217511485eb1587ccb19;hp=f981c900be363b18be8e67cd8db6895e800d465e;hb=11261eca2090842638d1b3b7c12b7cc1f6d58f09;hpb=5953db07cc2276392d0a81052d2d8c71d3252b5a diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index f981c90..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. ;;;; @@ -12,7 +12,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list @@ -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,7 +52,7 @@ :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 @@ -78,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) @@ -131,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)) @@ -167,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) @@ -281,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 @@ -305,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,7 +362,7 @@ column definition in the database.") (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." @@ -392,10 +392,20 @@ which does type checking before storing a value in a slot." ((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)) @@ -413,18 +423,20 @@ which does type checking before storing a value in a slot." (car list) list)) -(declaim (inline delistify)) +(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)) - + ;; KMR: store the user-specified type and then compute ;; real Lisp type and store it (let ((dsd (car direct-slots))) @@ -432,10 +444,11 @@ which does type checking before storing a value in a slot." (null (specified-type dsd))) (setf (specified-type dsd) (slot-definition-type dsd)) - (setf (slot-value dsd 'type) - (compute-lisp-type-from-slot-specification - 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 @@ -448,31 +461,34 @@ which does type checking before storing a value in a slot." (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 )? @@ -489,20 +505,21 @@ which does type checking before storing a value in a slot." ((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))) - (change-class esd 'view-class-effective-slot-definition - #+allegro :name - #+allegro (slot-definition-name dsd)) + #-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)))) @@ -512,7 +529,7 @@ which does type checking before storing a value in a slot." (setf (specified-type esd) (slot-definition-type dsd))) ) esd))) - + (defun slotdefs-for-slots-with-class (slots class) (let ((result nil)) (dolist (s slots)