+(defclass class-and-slots ()
+ ((view-class :accessor view-class :initarg :view-class :initform nil)
+ (slot-defs :accessor slot-defs :initarg :slot-defs :initform nil))
+ (:documentation "A helper class to keep track of which slot-defs from a
+ table need to be updated, a normalized class might have many of these
+ because each of its parent classes might represent some other table and we
+ need to match which slots came from which parent class/table"))
+
+(defun make-class-and-slots (c &optional s)
+ "Create a new class-and-slots object"
+ (make-instance 'class-and-slots :view-class c :slot-defs (listify s) ))
+
+(defmethod view-table ((o class-and-slots))
+ "get the view-table of the view-class of o"
+ (view-table (view-class o)))
+
+(defmethod view-table-exp ((o class-and-slots))
+ (sql-expression :table (view-table o)))
+
+(defmethod view-table-exp ((o standard-db-class))
+ (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)
+ collect (generate-attribute-reference class sd)))
+
+(defmethod attribute-value-pairs ((def class-and-slots) (o standard-db-object)
+ database)
+ "for a given class-and-slots and object, create the sql-expression & value pairs
+ that need to be sent to the database"
+ (loop for s in (slot-defs def)
+ for n = (to-slot-name s)
+ when (slot-boundp o n)
+ collect (make-attribute-value-pair s (slot-value o n) database)))
+
+(defmethod view-classes-and-slots-by-name ((obj standard-db-object) slots-to-match)
+ "If it's normalized, find the class that actually contains
+ the slot that's tied to the db,
+
+ otherwise just search the current class
+ "
+ (let* ((view-class (class-of obj))
+ (normalizedp (normalizedp view-class))
+ rtns)
+ (labels ((get-c&s-obj (class)
+ (or (find class rtns :key #'view-class)
+ (first (push (make-class-and-slots class) rtns))))
+ (associate-slot-with-class (class slot)
+ "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-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)))
+ (when normalizedp
+ (loop for parent in (class-direct-superclasses class)
+ until (associate-slot-with-class parent slot))))
+ sd)))
+ (loop
+ for in-slot in (listify slots-to-match)
+ do (associate-slot-with-class view-class in-slot)))
+ rtns))
+
+(defun update-auto-increments-keys (class obj database)
+ " 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)
+ (labels ((do-update (slot)
+ (when (and (null (easy-slot-value obj slot))
+ (auto-increment-column-p slot database))
+ (update-slot-from-db-value
+ obj slot
+ (or new-pk-value
+ (setf new-pk-value
+ (database-last-auto-increment-id
+ database table slot))))))
+ (chain-primary-keys (in-class)
+ "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 (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))
+ (chain-primary-keys direct-class)))
+ new-pk-value)))
+
+(defmethod %update-instance-helper
+ (class-and-slots obj database
+ &aux (avps (attribute-value-pairs class-and-slots obj database)))
+ "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))
+ (table (view-table view-class))
+ (table-sql (sql-expression :table table)))
+
+ ;; view database is the flag we use to tell it was pulled from a database
+ ;; and thus probably needs an update instead of an insert
+ (cond ((view-database obj)
+ (let ((where (key-qualifier-for-instance
+ obj :database database :this-class view-class)))
+ (unless where
+ (error "update-record-from-*: could not generate a where clause for ~a using ~A"
+ obj view-class))
+ (update-records table-sql
+ :av-pairs avps
+ :where where
+ :database database)))
+ (T ;; was not pulled from the db so insert it
+ ;; avps MUST contain any primary key slots set
+ ;; by previous inserts of the same object into different
+ ;; tables (ie: normalized stuff)
+ (insert-records :into table-sql
projects / clsql.git / blobdiff