;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id$
-;;;;
;;;; The CLSQL Object Oriented Data Manipulation Language (OODML).
;;;;
;;;; This file is part of CLSQL.
(in-package #:clsql-sys)
-(defun key-qualifier-for-instance (obj &key (database *default-database*))
- (let ((tb (view-table (class-of obj))))
+(defun key-qualifier-for-instance (obj &key (database *default-database*) this-class)
+ (let* ((obj-class (or this-class (class-of obj)))
+ (tb (view-table obj-class)))
(flet ((qfk (k)
(sql-operation '==
(sql-expression :attribute
- (view-class-slot-column k)
+ (database-identifier k database)
:table tb)
(db-value-from-slot
k
(slot-value obj (slot-definition-name k))
database))))
- (let* ((keys (keyslots-for-class (class-of obj)))
+ (let* ((keys (keyslots-for-class obj-class))
(keyxprs (mapcar #'qfk (reverse keys))))
(cond
((= (length keyxprs) 0) nil)
(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)))
- ((eq (view-class-slot-db-kind slotdef) :key)
- (sql-expression :attribute (view-class-slot-column slotdef)
- :table (view-table vclass)))
- (t nil)))
+ ((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)))
;;
;; Function used by 'find-all'
;;
(defun generate-selection-list (vclass)
- (let ((sels nil))
- (dolist (slotdef (ordered-class-slots vclass))
- (let ((res (generate-attribute-reference vclass slotdef)))
+ (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
(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 get-slot-values-from-view (obj slotdeflist values)
- (flet ((update-slot (slot-def values)
- (update-slot-from-db obj slot-def values)))
- (mapc #'update-slot slotdeflist values)
- obj))
+ (flet ((update-slot (slot-def values)
+ (update-slot-from-db obj slot-def values)))
+ (mapc #'update-slot slotdeflist values)
+ obj))
(defmethod update-record-from-slot ((obj standard-db-object) slot &key
(database *default-database*))
- (let* ((database (or (view-database obj) database))
- (vct (view-table (class-of obj)))
- (sd (slotdef-for-slot-with-class slot (class-of obj))))
- (check-slot-type sd (slot-value obj slot))
- (let* ((att (view-class-slot-column sd))
- (val (db-value-from-slot sd (slot-value obj slot) database)))
- (cond ((and vct sd (view-database obj))
- (update-records (sql-expression :table vct)
- :attributes (list (sql-expression :attribute att))
- :values (list val)
- :where (key-qualifier-for-instance
- obj :database database)
- :database database))
- ((and vct sd (not (view-database obj)))
- (insert-records :into (sql-expression :table vct)
- :attributes (list (sql-expression :attribute att))
- :values (list val)
- :database database)
- (setf (slot-value obj 'view-database) database))
- (t
- (error "Unable to update record.")))))
- (values))
+ (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
+ ;; the slot that's tied to the db
+ (setf view-class
+ (do ((this-class view-class
+ (car (class-direct-superclasses this-class))))
+ ((member slot
+ (mapcar #'(lambda (esd) (slot-definition-name esd))
+ (ordered-class-direct-slots this-class)))
+ this-class))))
+ (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 (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)
+ :attributes (list (sql-expression :attribute att))
+ :values (list val)
+ :where (key-qualifier-for-instance
+ obj :database database :this-class view-class)
+ :database database))
+ ((and vct sd (not (view-database obj)))
+ (insert-records :into (sql-expression :table vct)
+ :attributes (list (sql-expression :attribute att))
+ :values (list val)
+ :database database)
+ (setf (slot-value obj 'view-database) database))
+ (t
+ (error "Unable to update record.")))))
+ (values)))
(defmethod update-record-from-slots ((obj standard-db-object) slots &key
(database *default-database*))
- (let* ((database (or (view-database obj) database))
+ (when (normalizedp (class-of obj))
+ ;; FIXME: Rewrite to bundle slots for same table to be written
+ ;; as avpairs (like how is done for non-normalized view-classes below)
+ (dolist (slot slots)
+ (update-record-from-slot obj slot :database database))
+ (return-from update-record-from-slots (values)))
+
+ (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
(error "Unable to update records"))))
(values))
-(defmethod update-records-from-instance ((obj standard-db-object) &key database)
- (let ((database (or database (view-database obj) *default-database*)))
+(defmethod update-records-from-instance ((obj standard-db-object)
+ &key database this-class)
+ (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-boundp obj (slot-definition-name slot))))
(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 (class-of obj))
+ (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))
- (slots (remove-if-not #'slot-storedp
- (ordered-class-slots view-class)))
- (record-values (mapcar #'slot-value-list slots)))
- (unless record-values
- (error "No settable slots."))
- (if (view-database obj)
- (update-records (sql-expression :table view-class-table)
- :av-pairs record-values
- :where (key-qualifier-for-instance
- obj :database database)
- :database database)
- (progn
- (insert-records :into (sql-expression :table view-class-table)
- :av-pairs record-values
- :database database)
- (setf (slot-value obj 'view-database) database))))))
- (values))
-
-(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)
+ (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 pk-name) pk)))
+ (let* ((slots (remove-if-not #'slot-storedp
+ (if (normalizedp 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."))
+ ((and (normalizedp view-class)
+ (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
+ obj :database database
+ :this-class view-class)
+ :database database)
+ (when pk-slot
+ (setf pk (or pk
+ (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
+ (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
+ (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))))
+ (dolist (slot slots)
+ (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))
+
+(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*))
- (let* ((view-class (find-class (class-name (class-of instance))))
- (view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
- (view-qual (key-qualifier-for-instance instance :database vd))
- (sels (generate-selection-list view-class))
- (res (apply #'select (append (mapcar #'cdr sels)
- (list :from view-table
- :where view-qual
- :result-types nil
- :database vd)))))
- (when res
- (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
+ &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)))))
(defmethod update-slot-from-record ((instance standard-db-object)
slot &key (database *default-database*))
(let* ((view-class (find-class (class-name (class-of instance))))
- (view-table (sql-expression :table (view-table view-class)))
- (vd (or (view-database instance) database))
- (view-qual (key-qualifier-for-instance instance :database vd))
- (slot-def (slotdef-for-slot-with-class slot 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
- (get-slot-values-from-view instance (list slot-def) (car res)))))
-
+ (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))))
+ ((member slot
+ (mapcar #'(lambda (esd) (slot-definition-name esd))
+ (ordered-class-direct-slots this-class)))
+ 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))))))
(defmethod update-slot-with-null ((object standard-db-object)
slotname
(defvar +no-slot-value+ '+no-slot-value+)
(defsql sql-slot-value (:symbol "slot-value") (classname slot &optional (value +no-slot-value+) (database *default-database*))
- (let* ((class (find-class classname))
- (sld (slotdef-for-slot-with-class slot class)))
- (if sld
- (if (eq value +no-slot-value+)
- (sql-expression :attribute (view-class-slot-column sld)
- :table (view-table class))
- (db-value-from-slot
- sld
- value
- database))
- (error "Unknown slot ~A for class ~A" slot classname))))
+ (let* ((class (find-class classname))
+ (sld (slotdef-for-slot-with-class slot class)))
+ (if sld
+ (if (eq value +no-slot-value+)
+ (sql-expression :attribute (database-identifier sld database)
+ :table (view-table class))
+ (db-value-from-slot
+ sld
+ value
+ database))
+ (error "Unknown slot ~A for class ~A" slot classname))))
(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*))
(declare (ignore database))
(declare (ignore database db-type))
(if args
(format nil "INT(~A)" (car args))
- "INT"))
+ "INT"))
(deftype tinyint ()
"An 8-bit integer, this width may vary by SQL implementation."
(defmethod database-get-type-specifier ((type (eql 'number)) args database db-type)
(declare (ignore database db-type))
(cond
- ((and (consp args) (= (length args) 2))
- (format nil "NUMBER(~D,~D)" (first args) (second args)))
- ((and (consp args) (= (length args) 1))
- (format nil "NUMBER(~D)" (first args)))
- (t
- "NUMBER")))
+ ((and (consp args) (= (length args) 2))
+ (format nil "NUMBER(~D,~D)" (first args) (second args)))
+ ((and (consp args) (= (length args) 1))
+ (format nil "NUMBER(~D)" (first args)))
+ (t
+ "NUMBER")))
(defmethod database-get-type-specifier ((type (eql 'char)) args database db-type)
(declare (ignore database db-type))
(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database db-type)
(declare (ignore database db-type))
(if val
- (concatenate 'string
- (package-name (symbol-package val))
- "::"
- (symbol-name val))
- ""))
+ (concatenate 'string
+ (package-name (symbol-package val))
+ "::"
+ (symbol-name val))
+ ""))
(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database db-type)
(declare (ignore database db-type))
(format nil "~F" val))))
(defmethod read-sql-value (val type database db-type)
- (declare (ignore type database db-type))
- (read-from-string val))
+ (declare (ignore database db-type))
+ (cond
+ ((null type) val) ;;we have no desired type, just give the value
+ ((typep val type) val) ;;check that it hasn't already been converted.
+ ((typep val 'string) (read-from-string val)) ;;maybe read will just take care of it?
+ (T (error "Unable to read-sql-value ~a as type ~a" val type))))
(defmethod read-sql-value (val (type (eql 'string)) database db-type)
(declare (ignore database db-type))
(declare (ignore database db-type))
;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...)
(etypecase val
- (string
- (float (read-from-string val)))
- (float
- val)))
+ (string (float (read-from-string val)))
+ (float val)))
+
+(defmethod read-sql-value (val (type (eql 'double-float)) database db-type)
+ (declare (ignore database db-type))
+ ;; writing 1.0 writes 1, so if we *really* want a float, must do (float ...)
+ (etypecase val
+ (string (float
+ (let ((*read-default-float-format* 'double-float))
+ (read-from-string val))
+ 1.0d0))
+ (double-float val)
+ (float (coerce val 'double-float))))
(defmethod read-sql-value (val (type (eql 'boolean)) database db-type)
(declare (ignore database db-type))
: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))
(slot-value instance (gethash :foreign-key tdbi)))
- (list instance jcc)))
+ (list instance jcc)))
res)))
(:deferred
- ;; 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)))
- (fk (car k)))
- (setf (slot-value instance (gethash :home-key tdbi)) fk)
- (setf (slot-value jcc (gethash :foreign-key dbi))
- key)
- (setf (slot-value jcc (gethash :home-key tdbi))
- fk)
- (list instance jcc)))
- (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))))))))
+ ;; just fill in minimal slots
+ (mapcar
+ #'(lambda (k)
+ (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))
+ key)
+ (setf (slot-value jcc (gethash :home-key tdbi))
+ fk)
+ (list instance jcc)))
+ (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
+ :from (sql-expression :table jc-view-table)
+ :where jq
+ :database (choose-database-for-instance object))))))))
;;; Remote Joins
UPDATE-OBJECT-JOINS.")
(defun update-objects-joins (objects &key (slots t) (force-p t)
- class-name (max-len
- *default-update-objects-max-len*))
+ class-name (max-len
+ *default-update-objects-max-len*))
"Updates from the records of the appropriate database tables
the join slots specified by SLOTS in the supplied list of View
Class instances OBJECTS. SLOTS is t by default which means that
(slotdefs
(if (eq t slots)
(generate-retrieval-joins-list class :deferred)
- (remove-if #'null
- (mapcar #'(lambda (name)
- (let ((slotdef (find name class-slots :key #'slot-definition-name)))
- (unless slotdef
- (warn "Unable to find slot named ~S in class ~S." name class))
- slotdef))
- slots)))))
+ (remove-if #'null
+ (mapcar #'(lambda (name)
+ (let ((slotdef (find name class-slots :key #'slot-definition-name)))
+ (unless slotdef
+ (warn "Unable to find slot named ~S in class ~S." name class))
+ slotdef))
+ slots)))))
(dolist (slotdef slotdefs)
(let* ((dbi (view-class-slot-db-info slotdef))
(slotdef-name (slot-definition-name slotdef))
(remove-duplicates
(if force-p
(mapcar #'(lambda (o) (slot-value o home-key)) objects)
- (remove-if #'null
- (mapcar
- #'(lambda (o) (if (slot-boundp o slotdef-name)
- nil
- (slot-value o home-key)))
- objects)))))
+ (remove-if #'null
+ (mapcar
+ #'(lambda (o) (if (slot-boundp o slotdef-name)
+ nil
+ (slot-value o home-key)))
+ objects)))))
(n-object-keys (length object-keys))
(query-len (or max-len n-object-keys)))
((>= i n-object-keys))
(let* ((keys (if max-len
(subseq object-keys i (min (+ i query-len) n-object-keys))
- object-keys))
+ object-keys))
(results (unless (gethash :target-slot dbi)
- (find-all (list (gethash :join-class dbi))
- :where (make-instance 'sql-relational-exp
- :operator 'in
- :sub-expressions (list (sql-expression :attribute foreign-key)
- keys))
- :result-types :auto
- :flatp t)) ))
+ (find-all (list (gethash :join-class dbi))
+ :where (make-instance 'sql-relational-exp
+ :operator 'in
+ :sub-expressions (list (sql-expression :attribute foreign-key)
+ keys))
+ :result-types :auto
+ :flatp t)) ))
(dolist (object objects)
(when (or force-p (not (slot-boundp object slotdef-name)))
(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))
((and (not ts) (gethash :set dbi))
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 join-qualifier (class object slot-def)
- (declare (ignore class))
- (let* ((dbi (view-class-slot-db-info slot-def))
- (jc (find-class (gethash :join-class dbi)))
- ;;(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
- (view-class-slot-column fksd)
- :table (view-table jc)))
- (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))))))
+ (declare (ignore class))
+ (let* ((dbi (view-class-slot-db-info slot-def))
+ (jc (find-class (gethash :join-class dbi)))
+ ;;(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 =>
(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* ((slots (class-slots (class-of jo)))
+ (let* ((jo-class (class-of jo))
+ (slots
+ (if (normalizedp jo-class)
+ (class-direct-slots jo-class)
+ (class-slots jo-class)))
(pos-list (remove-if #'null
(mapcar
#'(lambda (s)
joins)
(mapc
#'(lambda (jc)
- (let ((slot (find (class-name (class-of jc)) (class-slots vclass)
- :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))))))
+ (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)
sclasses immediate-join-classes sels immediate-joins instances)))
(if (and flatp (= (length sclasses) 1))
(car objects)
- 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)
+ order-by offset limit refresh flatp result-types
+ inner-join on
+ (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))
+ (declare (ignore all set-operation group-by having offset limit inner-join on parameters)
+ (dynamic-extent args))
(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))))))
- (remf args :from)
- (remf args :where)
- (remf args :flatp)
- (remf args :additional-fields)
- (remf args :result-types)
- (remf args :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 #'table-sql-expr sclasses)
- (mapcan #'(lambda (jc-list)
- (mapcar
- #'(lambda (jc) (when jc (table-sql-expr jc)))
- jc-list))
- immediate-join-classes)
- sel-tables)
- :test #'tables-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))))
+ (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)))))
(defmethod instance-refreshed ((instance standard-db-object)))
specification states caching is on by default.")
(defun select (&rest select-all-args)
- "Executes a query on DATABASE, which has a default value of
+ "Executes a query on DATABASE, which has a default value of
*DEFAULT-DATABASE*, specified by the SQL expressions supplied
using the remaining arguments in SELECT-ALL-ARGS. The SELECT
argument can be used to generate queries in both functional and
a list of lists. If FLATP is t and only one result is returned
for each record selected in the query, the results are returned
as elements of a list."
+ (multiple-value-bind (target-args qualifier-args)
+ (query-get-selections select-all-args)
+ (unless (or *default-database* (getf qualifier-args :database))
+ (signal-no-database-error nil))
- (flet ((select-objects (target-args)
- (and target-args
- (every #'(lambda (arg)
- (and (symbolp arg)
- (find-class arg nil)))
- target-args))))
- (multiple-value-bind (target-args qualifier-args)
- (query-get-selections select-all-args)
- (unless (or *default-database* (getf qualifier-args :database))
- (signal-no-database-error nil))
-
- (cond
- ((select-objects target-args)
- (let ((caching (getf qualifier-args :caching *default-caching*))
- (result-types (getf qualifier-args :result-types :auto))
- (refresh (getf qualifier-args :refresh nil))
- (database (or (getf qualifier-args :database) *default-database*))
- (order-by (getf qualifier-args :order-by)))
- (remf qualifier-args :caching)
- (remf qualifier-args :refresh)
- (remf qualifier-args :result-types)
-
- ;; Add explicity table name to order-by if not specified and only
- ;; one selected table. This is required so FIND-ALL won't duplicate
- ;; the field
- (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)))))
- (setf (getf qualifier-args :order-by) order-by-list)))
+ (let ((caching (getf qualifier-args :caching *default-caching*))
+ (result-types (getf qualifier-args :result-types :auto))
+ (refresh (getf qualifier-args :refresh nil))
+ (database (getf qualifier-args :database *default-database*)))
- (cond
- ((null caching)
- (apply #'find-all target-args
- (append qualifier-args
- (list :result-types result-types :refresh refresh))))
- (t
- (let ((cached (records-cache-results target-args qualifier-args database)))
- (cond
- ((and cached (not refresh))
- cached)
- ((and cached refresh)
- (let ((results (apply #'find-all (append (list target-args) qualifier-args `(:instances ,cached :result-types :auto :refresh ,refresh)))))
- (setf (records-cache-results target-args qualifier-args database) results)
- results))
- (t
- (let ((results (apply #'find-all target-args (append qualifier-args
- `(:result-types :auto :refresh ,refresh)))))
- (setf (records-cache-results target-args qualifier-args database) results)
- results))))))))
- (t
- (let* ((expr (apply #'make-query select-all-args))
- (specified-types
+ (cond
+ ((and target-args
+ (every #'(lambda (arg)
+ (and (symbolp arg)
+ (find-class arg nil)))
+ target-args))
+
+ (setf qualifier-args (filter-plist qualifier-args :caching :refresh :result-types))
+
+ ;; Add explicity table name to order-by if not specified and only
+ ;; one selected table. This is required so FIND-ALL won't duplicate
+ ;; the field
+ (let ((order-by (getf qualifier-args :order-by)))
+ (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))))
+ (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
+ ((null caching)
+ (apply #'find-all target-args :result-types result-types :refresh refresh qualifier-args))
+ (t
+ (let ((cached (records-cache-results target-args qualifier-args database)))
+ (if (and cached (not refresh))
+ cached
+ (let ((results (apply #'find-all target-args
+ :result-types :auto :refresh refresh
+ :instances cached
+ qualifier-args)))
+ (setf (records-cache-results target-args qualifier-args database) results)
+
+ 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)
(let ((type (slot-value attrib 'type)))
type
t))
t))
- (slot-value expr 'selections))))
- (destructuring-bind (&key (flatp nil)
- (result-types :auto)
- (field-names t)
- (database *default-database*)
- &allow-other-keys)
- qualifier-args
- (query expr :flatp flatp
- :result-types
- ;; specifying a type for an attribute overrides result-types
- (if (some #'(lambda (x) (not (eq t x))) specified-types)
- specified-types
- result-types)
- :field-names field-names
- :database database))))))))
+ (slot-value expr 'selections)))
+ (flatp (getf qualifier-args :flatp))
+ (field-names (getf qualifier-args :field-names t)))
+
+ (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
+ (if (some #'(lambda (x) (not (eq t x))) specified-types)
+ specified-types
+ result-types)
+ :field-names field-names
+ :database database)))))))
(defun compute-records-cache-key (targets qualifiers)
(list targets
(defun (setf records-cache-results) (results targets qualifiers database)
(unless (record-caches database)
(setf (record-caches database)
- (make-hash-table :test 'equal
- #+allegro :values #+allegro :weak
- #+clisp :weak #+clisp :value
- #+lispworks :weak-kind #+lispworks :value)))
- (setf (gethash (compute-records-cache-key targets qualifiers)
+ (make-weak-hash-table :test 'equal)))
+ (setf (gethash (compute-records-cache-key (copy-list targets) qualifiers)
(record-caches database)) results)
results)