X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=d6d92b85ce3595aef251d63779212c3fe69753b1;hb=913477a11d2258f8fe87ff5b390c8904d17d66fe;hp=9d2924ab46b56431f1ed8faa84c736c71a8340cb;hpb=5a6f424f3c8920f8f11bbf1e3aed6b4c2c7e6af8;p=clsql.git diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 9d2924a..d6d92b8 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -1,15 +1,16 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; $Id: $ -;;;; ====================================================================== +;;;; ************************************************************************* ;;;; -;;;; Description ========================================================== -;;;; ====================================================================== +;;;; $Id$ ;;;; ;;;; CLSQL metaclass for standard-db-objects created in the OODDL. ;;;; -;;;; ====================================================================== - +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* (in-package #:clsql-sys) @@ -44,10 +45,6 @@ :accessor object-definition :initarg :definition :initform nil) - (version - :accessor object-version - :initarg :version - :initform 0) (key-slots :accessor key-slots :initform nil) @@ -57,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 :version :schemas)) - -#+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-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)) @@ -154,7 +76,7 @@ of the default method. The extra allowed options are the value of the ((typep arg 'sql-ident) (slot-value arg 'name)) ((stringp arg) - (intern (string-upcase arg))))) + (intern (symbol-name-default-case arg))))) (defun column-name-from-arg (arg) (cond ((symbolp arg) @@ -162,7 +84,7 @@ of the default method. The extra allowed options are the value of the ((typep arg 'sql-ident) (slot-value arg 'name)) ((stringp arg) - (intern (string-upcase arg))))) + (intern (symbol-name-default-case arg))))) (defun remove-keyword-arg (arglist akey) @@ -180,7 +102,7 @@ of the default method. The extra allowed options are the value of the (defmethod initialize-instance :around ((class standard-db-class) &rest all-keys &key direct-superclasses base-table - schemas version qualifier + qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) (vmc (find-class 'standard-db-class))) @@ -202,16 +124,12 @@ of the default method. The extra allowed options are the value of the (car base-table) base-table)) (class-name class))))) - (setf (object-version class) version) - (mapc (lambda (schema) - (pushnew (class-name class) (gethash schema *object-schemas*))) - (if (listp schemas) schemas (list schemas))) (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 schemas version + &key base-table direct-superclasses qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) @@ -234,10 +152,6 @@ of the default method. The extra allowed options are the value of the direct-superclasses) (remove-keyword-arg all-keys :direct-superclasses))) (call-next-method))) - (setf (object-version class) version) - (mapc (lambda (schema) - (pushnew (class-name class) (gethash schema *object-schemas*))) - (if (listp schemas) schemas (list schemas))) (register-metaclass class (nth (1+ (position :direct-slots all-keys)) all-keys))) @@ -261,7 +175,7 @@ of the default method. The extra allowed options are the value of the (slot-value slot 'db-kind) (and (slot-boundp slot 'column) (slot-value slot 'column)))))) - (let ((all-slots (mapcar #'frob-slot (class-slots class)))) + (let ((all-slots (mapcar #'frob-slot (ordered-class-slots class)))) (setq all-slots (remove-if #'not-db-col all-slots)) (setq all-slots (stable-sort all-slots #'string< :key #'car)) ;;(mapcar #'dink-type all-slots) @@ -280,14 +194,23 @@ of the default method. The extra allowed options are the value of the (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) - (class-slots class))))) + (ordered-class-slots class))))) #+(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)) - (class-slots class)))) + (ordered-class-slots class)))) ;; return the deepest view-class ancestor for a given view class @@ -364,17 +287,20 @@ 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 - :documentation "Description of the join."))) + :documentation "Description of the join.") + (specified-type + :accessor specified-type + :initform nil + :documentation "KMR: Internal slot storing the :type specified by user."))) (defparameter *db-info-lambda-list* '(&key join-class @@ -435,6 +361,59 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (declare (ignore initargs)) (find-class 'view-class-effective-slot-definition)) +#+openmcl +(defun compute-class-precedence-list (class) + ;; safe to call this in openmcl + (class-precedence-list class)) + +#-(or sbcl cmu) +(defmethod compute-slots ((class standard-db-class)) + "Need to sort order of class slots so they are the same across +implementations." + (let ((slots (call-next-method)) + desired-sequence + output-slots) + (dolist (c (compute-class-precedence-list class)) + (dolist (s (class-direct-slots c)) + (let ((name (slot-definition-name s))) + (unless (find name desired-sequence) + (push name desired-sequence))))) + (dolist (desired desired-sequence) + (let ((slot (find desired slots :key #'slot-definition-name))) + (assert slot) + (push slot output-slots))) + output-slots)) + +(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 + (cond + ((consp specified-type) + (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))) + #+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 ;; what kind of database value (if any) is stored there, generates and ;; verifies the column name. @@ -443,6 +422,7 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") #+kmr-normal-cesd slot-name direct-slots) #+kmr-normal-cesd (declare (ignore slot-name)) + (let ((slotd (call-next-method)) (sd (car direct-slots))) @@ -462,9 +442,8 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (when (slot-boundp sd 'db-type) (view-class-slot-db-type sd))) - - (setf (slot-value slotd 'nulls-ok) - (view-class-slot-nulls-ok 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) @@ -481,7 +460,6 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (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 )? @@ -490,7 +468,16 @@ all NULL values retrieved are converted by DATABASE-NULL-VALUE") (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))))) + (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