(flet ((qfk (k)
(sql-operation '==
(sql-expression :attribute
- (view-class-slot-column k)
+ (database-identifier k database)
:table tb)
(db-value-from-slot
k
(defun generate-attribute-reference (vclass slotdef)
(cond
((eq (view-class-slot-db-kind slotdef) :base)
- (sql-expression :attribute (view-class-slot-column slotdef)
- :table (view-table vclass)))
+ (sql-expression :attribute (database-identifier slotdef nil)
+ :table (database-identifier vclass nil)))
((eq (view-class-slot-db-kind slotdef) :key)
- (sql-expression :attribute (view-class-slot-column slotdef)
- :table (view-table vclass)))
+ (sql-expression :attribute (database-identifier slotdef nil)
+ :table (database-identifier vclass nil)))
(t nil)))
;;
(push (cons slotdef res) sels))))))
sels))
+(defmethod choose-database-for-instance ((obj standard-db-object) &optional database)
+ "Determine which database connection to use for a standard-db-object.
+ Errs if none is available."
+ (or (find-if #'(lambda (db)
+ (and db (is-database-open db)))
+ (list (view-database obj)
+ database
+ *default-database*))
+ (signal-no-database-error nil)))
+
+
;; Called by 'get-slot-values-from-view'
;;
(cond ((and value (null slot-reader))
(setf (slot-value instance slot-name)
(read-sql-value value (delistify slot-type)
- (view-database instance)
+ (choose-database-for-instance instance)
(database-underlying-type
- (view-database instance)))))
+ (choose-database-for-instance instance)))))
((null value)
(update-slot-with-null instance slot-name slotdef))
((typep slot-reader 'string)
(defmethod update-record-from-slot ((obj standard-db-object) slot &key
(database *default-database*))
- (let* ((database (or (view-database obj) database))
+ (let* ((database (choose-database-for-instance obj database))
(view-class (class-of obj)))
(when (normalizedp view-class)
;; If it's normalized, find the class that actually contains
(let* ((vct (view-table view-class))
(sd (slotdef-for-slot-with-class slot view-class)))
(check-slot-type sd (slot-value obj slot))
- (let* ((att (view-class-slot-column sd))
+ (let* ((att (database-identifier sd database))
(val (db-value-from-slot sd (slot-value obj slot) database)))
(cond ((and vct sd (view-database obj))
(update-records (sql-expression :table vct)
(update-record-from-slot obj slot :database database))
(return-from update-record-from-slots (values)))
- (let* ((database (or (view-database obj) database))
+ (let* ((database (choose-database-for-instance obj database))
(vct (view-table (class-of obj)))
(sds (slotdefs-for-slots-with-class slots (class-of obj)))
(avps (mapcar #'(lambda (s)
obj (slot-definition-name s))))
(check-slot-type s val)
(list (sql-expression
- :attribute (view-class-slot-column s))
+ :attribute (database-identifier s database))
(db-value-from-slot s val database))))
sds)))
(cond ((and avps (view-database obj))
- (update-records (sql-expression :table vct)
- :av-pairs avps
- :where (key-qualifier-for-instance
- obj :database database)
- :database database))
+ (let ((where (key-qualifier-for-instance
+ obj :database database)))
+ (unless where
+ (error "update-record-from-slots: could not generate a where clause for ~a" obj))
+ (update-records (sql-expression :table vct)
+ :av-pairs avps
+ :where where
+ :database database)))
((and avps (not (view-database obj)))
(insert-records :into (sql-expression :table vct)
:av-pairs avps
(defmethod update-records-from-instance ((obj standard-db-object)
&key database this-class)
- (let ((database (or database (view-database obj) *default-database*))
+ (let ((database (choose-database-for-instance obj database))
(pk nil))
(labels ((slot-storedp (slot)
(and (member (view-class-slot-db-kind slot) '(:base :key))
(slot-value-list (slot)
(let ((value (slot-value obj (slot-definition-name slot))))
(check-slot-type slot value)
- (list (sql-expression :attribute (view-class-slot-column slot))
+ (list (sql-expression :attribute (database-identifier slot database))
(db-value-from-slot slot value database)))))
(let* ((view-class (or this-class (class-of obj)))
(pk-slot (car (keyslots-for-class view-class)))
(ordered-class-direct-slots view-class)
(ordered-class-slots view-class))))
(record-values (mapcar #'slot-value-list slots)))
+
(cond ((and (not (normalizedp view-class))
(not record-values))
(error "No settable slots."))
(not record-values))
nil)
((view-database obj)
+ ;; if this slot is set, the database object was returned from a select
+ ;; and has already been in the database, so we must need an update
(update-records (sql-expression :table view-class-table)
:av-pairs record-values
:where (key-qualifier-for-instance
(setf pk (or pk
(slot-value obj (slot-definition-name pk-slot))))))
(t
- (insert-records :into (sql-expression :table view-class-table)
+ (insert-records :into (sql-expression :table view-class-table)
:av-pairs record-values
:database database)
- (when pk-slot
- (if (or (and (listp (view-class-slot-db-constraints pk-slot))
- (member :auto-increment (view-class-slot-db-constraints pk-slot)))
- (eql (view-class-slot-db-constraints pk-slot) :auto-increment))
- (setf pk (or pk
- (car (query "SELECT LAST_INSERT_ID();"
- :flatp t :field-names nil
- :database database))))
- (setf pk (or pk
- (slot-value obj (slot-definition-name pk-slot))))))
- (when (eql this-class nil)
- (setf (slot-value obj 'view-database) database)))))))
+
+ (when (and pk-slot (not pk))
+ (setf pk
+ (when (auto-increment-column-p pk-slot database)
+ (setf (slot-value obj (slot-definition-name pk-slot))
+ (database-last-auto-increment-id
+ database view-class-table pk-slot)))))
+ (when pk-slot
+ (setf pk (or pk
+ (slot-value
+ obj (slot-definition-name pk-slot)))))
+ (when (eql this-class nil)
+ (setf (slot-value obj 'view-database) database)))))))
+ ;; handle slots with defaults
+ (let* ((view-class (or this-class (class-of obj)))
+ (slots (if (normalizedp view-class)
+ (ordered-class-direct-slots view-class)
+ (ordered-class-slots view-class))))
+ (dolist (slot slots)
+ (when (and (slot-exists-p slot 'db-constraints)
+ (listp (view-class-slot-db-constraints slot))
+ (member :default (view-class-slot-db-constraints slot)))
+ (unless (and (slot-boundp obj (slot-definition-name slot))
+ (slot-value obj (slot-definition-name slot)))
+ (update-slot-from-record obj (slot-definition-name slot))))))
+
pk))
-(defmethod delete-instance-records ((instance standard-db-object))
- (let ((vt (sql-expression :table (view-table (class-of instance))))
- (vd (view-database instance)))
- (if vd
- (let ((qualifier (key-qualifier-for-instance instance :database vd)))
- (delete-records :from vt :where qualifier :database vd)
- (setf (record-caches vd) nil)
+(defmethod delete-instance-records ((instance standard-db-object) &key database)
+ (let ((database (choose-database-for-instance instance database))
+ (vt (sql-expression :table (view-table (class-of instance)))))
+ (if database
+ (let ((qualifier (key-qualifier-for-instance instance :database database)))
+ (delete-records :from vt :where qualifier :database database)
+ (setf (record-caches database) nil)
(setf (slot-value instance 'view-database) nil)
(values))
- (signal-no-database-error vd))))
+ (signal-no-database-error database))))
(defmethod update-instance-from-records ((instance standard-db-object)
&key (database *default-database*)
(setf pres (update-instance-from-records instance :database database
:this-class pclass)))
(let* ((view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
+ (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))
(ordered-class-direct-slots this-class)))
this-class))))
(let* ((view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
+ (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))
(sld (slotdef-for-slot-with-class slot class)))
(if sld
(if (eq value +no-slot-value+)
- (sql-expression :attribute (view-class-slot-column sld)
+ (sql-expression :attribute (database-identifier sld database)
:table (view-table class))
(db-value-from-slot
sld
:table jc-view-table))
:where jq
:result-types :auto
- :database (view-database object))))
+ :database (choose-database-for-instance object))))
(mapcar #'(lambda (i)
(let* ((instance (car i))
- (jcc (make-instance jc :view-database (view-database instance))))
+ (jcc (make-instance jc :view-database (choose-database-for-instance instance))))
(setf (slot-value jcc (gethash :foreign-key dbi))
key)
(setf (slot-value jcc (gethash :home-key tdbi))
;; just fill in minimal slots
(mapcar
#'(lambda (k)
- (let ((instance (make-instance tsc :view-database (view-database object)))
- (jcc (make-instance jc :view-database (view-database object)))
+ (let ((instance (make-instance tsc :view-database (choose-database-for-instance object)))
+ (jcc (make-instance jc :view-database (choose-database-for-instance object)))
(fk (car k)))
(setf (slot-value instance (gethash :home-key tdbi)) fk)
(setf (slot-value jcc (gethash :foreign-key dbi))
(select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
:from (sql-expression :table jc-view-table)
:where jq
- :database (view-database object))))))))
+ :database (choose-database-for-instance object))))))))
;;; Remote Joins
(let ((jq (join-qualifier class object slot-def)))
(when jq
(select jc :where jq :flatp t :result-types nil
- :database (view-database object))))))
+ :database (choose-database-for-instance object))))))
(defun fault-join-slot (class object slot-def)
(let* ((dbi (view-class-slot-db-info slot-def))
(symbol
(sql-expression
:attribute
- (view-class-slot-column
- (slotdef-for-slot-with-class fk sc))
+ (database-identifier
+ (slotdef-for-slot-with-class fk sc) nil)
:table (view-table sc)))
(t fk))
(typecase hk
(let ((res (car (select (class-name sc) :where jq
:flatp t :result-types nil
:caching nil
- :database (view-database object))))
+ :database (choose-database-for-instance object))))
(slot-name (slot-definition-name slot-def)))
;; If current class is normalized and wanted slot is not
(symbol
(sql-expression
:attribute
- (view-class-slot-column fksd)
- :table (view-table jc)))
+ (database-identifier fksd nil)
+ :table (database-identifier jc nil)))
(t fk))
(typecase hk
(symbol
(car objects)
objects))))
+(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 find-all (view-classes
&rest args
&key all set-operation distinct from where group-by having
order-by offset limit refresh flatp result-types
inner-join on
(database *default-database*)
- instances)
+ 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))
(flet ((ref-equal (ref1 ref2)
(string= (sql-output ref1 database)
- (sql-output ref2 database)))
- (table-sql-expr (table)
- (sql-expression :table (view-table table)))
- (tables-equal (table-a table-b)
- (when (and table-a table-b)
- (string= (string (slot-value table-a 'name))
- (string (slot-value table-b 'name))))))
+ (sql-output ref2 database))))
(remf args :from)
(remf args :where)
(remf args :flatp)
(sel-tables (collect-table-refs where))
(tables (remove-if #'null
(remove-duplicates
- (append (mapcar #'table-sql-expr sclasses)
+ (append (mapcar #'select-table-sql-expr sclasses)
(mapcan #'(lambda (jc-list)
(mapcar
- #'(lambda (jc) (when jc (table-sql-expr jc)))
+ #'(lambda (jc) (when jc (select-table-sql-expr jc)))
jc-list))
immediate-join-classes)
sel-tables)
- :test #'tables-equal)))
+ :test #'database-identifier-equal)))
(order-by-slots (mapcar #'(lambda (ob) (if (atom ob) ob (car ob)))
(listify order-by)))
(join-where nil))
(when (and order-by (= 1 (length target-args)))
(let ((table-name (view-table (find-class (car target-args))))
(order-by-list (copy-seq (listify order-by))))
-
- (loop for i from 0 below (length order-by-list)
- do (etypecase (nth i order-by-list)
- (sql-ident-attribute
- (unless (slot-value (nth i order-by-list) 'qualifier)
- (setf (slot-value (nth i order-by-list) 'qualifier) table-name)))
- (cons
- (unless (slot-value (car (nth i order-by-list)) 'qualifier)
- (setf (slot-value (car (nth i order-by-list)) 'qualifier) table-name)))))
+ (labels ((set-table-if-needed (val)
+ (typecase val
+ (sql-ident-attribute
+ (handler-case
+ (unless (slot-value val 'qualifier)
+ (setf (slot-value val 'qualifier) table-name))
+ (simple-error ()
+ ;; TODO: Check for a specific error we expect
+ )))
+ (cons (set-table-if-needed (car val))))))
+ (loop for i from 0 below (length order-by-list)
+ for id = (nth i order-by-list)
+ do (set-table-if-needed id)))
(setf (getf qualifier-args :order-by) order-by-list)))
(cond
results))))))))
(t
(let* ((expr (apply #'make-query select-all-args))
+ (parameters (second (member :parameters select-all-args)))
(specified-types
(mapcar #'(lambda (attrib)
(if (typep attrib 'sql-ident-attribute)
(database *default-database*)
&allow-other-keys)
qualifier-args
+ (when parameters
+ (setf expr (command-object (sql-output expr database) parameters)))
(query expr :flatp flatp
:result-types
;; specifying a type for an attribute overrides result-types
projects / clsql.git / blobdiff