X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=aafd3f4120e5eee65980599b487cf7c3074ced6a;hb=ed4847a3ca88803bad88e72a514c855e85b50ba7;hp=af8e461b774ba05b7e8fce2122642e630633b698;hpb=c339a403634db7fc71308bb6da91e81af4cde1bb;p=clsql.git diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index af8e461..aafd3f4 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -45,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) @@ -58,92 +54,17 @@ :initform nil)) (:documentation "VIEW-CLASS metaclass.")) -#+lispworks -(defmacro push-on-end (value location) - `(setf ,location (nconc ,location (list ,value)))) +;;; Lispworks 4.2 and before requires special processing of extra slot and class options -;; 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)) +(defconstant +extra-class-options+ '(:base-table)) -#+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 -(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)) +(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)) @@ -155,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) @@ -163,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) @@ -181,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))) @@ -203,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)) @@ -235,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)))