#+mop-slot-order-reversed (reverse (class-direct-slots class))
#-mop-slot-order-reversed (class-direct-slots class))
-(defun find-class-slot-by-name (class slot-name &optional direct?)
+(defun find-slot-by-name (class slot-name &optional direct? recurse?)
"Looks up a direct-slot-definition by name"
- (setf class (to-class class))
- (find (to-slot-name slot-name)
- (if direct?
- (ordered-class-direct-slots class)
- (ordered-class-slots class))
- :key #'slot-definition-name))
+ (setf class (to-class class)
+ slot-name (to-slot-name slot-name))
+ (labels ((find-it (class)
+ (let* ((slots (if direct?
+ (ordered-class-direct-slots class)
+ (ordered-class-slots class)))
+ (it (find slot-name
+ slots
+ :key #'slot-definition-name)))
+ (if it
+ it
+ (when recurse?
+ (loop for sup in (class-direct-superclasses class)
+ for rtn = (find-it sup)
+ until rtn
+ finally (return rtn)))))))
+ (find-it class)))
;; Lispworks has symbol for slot rather than the slot instance
(defun %svuc-slot-name (slot)
(ordered-class-direct-slots class)
(ordered-class-slots class)))
+(defun key-slot-p (slot-def)
+ "takes a slot def and returns whether or not it is a key"
+ (eql :key (view-class-slot-db-kind slot-def)))
+
+(defun join-slot-p (slot-def)
+ "takes a slot def and returns whether or not it is a key"
+ (eql :join (view-class-slot-db-kind slot-def)))
+
+(defun key-or-base-slot-p (slot-def)
+ "takes a slot def and returns whether or not it is a key"
+ (member (view-class-slot-db-kind slot-def) '(:key :base)))
+
(defun direct-normalized-slot-p (class slot-name)
"Is this a normalized class and if so is the slot one of our direct slots?"
(setf slot-name (to-slot-name slot-name))
- (and (normalizedp class)
+ (and (typep class 'standard-db-class)
+ (normalizedp class)
(member slot-name (ordered-class-direct-slots class)
:key #'slot-definition-name)))
(defun not-direct-normalized-slot-p (class slot-name)
"Is this a normalized class and if so is the slot not one of our direct slots?"
(setf slot-name (to-slot-name slot-name))
- (and (normalizedp class)
+ (and (typep class 'standard-db-class)
+ (normalizedp class)
(not (member slot-name (ordered-class-direct-slots class)
:key #'slot-definition-name))))
(defmethod database-generate-column-definition (class slotdef database)
(declare (ignore class))
- (when (member (view-class-slot-db-kind slotdef) '(:base :key))
+ (when (key-or-base-slot-p slotdef)
(let ((cdef
(list (sql-expression :attribute (database-identifier slotdef database))
(specified-type slotdef))))
"Find the best class to associate with the slot. If it is
normalized then it needs to be a direct slot otherwise it just
needs to be on the class."
- (let ((sd (find-class-slot-by-name class slot normalizedp)))
+ (let ((sd (find-slot-by-name class slot normalizedp nil)))
(if sd
;;we found it directly or it's (not normalized)
(pushnew sd (slot-defs (get-c&s-obj class)))
((obj standard-db-object) slot &key (database *default-database*))
(update-record-from-slots obj slot :database database))
-(defun %slot-storedp (slot-def)
- "Whether or not a slot should be stored in the database based on its db-kind
- and whether it is bound"
- (member (view-class-slot-db-kind slot-def) '(:base :key)))
+
(defmethod view-classes-and-storable-slots-for-instance ((obj standard-db-object))
"Get a list of all the tables we need to update and the slots on them
rtns)
(labels ((storable-slots (class)
(loop for sd in (slots-for-possibly-normalized-class class)
- when (%slot-storedp sd)
+ when (key-or-base-slot-p sd)
collect sd))
(get-classes-and-slots (class &aux (normalizedp (normalizedp class)))
(let ((slots (storable-slots class)))