(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))
+ (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
"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))
+(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 (%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)))
(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)
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)
(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))))))
+ (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