"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"
+ used by things like make-select-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'
-;;
-
-(defun generate-selection-list (vclass)
- (let* ((sels nil)
- (this-class vclass)
- (slots (if (normalizedp vclass)
- (labels ((getdslots ()
- (let ((sl (ordered-class-direct-slots this-class)))
- (cond (sl)
- (t
- (setf this-class
- (car (class-direct-superclasses this-class)))
- (getdslots))))))
- (getdslots))
- (ordered-class-slots this-class))))
- (dolist (slotdef slots)
- (let ((res (generate-attribute-reference this-class slotdef)))
- (when res
- (push (cons slotdef res) sels))))
- (if sels
- sels
- (error "No slots of type :base in view-class ~A" (class-name vclass)))))
-
-
-
-(defun generate-retrieval-joins-list (vclass retrieval-method)
+(defun generate-retrieval-joins-list (class retrieval-method)
"Returns list of immediate join slots for a class."
- (let ((join-slotdefs nil))
- (dolist (slotdef (ordered-class-slots vclass) join-slotdefs)
- (when (and (eq :join (view-class-slot-db-kind slotdef))
- (eq retrieval-method (gethash :retrieval (view-class-slot-db-info slotdef))))
- (push slotdef join-slotdefs)))))
+ (setf class (to-class class))
+ (loop for slot in (ordered-class-slots class)
+ when (eql (join-slot-retrieval-method slot) retrieval-method)
+ collect slot))
-(defun generate-immediate-joins-selection-list (vclass)
- "Returns list of immediate join slots for a class."
- (let (sels)
- (dolist (joined-slot (generate-retrieval-joins-list vclass :immediate) sels)
- (let* ((join-class-name (gethash :join-class (view-class-slot-db-info joined-slot)))
- (join-class (when join-class-name (find-class join-class-name))))
- (dolist (slotdef (ordered-class-slots join-class))
- (let ((res (generate-attribute-reference join-class slotdef)))
- (when res
- (push (cons slotdef res) sels))))))
- sels))
+(defun immediate-join-slots (class)
+ (generate-retrieval-joins-list class :immediate))
(defmethod choose-database-for-instance ((obj standard-db-object) &optional database)
"Determine which database connection to use for a standard-db-object.
(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*))
+ "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))
(defun view-classes-and-storable-slots (class)
(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
(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
(signal-no-database-error database))))
(defmethod update-instance-from-records ((instance standard-db-object)
- &key (database *default-database*)
- this-class)
- (let* ((view-class (or this-class (class-of instance)))
- (pclass (car (class-direct-superclasses view-class)))
- (pres nil))
- (when (normalizedp view-class)
- (setf pres (update-instance-from-records instance :database database
- :this-class pclass)))
- (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))
- (sels (generate-selection-list view-class))
- (res nil))
- (cond (view-qual
- (setf res (apply #'select (append (mapcar #'cdr sels)
- (list :from view-table
- :where view-qual
- :result-types nil
- :database vd))))
- (when res
- (setf (slot-value instance 'view-database) vd)
- (get-slot-values-from-view instance (mapcar #'car sels) (car res))))
- (pres)
- (t nil)))))
+ &key (database *default-database*))
+ "Updates a database object with the current values stored in the database
+
+ TODO: Should this update immediate join slots similar to build-objects?
+ Can we just call build-objects?, update-objects-joins?
+ "
+
+ (let* ((classes-and-slots (view-classes-and-storable-slots instance))
+ (vd (choose-database-for-instance instance database)))
+ (labels ((do-update (class-and-slots)
+ (let* ((select-list (make-select-list class-and-slots :do-joins-p nil))
+ (view-table (sql-table select-list))
+ (view-qual (key-qualifier-for-instance
+ instance :database vd
+ :this-class (view-class select-list)))
+ (res (when view-qual
+ (first
+ (apply #'select
+ (append (full-select-list select-list)
+ (list :from view-table
+ :where view-qual
+ :result-types nil
+ :database vd)))))))
+ (when res
+ (setf (slot-value instance 'view-database) vd)
+ (get-slot-values-from-view instance (slot-list select-list) res))
+ )))
+ (loop for class-and-slots in classes-and-slots
+ do (do-update class-and-slots)))))
(defmethod get-slot-value-from-record ((instance standard-db-object)
(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)))
(normalized-key-value object))
(update-slot-from-record object slot-def)))
+(defun all-home-keys-have-values-p (object slot-def)
+ "Do all of the home-keys have values ?"
+ (let ((home-keys (join-slot-info-value slot-def :home-key)))
+ (loop for key in (listify home-keys)
+ always (easy-slot-value object key))))
+
(defun join-qualifier (class object slot-def)
+ "Builds the join where clause based on the keys of the join slot and values
+ of the object"
(declare (ignore class))
- (let* ((dbi (view-class-slot-db-info slot-def))
- (jc (find-class (gethash :join-class dbi)))
+ (let* ((jc (join-slot-class slot-def))
;;(ts (gethash :target-slot dbi))
;;(tsdef (if ts (slotdef-for-slot-with-class ts jc)))
- (foreign-keys (gethash :foreign-key dbi))
- (home-keys (gethash :home-key dbi)))
- (when (every #'(lambda (slt)
- (and (slot-boundp object slt)
- (not (null (slot-value object slt)))))
- (if (listp home-keys) home-keys (list home-keys)))
- (let ((jc
- (mapcar #'(lambda (hk fk)
- (let ((fksd (slotdef-for-slot-with-class fk jc)))
- (sql-operation '==
- (typecase fk
- (symbol
- (sql-expression
- :attribute
- (database-identifier fksd nil)
- :table (database-identifier jc nil)))
- (t fk))
- (typecase hk
- (symbol
- (slot-value object hk))
- (t
- hk)))))
- (if (listp home-keys)
- home-keys
- (list home-keys))
- (if (listp foreign-keys)
- foreign-keys
- (list foreign-keys)))))
- (when jc
- (if (> (length jc) 1)
- (apply #'sql-and jc)
- jc))))))
-
-;; FIXME: add retrieval immediate for efficiency
-;; For example, for (select 'employee-address) in test suite =>
-;; select addr.*,ea_join.* FROM addr,ea_join WHERE ea_join.aaddressid=addr.addressid\g
-
-(defun build-objects (vals sclasses immediate-join-classes sels immediate-joins database refresh flatp instances)
- "Used by find-all to build objects."
- (labels ((build-object (vals vclass jclasses selects immediate-selects instance)
- (let* ((db-vals (butlast vals (- (list-length vals)
- (list-length selects))))
- (obj (if instance instance (make-instance (class-name vclass) :view-database database)))
- (join-vals (subseq vals (list-length selects)))
- (joins (mapcar #'(lambda (c) (when c (make-instance c :view-database database)))
- jclasses)))
-
- ;;(format t "joins: ~S~%db-vals: ~S~%join-values: ~S~%selects: ~S~%immediate-selects: ~S~%"
- ;;joins db-vals join-vals selects immediate-selects)
-
- ;; use refresh keyword here
- (setf obj (get-slot-values-from-view obj (mapcar #'car selects) db-vals))
- (mapc #'(lambda (jo)
- ;; find all immediate-select slots and join-vals for this object
- (let* ((jo-class (class-of jo))
- (slots (slots-for-possibly-normalized-class jo-class))
- (pos-list (remove-if #'null
- (mapcar
- #'(lambda (s)
- (position s immediate-selects
- :key #'car
- :test #'eq))
- slots))))
- (get-slot-values-from-view jo
- (mapcar #'car
- (mapcar #'(lambda (pos)
- (nth pos immediate-selects))
- pos-list))
- (mapcar #'(lambda (pos) (nth pos join-vals))
- pos-list))))
- joins)
- (mapc
- #'(lambda (jc)
- (let* ((vslots
- (class-slots vclass))
- (slot (find (class-name (class-of jc)) vslots
- :key #'(lambda (slot)
- (when (and (eq :join (view-class-slot-db-kind slot))
- (eq (slot-definition-name slot)
- (gethash :join-class (view-class-slot-db-info slot))))
- (slot-definition-name slot))))))
- (when slot
- (setf (slot-value obj (slot-definition-name slot)) jc))))
- joins)
- (when refresh (instance-refreshed obj))
- obj)))
- (let* ((objects
- (mapcar #'(lambda (sclass jclass sel immediate-join instance)
- (prog1
- (build-object vals sclass jclass sel immediate-join instance)
- (setf vals (nthcdr (+ (list-length sel) (list-length immediate-join))
- vals))))
- sclasses immediate-join-classes sels immediate-joins instances)))
- (if (and flatp (= (length sclasses) 1))
- (car objects)
- objects))))
+ (foreign-keys (listify (join-slot-info-value slot-def :foreign-key)))
+ (home-keys (listify (join-slot-info-value slot-def :home-key))))
+ (when (all-home-keys-have-values-p object slot-def)
+ (clsql-ands
+ (loop for hk in home-keys
+ for fk in foreign-keys
+ for fksd = (slotdef-for-slot-with-class fk jc)
+ for fk-sql = (typecase fk
+ (symbol
+ (sql-expression
+ :attribute (database-identifier fksd nil)
+ :table (database-identifier jc nil)))
+ (t fk))
+ for hk-val = (typecase hk
+ ((or symbol
+ view-class-effective-slot-definition
+ view-class-direct-slot-definition)
+ (easy-slot-value object hk))
+ (t hk))
+ collect (sql-operation '== fk-sql hk-val))))))
(defmethod select-table-sql-expr ((table T))
"Turns an object representing a table into the :from part of the sql expression that will be executed "
(sql-expression :table (view-table table)))
+(defun select-reference-equal (r1 r2)
+ "determines if two sql select references are equal
+ using database identifier equal"
+ (flet ((id-of (r)
+ (etypecase r
+ (cons (cdr r))
+ (sql-ident-attribute r))))
+ (database-identifier-equal (id-of r1) (id-of r2))))
+
+(defun join-slot-qualifier (class join-slot)
+ "Creates a sql-expression expressing the join between the home-key on the table
+ and its respective key on the joined-to-table"
+ (sql-operation
+ '==
+ (sql-expression
+ :attribute (join-slot-info-value join-slot :foreign-key)
+ :table (view-table (join-slot-class join-slot)))
+ (sql-expression
+ :attribute (join-slot-info-value join-slot :home-key)
+ :table (view-table class))))
+
+(defun all-immediate-join-classes-for (classes)
+ "returns a list of all join-classes needed for a list of classes"
+ (loop for class in (listify classes)
+ appending (loop for slot in (immediate-join-slots class)
+ collect (join-slot-class slot))))
+
+(defun %tables-for-query (classes from where inner-joins)
+ "Given lists of classes froms wheres and inner-join compile a list
+ of tables that should appear in the FROM section of the query.
+
+ This includes any immediate join classes from each of the classes"
+ (let ((inner-join-tables (collect-table-refs (listify inner-joins))))
+ (loop for tbl in (append
+ (mapcar #'select-table-sql-expr classes)
+ (mapcar #'select-table-sql-expr
+ (all-immediate-join-classes-for classes))
+ (collect-table-refs (listify where))
+ (collect-table-refs (listify from)))
+ when (and tbl
+ (not (find tbl rtn :test #'database-identifier-equal))
+ ;; TODO: inner-join is currently hacky as can be
+ (not (find tbl inner-join-tables :test #'database-identifier-equal)))
+ collect tbl into rtn
+ finally (return rtn))))
+
+
+(defclass select-list ()
+ ((view-class :accessor view-class :initarg :view-class :initform nil)
+ (select-list :accessor select-list :initarg :select-list :initform nil)
+ (slot-list :accessor slot-list :initarg :slot-list :initform nil)
+ (joins :accessor joins :initarg :joins :initform nil)
+ (join-slots :accessor join-slots :initarg :join-slots :initform nil))
+ (:documentation
+ "Collects the classes, slots and their respective sql representations
+ so that update-instance-from-recors, find-all, build-objects can share this
+ info and calculate it once. Joins are select-lists for each immediate join-slot
+ but only if make-select-list is called with do-joins-p"))
+
+(defmethod view-table ((o select-list))
+ (view-table (view-class o)))
+
+(defmethod sql-table ((o select-list))
+ (sql-expression :table (view-table o)))
+
+(defun make-select-list (class-and-slots &key (do-joins-p nil))
+ "Make a select-list for the current class (or class-and-slots) object."
+ (let* ((class-and-slots
+ (etypecase class-and-slots
+ (class-and-slots class-and-slots)
+ ((or symbol standard-db-class)
+ ;; find the first class with slots for us to select (this should be)
+ ;; the first of its classes / parent-classes with slots
+ (first (reverse (view-classes-and-storable-slots
+ (to-class class-and-slots)))))))
+ (class (view-class class-and-slots))
+ (join-slots (when do-joins-p (immediate-join-slots class))))
+ (multiple-value-bind (slots sqls)
+ (loop for slot in (slot-defs class-and-slots)
+ for sql = (generate-attribute-reference class slot)
+ collect slot into slots
+ collect sql into sqls
+ finally (return (values slots sqls)))
+ (unless slots
+ (error "No slots of type :base in view-class ~A" (class-name class)))
+ (make-instance
+ 'select-list
+ :view-class class
+ :select-list sqls
+ :slot-list slots
+ :join-slots join-slots
+ ;; only do a single layer of join objects
+ :joins (when do-joins-p
+ (loop for js in join-slots
+ collect (make-select-list
+ (join-slot-class js)
+ :do-joins-p nil)))))))
+
+(defun full-select-list ( select-lists )
+ "Returns a list of sql-ref of things to select for the given classes
+
+ THIS NEEDS TO MATCH THE ORDER OF build-objects
+ "
+ (loop for s in (listify select-lists)
+ appending (select-list s)
+ appending (loop for join in (joins s)
+ appending (select-list join))))
+
+(defun build-objects (select-lists row database &optional existing-instances)
+ "Used by find-all to build objects.
+
+ THIS NEEDS TO MATCH THE ORDER OF FULL-SELECT-LIST
+
+ TODO: this caching scheme seems bad for a number of reasons
+ * order is not guaranteed so references being held by one object
+ might change to represent a different database row (seems HIGHLY
+ suspect)
+ * also join objects are overwritten rather than refreshed
+
+ TODO: the way we handle immediate joins seems only valid if it is a single
+ object. I suspect that making a :set :immediate join column would result
+ in an invalid number of objects returned from the database, because there
+ would be multiple rows per object, but we would return an object per row
+ "
+ (setf existing-instances (listify existing-instances))
+ (loop
+ for select-list in select-lists
+ for class = (view-class select-list)
+ for existing = (pop existing-instances)
+ for object = (or existing
+ (make-instance class :view-database database))
+ do (loop for slot in (slot-list select-list)
+ do (update-slot-from-db-value object slot (pop row)))
+ do (loop for join-slot in (join-slots select-list)
+ for join in (joins select-list)
+ for join-class = (view-class join)
+ for join-object =
+ (setf (easy-slot-value object join-slot)
+ (make-instance join-class))
+ do (loop for slot in (slot-list join)
+ do (update-slot-from-db-value join-object slot (pop row))))
+ do (when existing (instance-refreshed object))
+ collect object))
(defun find-all (view-classes
&rest args
(database *default-database*)
instances parameters)
"Called by SELECT to generate object query results when the
- View Classes VIEW-CLASSES are passed as arguments to SELECT."
- (declare (ignore all set-operation group-by having offset limit inner-join on parameters)
+ View Classes VIEW-CLASSES are passed as arguments to SELECT.
+
+ TODO: the caching scheme of passing in instances and overwriting their
+ values seems bad for a number of reasons
+ * order is not guaranteed so references being held by one object
+ might change to represent a different database row (seems HIGHLY
+ suspect)
+
+ TODO: the way we handle immediate joins seems only valid if it is a single
+ object. I suspect that making a :set :immediate join column would result
+ in an invalid number of objects returned from the database, because there
+ would be multiple objects returned from the database
+ "
+ (declare (ignore all set-operation group-by having offset limit on parameters
+ distinct order-by)
(dynamic-extent args))
- (flet ((ref-equal (ref1 ref2)
- (string= (sql-output ref1 database)
- (sql-output ref2 database))))
- (declare (dynamic-extent (function ref-equal)))
- (let ((args (filter-plist args :from :where :flatp :additional-fields :result-types :instances)))
- (let* ((*db-deserializing* t)
- (sclasses (mapcar #'find-class view-classes))
- (immediate-join-slots
- (mapcar #'(lambda (c) (generate-retrieval-joins-list c :immediate)) sclasses))
- (immediate-join-classes
- (mapcar #'(lambda (jcs)
- (mapcar #'(lambda (slotdef)
- (find-class (gethash :join-class (view-class-slot-db-info slotdef))))
- jcs))
- immediate-join-slots))
- (immediate-join-sels (mapcar #'generate-immediate-joins-selection-list sclasses))
- (sels (mapcar #'generate-selection-list sclasses))
- (fullsels (apply #'append (mapcar #'append sels immediate-join-sels)))
- (sel-tables (collect-table-refs where))
- (tables (remove-if #'null
- (remove-duplicates
- (append (mapcar #'select-table-sql-expr sclasses)
- (mapcan #'(lambda (jc-list)
- (mapcar
- #'(lambda (jc) (when jc (select-table-sql-expr jc)))
- jc-list))
- immediate-join-classes)
- sel-tables)
- :test #'database-identifier-equal)))
- (order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
- (listify order-by)))
- (join-where nil))
-
- ;;(format t "sclasses: ~W~%ijc: ~W~%tables: ~W~%" sclasses immediate-join-classes tables)
-
- (dolist (ob order-by-slots)
- (when (and ob (not (member ob (mapcar #'cdr fullsels)
- :test #'ref-equal)))
- (setq fullsels
- (append fullsels (mapcar #'(lambda (att) (cons nil att))
- order-by-slots)))))
- (dolist (ob (listify distinct))
- (when (and (typep ob 'sql-ident)
- (not (member ob (mapcar #'cdr fullsels)
- :test #'ref-equal)))
- (setq fullsels
- (append fullsels (mapcar #'(lambda (att) (cons nil att))
- (listify ob))))))
- (mapcar #'(lambda (vclass jclasses jslots)
- (when jclasses
- (mapcar
- #'(lambda (jclass jslot)
- (let ((dbi (view-class-slot-db-info jslot)))
- (setq join-where
- (append
- (list (sql-operation '==
- (sql-expression
- :attribute (gethash :foreign-key dbi)
- :table (view-table jclass))
- (sql-expression
- :attribute (gethash :home-key dbi)
- :table (view-table vclass))))
- (when join-where (listify join-where))))))
- jclasses jslots)))
- sclasses immediate-join-classes immediate-join-slots)
- ;; Reported buggy on clsql-devel
- ;; (when where (setq where (listify where)))
- (cond
- ((and where join-where)
- (setq where (list (apply #'sql-and where join-where))))
- ((and (null where) (> (length join-where) 1))
- (setq where (list (apply #'sql-and join-where)))))
-
- (let* ((rows (apply #'select
- (append (mapcar #'cdr fullsels)
- (cons :from
- (list (append (when from (listify from))
- (listify tables))))
- (list :result-types result-types)
- (when where
- (list :where where))
- args)))
- (instances-to-add (- (length rows) (length instances)))
- (perhaps-extended-instances
- (if (plusp instances-to-add)
- (append instances (do ((i 0 (1+ i))
- (res nil))
- ((= i instances-to-add) res)
- (push (make-list (length sclasses) :initial-element nil) res)))
- instances))
- (objects (mapcar
- #'(lambda (row instance)
- (build-objects row sclasses immediate-join-classes sels
- immediate-join-sels database refresh flatp
- (if (and flatp (atom instance))
- (list instance)
- instance)))
- rows perhaps-extended-instances)))
- objects)))))
+ (let* ((args (filter-plist
+ args :from :where :flatp :additional-fields :result-types :instances))
+ (*db-deserializing* t)
+ (sclasses (mapcar #'to-class view-classes))
+ (tables (%tables-for-query sclasses from where inner-join))
+ (join-where
+ (loop for class in sclasses
+ appending (loop for slot in (immediate-join-slots class)
+ collect (join-slot-qualifier class slot))))
+ (select-lists (loop for class in sclasses
+ collect (make-select-list class :do-joins-p t)))
+ (full-select-list (full-select-list select-lists))
+ (where (clsql-ands (append (listify where) (listify join-where))))
+ #|
+ (_ (format t "~&sclasses: ~W~%ijc: ~W~%tables: ~W~%"
+ sclasses immediate-join-classes tables))
+ |#
+ (rows (apply #'select
+ (append full-select-list
+ (list :from tables
+ :result-types result-types
+ :where where)
+ args)))
+ (return-objects
+ (loop for row in rows
+ for old-objs = (pop instances)
+ for objs = (build-objects select-lists row database
+ (when refresh old-objs))
+ collecting (if flatp
+ (delist-if-single objs)
+ objs))))
+ return-objects))
(defmethod instance-refreshed ((instance standard-db-object)))
projects / clsql.git / blobdiff