(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
(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)
(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))
(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
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))
: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))
(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
(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))
(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)
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