(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)))
;;
(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)
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))
(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)))
+ (pk-name (when pk-slot (slot-definition-name pk-slot)))
(view-class-table (view-table view-class))
(pclass (car (class-direct-superclasses view-class))))
(when (normalizedp view-class)
(setf pk (update-records-from-instance obj :database database
:this-class pclass))
(when pk-slot
- (setf (slot-value obj (slot-definition-name pk-slot)) pk)))
+ (setf (slot-value obj pk-name) pk)))
(let* ((slots (remove-if-not #'slot-storedp
(if (normalizedp view-class)
(ordered-class-direct-slots view-class)
:database database)
(when pk-slot
(setf pk (or pk
- (slot-value obj (slot-definition-name pk-slot))))))
+ (slot-value obj pk-name)))))
(t
(insert-records :into (sql-expression :table view-class-table)
:av-pairs record-values
:database database)
-
(when (and pk-slot (not pk))
- (setf pk (if (or (member :auto-increment (listify (view-class-slot-db-constraints pk-slot)))
- (not (null (view-class-slot-autoincrement-sequence pk-slot))))
- (setf (slot-value obj (slot-definition-name pk-slot))
- (database-last-auto-increment-id database
- view-class-table
- pk-slot)))))
+ (setf pk
+ (when (auto-increment-column-p pk-slot database)
+ (setf (slot-value obj pk-name)
+ (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)
+ (and (slot-boundp obj pk-name)
+ (slot-value obj pk-name)))))
+ (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))))
+ (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))))))
+ (let ((slot-name (slot-definition-name slot)))
+ (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-name)
+ (slot-value obj slot-name))
+ (update-slot-from-record obj slot-name))))))
pk))
(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
(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
(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))
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