(in-package #:clsql-sys)
(defun find-normalized-key (obj)
+ "Find the first / primary key of a normalized object"
(find-slot-if obj #'key-slot-p T T))
(defun normalized-key-value (obj)
(easy-slot-value obj (find-normalized-key obj))))
(defun key-qualifier-for-instance (obj &key (database *default-database*) this-class)
+ "Generate a boolean sql-expression that identifies an object by its keys"
(let* ((obj-class (or this-class (class-of obj)))
(keys (keyslots-for-class obj-class))
(normal-db-value (normalized-key-value obj)))
(defmethod update-slot-with-null ((object standard-db-object) slotdef)
+ "sets a slot to the void value of the slot-def (usually nil)"
(setf (easy-slot-value object slotdef)
(slot-value slotdef 'void-value)))
(format nil slot-reader value))))))))
(defmethod key-value-from-db (slotdef value database)
+ "TODO: is this deprecated? there are no uses anywhere in clsql"
(declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
(let ((slot-reader (view-class-slot-db-reader slotdef))
(slot-type (specified-type slotdef)))
(sql-expression :table (view-table o)))
(defmethod attribute-references ((o class-and-slots))
+ "build sql-ident-attributes for a given class-and-slots"
(loop
with class = (view-class o)
for sd in (slot-defs o)
rtns))
(defun update-auto-increments-keys (class obj database)
- ;; handle pulling any autoincrement values into the object
+ " handle pulling any autoincrement values into the object
+ if normalized and we now that all the "
(let ((pk-slots (keyslots-for-class class))
(table (view-table class))
new-pk-value)
"This seems kindof wrong, but this is mostly how it was working, so
its here to keep the normalized code path working"
(when (typep in-class 'standard-db-class)
- (loop for slot in (keyslots-for-class in-class)
- do (do-update slot))
- (loop for c in (class-direct-superclasses in-class)
- do (chain-primary-keys c)))))
+ (loop for slot in (ordered-class-slots in-class)
+ when (key-slot-p slot)
+ do (do-update slot)))))
(loop for slot in pk-slots do (do-update slot))
(let ((direct-class (to-class obj)))
(when (and new-pk-value (normalizedp direct-class))
(defmethod %update-instance-helper
(class-and-slots obj database
&aux (avps (attribute-value-pairs class-and-slots obj database)))
- ;; we dont actually need to update anything on this particular parent class
+ "A function to help us update a given table (based on class-and-slots)
+ with values from an object"
+ ;; we dont actually need to update anything on this particular
+ ;; class / parent class
(unless avps (return-from %update-instance-helper))
(let* ((view-class (view-class class-and-slots))
(defmethod update-record-from-slots ((obj standard-db-object) slots
&key (database *default-database*))
+ "For a given list of slots, update all records associated with those slots
+ and classes.
+
+ Generally this will update the single record associated with this object,
+ but for normalized classes might update as many records as there are
+ inheritances "
(setf slots (listify slots))
(let* ((classes-and-slots (view-classes-and-slots-by-name obj slots))
(database (choose-database-for-instance obj database)))
(defmethod update-record-from-slot
((obj standard-db-object) slot &key (database *default-database*))
- (update-record-from-slots obj slot :database database))
-
+ "just call update-records-from-slots which now handles this.
+ This function is only here to maintain backwards compatibility in
+ the public api"
+ (update-record-from-slots obj slot :database database))
-(defmethod view-classes-and-storable-slots-for-instance ((obj standard-db-object))
+(defun view-classes-and-storable-slots (class)
"Get a list of all the tables we need to update and the slots on them
for non normalized classes we return the class and all its storable slots
for normalized classes we return a list of direct slots and the class they
came from for each normalized view class
"
- (let* ((view-class (class-of obj))
- rtns)
+ (setf class (to-class class))
+ (let* (rtns)
(labels ((storable-slots (class)
(loop for sd in (slots-for-possibly-normalized-class class)
when (key-or-base-slot-p sd)
(loop for new-class in (class-direct-superclasses class)
do (when (typep new-class 'standard-db-class)
(get-classes-and-slots new-class))))))
- (get-classes-and-slots view-class))
+ (get-classes-and-slots class))
rtns))
(defmethod primary-key-slot-values ((obj standard-db-object)
&key class slots )
+ "Returns the values of all key-slots for a given class"
(defaulting class (class-of obj)
slots (keyslots-for-class class))
(loop for slot in slots
view-database slot on the object is nil then the object is assumed to be
new and is inserted"
(let ((database (choose-database-for-instance obj database))
- (classes-and-slots (view-classes-and-storable-slots-for-instance obj)))
+ (classes-and-slots (view-classes-and-storable-slots obj)))
(loop for class-and-slots in classes-and-slots
do (%update-instance-helper class-and-slots obj database))
(setf (slot-value obj 'view-database) database)
(primary-key-slot-values obj)))
(defmethod delete-instance-records ((instance standard-db-object) &key database)
+ "Removes the records associated with a given instance
+ (as determined by key-qualifier-for-instance)
+
+ TODO: Doesnt handle normalized classes at all afaict"
(let ((database (choose-database-for-instance instance database))
(vt (sql-expression :table (view-table (class-of instance)))))
(if database
(defmethod update-slot-from-record ((instance standard-db-object)
slot &key (database *default-database*))
+ "Pulls the value of a given slot form the database and stores that in the
+ appropriate slot on instance"
(multiple-value-bind (res slot-def)
(get-slot-value-from-record instance slot :database database)
(let ((vd (choose-database-for-instance instance database)))
projects / clsql.git / blobdiff