X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=082b1d3c111079a487953b643751d1ad5a8cd231;hb=2d4e5fd3f01bd461e573e246c0fd9b6a944d8e5a;hp=ac0592087e6add41f5d3ed03428b5f3056b638a2;hpb=9a70270bf9a1d60323ded33ce52bd0904544c70b;p=clsql.git diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index ac05920..082b1d3 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -12,7 +12,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql-sys) +(in-package #:clsql) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list @@ -54,92 +54,17 @@ :initform nil)) (:documentation "VIEW-CLASS metaclass.")) -#+lispworks -(defmacro push-on-end (value location) - `(setf ,location (nconc ,location (list ,value)))) - -;; As Heiko Kirscke (author of PLOB!) would say: !@##^@%! Lispworks! -#+lispworks -(defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok - :db-writer :db-type :db-info)) - -#+lispworks -(define-setf-expander assoc (key alist &environment env) - (multiple-value-bind (temps vals stores store-form access-form) - (get-setf-expansion alist env) - (let ((new-value (gensym "NEW-VALUE-")) - (keyed (gensym "KEYED-")) - (accessed (gensym "ACCESSED-")) - (store-new-value (car stores))) - (values (cons keyed temps) - (cons key vals) - `(,new-value) - `(let* ((,accessed ,access-form) - (,store-new-value (assoc ,keyed ,accessed))) - (if ,store-new-value - (rplacd ,store-new-value ,new-value) - (progn - (setq ,store-new-value - (acons ,keyed ,new-value ,accessed)) - ,store-form)) - ,new-value) - `(assoc ,new-value ,access-form))))) - -#+lispworks -(defmethod clos::canonicalize-defclass-slot :around - ((prototype standard-db-class) slot) - "\\lw\\ signals an error on unknown slot options; so this method -removes any extra allowed options before calling the default method -and returns the canonicalized extra options concatenated to the result -of the default method. The extra allowed options are the value of the -\\fcite{+extra-slot-options+}." - (let ((extra-slot-options ()) - (rest-options ()) - (result ())) - (do ((olist (cdr slot) (cddr olist))) - ((null olist)) - (let ((option (car olist))) - (cond - ((find option +extra-slot-options+) - ;;(push (cons option (cadr olist)) extra-slot-options)) - (setf (assoc option extra-slot-options) (cadr olist))) - (t - (push (cadr olist) rest-options) - (push (car olist) rest-options))))) - (setf result (call-next-method prototype (cons (car slot) rest-options))) - (dolist (option extra-slot-options) - (push-on-end (car option) result) - (push-on-end `(quote ,(cdr option)) result)) - result)) +;;; Lispworks 4.2 and before requires special processing of extra slot and class options -#+lispworks -(defconstant +extra-class-options+ '(:base-table)) - -#+lispworks -(defmethod clos::canonicalize-class-options :around - ((prototype standard-db-class) class-options) - "\\lw\\ signals an error on unknown class options; so this method -removes any extra allowed options before calling the default method -and returns the canonicalized extra options concatenated to the result -of the default method. The extra allowed options are the value of the -\\fcite{+extra-class-options+}." - (let ((extra-class-options nil) - (rest-options ()) - (result ())) - (dolist (o class-options) - (let ((option (car o))) - (cond - ((find option +extra-class-options+) - ;;(push (cons option (cadr o)) extra-class-options)) - (setf (assoc option extra-class-options) (cadr o))) - (t - (push o rest-options))))) - (setf result (call-next-method prototype rest-options)) - (dolist (option extra-class-options) - (push-on-end (car option) result) - (push-on-end `(quote ,(cdr option)) result)) - result)) +(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)) +(dolist (slot-option +extra-slot-options+) + (process-slot-option standard-db-class slot-option)) + +(dolist (class-option +extra-class-options+) + (process-class-option standard-db-class class-option)) (defmethod validate-superclass ((class standard-db-class) (superclass standard-class)) @@ -273,15 +198,6 @@ of the default method. The extra allowed options are the value of the #+(or allegro openmcl) (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)) @@ -362,13 +278,12 @@ column definition in the database.") :initform nil :documentation "A single constraint or list of constraints for this column") - (nulls-ok - :accessor view-class-slot-nulls-ok - :initarg :nulls-ok + (void-value + :accessor view-class-slot-void-value + :initarg :void-value :initform nil :documentation - "If t, all sql NULL values retrieved from the database become nil; if nil, -all NULL values retrieved are converted by DATABASE-NULL-VALUE") + "Value to store is the SQL value is NULL. Default is NIL.") (db-info :accessor view-class-slot-db-info :initarg :db-info @@ -463,7 +378,7 @@ 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)) + (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 @@ -472,22 +387,15 @@ 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) (t - #+openmcl (setf (slot-value slotd 'ccl::type-predicate) 'ccl:true) specified-type))) + ((eq (ensure-keyword specified-type) :bigint) + 'integer) #+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) (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 @@ -498,76 +406,81 @@ which does type checking before storing a value in a slot." #+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 'nulls-ok) - (view-class-slot-nulls-ok 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 (slot-value dsd 'type) + (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) + (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) + (view-class-slot-db-type dsd))) + + (setf (slot-value esd 'void-value) + (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) + (view-class-slot-db-kind dsd) + :base)) + + (setf (slot-value esd 'db-writer) + (when (slot-boundp dsd 'db-writer) + (view-class-slot-db-writer dsd))) + (setf (slot-value esd 'db-constraints) + (when (slot-boundp dsd 'db-constraints) + (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) + (if (listp (view-class-slot-db-info dsd)) + (parse-db-info (view-class-slot-db-info dsd)) + (view-class-slot-db-info dsd)))) + + (setf (specified-type esd) (specified-type dsd)) + + ) + ;; all other slots + (t + (change-class esd 'view-class-effective-slot-definition + #+allegro :name + #+allegro (slot-definition-name dsd)) + + (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))) + esd))) + (defun slotdefs-for-slots-with-class (slots class) (let ((result nil)) (dolist (s slots)