(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)
+ "Normalized classes share a single key for all their key slots"
+ (when (normalizedp (class-of 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)))
- (tb (view-table obj-class)))
- (flet ((qfk (k)
- (sql-operation '==
- (sql-expression :attribute
- (database-identifier k database)
- :table tb)
- (db-value-from-slot
- k
- (slot-value obj (slot-definition-name k))
- database))))
- (let* ((keys (keyslots-for-class obj-class))
- (keyxprs (mapcar #'qfk (reverse keys))))
- (cond
- ((= (length keyxprs) 0) nil)
- ((= (length keyxprs) 1) (car keyxprs))
- ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs)))))))
-
-;;
-;; Function used by 'generate-selection-list'
-;;
-
-(defun generate-attribute-reference (vclass slotdef)
- (cond
- ((eq (view-class-slot-db-kind slotdef) :base)
- (sql-expression :attribute (database-identifier slotdef nil)
- :table (database-identifier vclass nil)))
- ((eq (view-class-slot-db-kind slotdef) :key)
- (sql-expression :attribute (database-identifier slotdef nil)
- :table (database-identifier vclass nil)))
- (t nil)))
+ (keys (keyslots-for-class obj-class))
+ (normal-db-value (normalized-key-value obj)))
+ (when keys
+ (labels ((db-value (k)
+ (or normal-db-value
+ (db-value-from-slot
+ k
+ (easy-slot-value obj k)
+ database)))
+ (key-equal-exp (k)
+ (sql-operation '== (generate-attribute-reference obj-class k database)
+ (db-value k))))
+ (clsql-ands (mapcar #'key-equal-exp keys))))))
+
+(defun generate-attribute-reference (vclass slotdef &optional (database *default-database*))
+ "Turns key class and slot-def into a sql-expression representing the
+ table and column it comes from
+
+ used by things like generate-selection-list, update-slot-from-record"
+ (when (key-or-base-slot-p slotdef)
+ (sql-expression :attribute (database-identifier slotdef database)
+ :table (database-identifier vclass database))))
;;
;; Function used by 'find-all'
(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)))
"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
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
(pres)
(t nil)))))
+
+(defmethod get-slot-value-from-record ((instance standard-db-object)
+ slot &key (database *default-database*))
+ (let* ((class-and-slot
+ (first
+ (view-classes-and-slots-by-name instance slot)))
+ (view-class (view-class class-and-slot))
+ (slot-def (first (slot-defs class-and-slot)))
+ (vd (choose-database-for-instance instance database))
+ (att-ref (first (attribute-references class-and-slot)))
+ (res (first
+ (select att-ref
+ :from (view-table-exp class-and-slot)
+ :where (key-qualifier-for-instance
+ instance
+ :database vd
+ :this-class view-class)
+ :result-types nil
+ :flatp T))))
+ (values res slot-def)))
+
(defmethod update-slot-from-record ((instance standard-db-object)
slot &key (database *default-database*))
- (let* ((view-class (find-class (class-name (class-of instance))))
- (slot-def (slotdef-for-slot-with-class slot view-class)))
- (when (normalizedp view-class)
- ;; If it's normalized, find the class that actually contains
- ;; the slot that's tied to the db
- (setf view-class
- (do ((this-class view-class
- (car (class-direct-superclasses this-class))))
- ((direct-normalized-slot-p this-class slot)
- this-class))))
- (let* ((view-table (sql-expression :table (view-table view-class)))
- (vd (choose-database-for-instance instance database))
- (view-qual (key-qualifier-for-instance instance :database vd
- :this-class view-class))
- (att-ref (generate-attribute-reference view-class slot-def))
- (res (select att-ref :from view-table :where view-qual
- :result-types nil)))
- (when res
- (setf (slot-value instance 'view-database) vd)
- (get-slot-values-from-view instance (list slot-def) (car res))))))
+ "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)))
+ (setf (slot-value instance 'view-database) vd)
+ (update-slot-from-db-value instance slot-def res))))
(defvar +no-slot-value+ '+no-slot-value+)
(select jc :where jq :flatp t :result-types nil
:database (choose-database-for-instance object))))))
+
+
(defun fault-join-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
- (ts (gethash :target-slot dbi)))
- (if (and ts (gethash :set dbi))
+ (ts (gethash :target-slot dbi))
+ (dbi-set (gethash :set dbi)))
+ (if (and ts dbi-set)
(fault-join-target-slot class object slot-def)
(let ((res (fault-join-slot-raw class object slot-def)))
(when res
(cond
- ((and ts (not (gethash :set dbi)))
+ ((and ts (not dbi-set))
(mapcar (lambda (obj) (slot-value obj ts)) res))
- ((and (not ts) (not (gethash :set dbi)))
+ ((and (not ts) (not dbi-set))
(car res))
- ((and (not ts) (gethash :set dbi))
+ ((and (not ts) dbi-set)
res)))))))
-;;;; Should we not return the whole result, instead of only
-;;;; the one slot-value? We get all the values from the db
-;;;; anyway, so?
-(defun fault-join-normalized-slot (class object slot-def)
- (labels ((getsc (this-class)
- (let ((sc (car (class-direct-superclasses this-class))))
- (if (key-slots sc)
- sc
- (getsc sc)))))
- (let* ((sc (getsc class))
- (hk (slot-definition-name (car (key-slots class))))
- (fk (slot-definition-name (car (key-slots sc)))))
- (let ((jq (sql-operation '==
- (typecase fk
- (symbol
- (sql-expression
- :attribute
- (database-identifier
- (slotdef-for-slot-with-class fk sc) nil)
- :table (view-table sc)))
- (t fk))
- (typecase hk
- (symbol
- (slot-value object hk))
- (t hk)))))
-
- ;; Caching nil in next select, because in normalized mode
- ;; records can be changed through other instances (children,
- ;; parents) so changes possibly won't be noticed
- (let ((res (car (select (class-name sc) :where jq
- :flatp t :result-types nil
- :caching nil
- :database (choose-database-for-instance object))))
- (slot-name (slot-definition-name slot-def)))
-
- ;; If current class is normalized and wanted slot is not
- ;; a direct member, recurse up
- (if (and (normalizedp class)
- (not (member slot-name
- (mapcar #'(lambda (esd) (slot-definition-name esd))
- (ordered-class-direct-slots class))))
- (not (slot-boundp res slot-name)))
- (fault-join-normalized-slot sc res slot-def)
- (slot-value res slot-name)))))) )
+(defun update-fault-join-normalized-slot (class object slot-def)
+ (if (and (normalizedp class) (key-slot-p slot-def))
+ (setf (easy-slot-value object slot-def)
+ (normalized-key-value object))
+ (update-slot-from-record object slot-def)))
(defun join-qualifier (class object slot-def)
(declare (ignore class))
projects / clsql.git / blobdiff