;; ------------------------------------------------------------
;; metaclass: view-class
-(defclass view-metaclass (standard-class)
+(defclass standard-db-class (standard-class)
((view-table
:accessor view-table
:initarg :view-table)
:accessor object-definition
:initarg :definition
:initform nil)
- (version
- :accessor object-version
- :initarg :version
- :initform 0)
(key-slots
:accessor key-slots
:initform nil)
#+lispworks
(defmethod clos::canonicalize-defclass-slot :around
- ((prototype view-metaclass) slot)
+ ((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
result))
#+lispworks
-(defconstant +extra-class-options+ '(:base-table :version :schemas))
+(defconstant +extra-class-options+ '(:base-table))
#+lispworks
(defmethod clos::canonicalize-class-options :around
- ((prototype view-metaclass) class-options)
+ ((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
result))
-(defmethod validate-superclass ((class view-metaclass)
+(defmethod validate-superclass ((class standard-db-class)
(superclass standard-class))
t)
(pop-arg mylist))
newlist))
-(defmethod initialize-instance :around ((class view-metaclass)
+(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 'view-metaclass)))
+ (vmc (find-class 'standard-db-class)))
(setf (view-class-qualifier class)
(car qualifier))
(if root-class
(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 view-metaclass)
+(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))
- (vmc (find-class 'view-metaclass)))
+ (vmc (find-class 'standard-db-class)))
(setf (view-table class)
(table-name-from-arg (sql-escape (or (and base-table
(if (listp base-table)
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)))
(ordered-class-slots class)))))
#+(or allegro openmcl)
-(defmethod finalize-inheritance :after ((class view-metaclass))
+(defmethod finalize-inheritance :after ((class standard-db-class))
;; KMRL for slots without a type set, openmcl sets type-predicate to ccl:false
- ;; for view-metaclass
+ ;; for standard-db-class
#+openmcl
(mapcar
#'(lambda (s)
standard-effective-slot-definition)
())
-(defmethod direct-slot-definition-class ((class view-metaclass)
+(defmethod direct-slot-definition-class ((class standard-db-class)
#+kmr-normal-dsdc &rest
initargs)
(declare (ignore initargs))
(find-class 'view-class-direct-slot-definition))
-(defmethod effective-slot-definition-class ((class view-metaclass)
+(defmethod effective-slot-definition-class ((class standard-db-class)
#+kmr-normal-esdc &rest
initargs)
(declare (ignore initargs))
(class-precedence-list class))
#-(or sbcl cmu)
-(defmethod compute-slots ((class view-metaclass))
+(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))
;; what kind of database value (if any) is stored there, generates and
;; verifies the column name.
-(defmethod compute-effective-slot-definition ((class view-metaclass)
+(defmethod compute-effective-slot-definition ((class standard-db-class)
#+kmr-normal-cesd slot-name
direct-slots)
#+kmr-normal-cesd (declare (ignore slot-name))