From 7b89378f8c7b8437bef05f9b50f3613099ea41c0 Mon Sep 17 00:00:00 2001 From: Russ Tyndall Date: Mon, 19 Nov 2012 17:00:27 -0500 Subject: [PATCH] reworked fault-join-slot & fault-join-normalized-slot to do less work slot-value-using class got a bit cleaner along the way. --- sql/expressions.lisp | 48 ++++++++++++ sql/kmr-mop.lisp | 19 +++-- sql/ooddl.lisp | 38 ++++----- sql/oodml.lisp | 179 +++++++++++++++++++------------------------ 4 files changed, 158 insertions(+), 126 deletions(-) diff --git a/sql/expressions.lisp b/sql/expressions.lisp index 983d4a5..29363af 100644 --- a/sql/expressions.lisp +++ b/sql/expressions.lisp @@ -1182,3 +1182,51 @@ uninclusive, and the args from that keyword to the end." (%sql-expression (flatten-id name)) ))) +(defun %clsql-subclauses (clauses) + "a helper for dealing with lists of sql clauses" + (loop for c in clauses + when c + collect (typecase c + (string (clsql-sys:sql-expression :string c)) + (T c)))) + +(defun clsql-ands (clauses) + "Correctly creates a sql 'and' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'and' expression if there are many + returns nil if there are no children" + (let ((ex (%clsql-subclauses clauses))) + (when ex + (case (length ex) + (1 (first ex)) + (t (apply #'clsql-sys:sql-and ex)))))) + +(defun clsql-and (&rest clauses) + "Correctly creates a sql 'and' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'and' expression if there are many + returns nil if there are no children" + (clsql-ands clauses)) + +(defun clsql-ors (clauses) + "Correctly creates a sql 'or' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'or' expression if there are many + returns nil if there are no children" + (let ((ex (%clsql-subclauses clauses))) + (when ex + (case (length ex) + (1 (first ex)) + (t (apply #'clsql-sys:sql-or ex)))))) + +(defun clsql-or (&rest clauses) + "Correctly creates a sql 'or' expression for the clauses + ignores any nil clauses + returns a single child expression if there is only one + returns an 'or' expression if there are many + returns nil if there are no children" + (clsql-ors clauses)) + diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp index 017aa0b..f355282 100644 --- a/sql/kmr-mop.lisp +++ b/sql/kmr-mop.lisp @@ -66,19 +66,15 @@ #+mop-slot-order-reversed (reverse (class-direct-slots class)) #-mop-slot-order-reversed (class-direct-slots class)) -(defun find-slot-by-name (class slot-name &optional direct? recurse?) +(defun find-slot-if (class predicate &optional direct? recurse?) "Looks up a direct-slot-definition by name" - (setf class (to-class class) - slot-name (to-slot-name slot-name)) + (setf class (to-class class)) (labels ((find-it (class) (let* ((slots (if direct? (ordered-class-direct-slots class) (ordered-class-slots class))) - (it (find slot-name - slots - :key #'slot-definition-name))) - (if it - it + (it (find-if predicate slots))) + (or it (when recurse? (loop for sup in (class-direct-superclasses class) for rtn = (find-it sup) @@ -86,6 +82,13 @@ finally (return rtn))))))) (find-it class))) +(defun find-slot-by-name (class slot-name &optional direct? recurse?) + "Looks up a direct-slot-definition by name" + (setf class (to-class class) + slot-name (to-slot-name slot-name)) + (find-slot-if class (lambda (slot-def) (eql (to-slot-name slot-def) slot-name)) + direct? recurse?)) + ;; Lispworks has symbol for slot rather than the slot instance (defun %svuc-slot-name (slot) #+lispworks slot diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index 25308e1..bb2405b 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -31,28 +31,28 @@ (defvar *db-initializing* nil) (defmethod slot-value-using-class ((class standard-db-class) instance slot-def) + "When a slot is unbound but should contain a join object or a value from a + normalized view-class, then retrieve and set those slots, so the value can + be returned" (declare (optimize (speed 3))) (unless *db-deserializing* (let* ((slot-name (%svuc-slot-name slot-def)) - (slot-object (%svuc-slot-object slot-def class)) - (slot-kind (view-class-slot-db-kind slot-object))) - (if (and (eql slot-kind :join) - (not (slot-boundp instance slot-name))) - (let ((*db-deserializing* t)) - (if (view-database instance) - (setf (slot-value instance slot-name) - (fault-join-slot class instance slot-object)) - (setf (slot-value instance slot-name) nil))) - (when (and (normalizedp class) - (not (member slot-name - (mapcar #'(lambda (esd) (slot-definition-name esd)) - (ordered-class-direct-slots class)))) - (not (slot-boundp instance slot-name))) - (let ((*db-deserializing* t)) - (if (view-database instance) - (setf (slot-value instance slot-name) - (fault-join-normalized-slot class instance slot-object)) - (setf (slot-value instance slot-name) nil))))))) + (slot-object (%svuc-slot-object slot-def class))) + (unless (slot-boundp instance slot-name) + (let ((*db-deserializing* t)) + (cond + ((join-slot-p slot-def) + (setf (slot-value instance slot-name) + (if (view-database instance) + (fault-join-slot class instance slot-object) + ;; TODO: you could in theory get a join object even if + ;; its joined-to object was not in the database + nil + ))) + ((not-direct-normalized-slot-p class slot-def) + (if (view-database instance) + (update-fault-join-normalized-slot class instance slot-def) + (setf (slot-value instance slot-name) nil)))))))) (call-next-method)) (defmethod (setf slot-value-using-class) (new-value (class standard-db-class) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index bf9026b..03aa551 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -12,39 +12,38 @@ (in-package #:clsql-sys) +(defun find-normalized-key (obj) + (find-slot-if obj #'key-slot-p T T)) + +(defun normalized-key-value (obj) + "Normalized classes share a single key for all their key slots" + (when (normalizedp (class-of obj)) + (easy-slot-value obj (find-normalized-key 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 - (database-identifier k database) - :table tb) - (db-value-from-slot - k - (slot-value obj (slot-definition-name k)) - database)))) - (let* ((keys (keyslots-for-class obj-class)) - (keyxprs (mapcar #'qfk (reverse keys)))) - (cond - ((= (length keyxprs) 0) nil) - ((= (length keyxprs) 1) (car keyxprs)) - ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs))))))) - -;; -;; Function used by 'generate-selection-list' -;; - -(defun generate-attribute-reference (vclass slotdef) - (cond - ((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))) + (keys (keyslots-for-class obj-class)) + (normal-db-value (normalized-key-value obj))) + (when keys + (labels ((db-value (k) + (or normal-db-value + (db-value-from-slot + k + (easy-slot-value obj k) + database))) + (key-equal-exp (k) + (sql-operation '== (generate-attribute-reference obj-class k database) + (db-value k)))) + (clsql-ands (mapcar #'key-equal-exp keys)))))) + +(defun generate-attribute-reference (vclass slotdef &optional (database *default-database*)) + "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" + (when (key-or-base-slot-p slotdef) + (sql-expression :attribute (database-identifier slotdef database) + :table (database-identifier vclass database)))) ;; ;; Function used by 'find-all' @@ -194,6 +193,18 @@ "get the view-table of the view-class of o" (view-table (view-class o))) +(defmethod view-table-exp ((o class-and-slots)) + (sql-expression :table (view-table o))) + +(defmethod view-table-exp ((o standard-db-class)) + (sql-expression :table (view-table o))) + +(defmethod attribute-references ((o class-and-slots)) + (loop + with class = (view-class o) + for sd in (slot-defs o) + collect (generate-attribute-reference class sd))) + (defmethod attribute-value-pairs ((def class-and-slots) (o standard-db-object) database) "for a given class-and-slots and object, create the sql-expression & value pairs @@ -406,28 +417,34 @@ (pres) (t nil))))) + +(defmethod get-slot-value-from-record ((instance standard-db-object) + slot &key (database *default-database*)) + (let* ((class-and-slot + (first + (view-classes-and-slots-by-name instance slot))) + (view-class (view-class class-and-slot)) + (slot-def (first (slot-defs class-and-slot))) + (vd (choose-database-for-instance instance database)) + (att-ref (first (attribute-references class-and-slot))) + (res (first + (select att-ref + :from (view-table-exp class-and-slot) + :where (key-qualifier-for-instance + instance + :database vd + :this-class view-class) + :result-types nil + :flatp T)))) + (values res slot-def))) + (defmethod update-slot-from-record ((instance standard-db-object) slot &key (database *default-database*)) - (let* ((view-class (find-class (class-name (class-of instance)))) - (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)))) - ((direct-normalized-slot-p this-class slot) - 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)))))) + (multiple-value-bind (res slot-def) + (get-slot-value-from-record instance slot :database database) + (let ((vd (choose-database-for-instance instance database))) + (setf (slot-value instance 'view-database) vd) + (update-slot-from-db-value instance slot-def res)))) (defvar +no-slot-value+ '+no-slot-value+) @@ -940,65 +957,29 @@ maximum of MAX-LEN instances updated in each query." (select jc :where jq :flatp t :result-types nil :database (choose-database-for-instance object)))))) + + (defun fault-join-slot (class object slot-def) (let* ((dbi (view-class-slot-db-info slot-def)) - (ts (gethash :target-slot dbi))) - (if (and ts (gethash :set dbi)) + (ts (gethash :target-slot dbi)) + (dbi-set (gethash :set dbi))) + (if (and ts dbi-set) (fault-join-target-slot class object slot-def) (let ((res (fault-join-slot-raw class object slot-def))) (when res (cond - ((and ts (not (gethash :set dbi))) + ((and ts (not dbi-set)) (mapcar (lambda (obj) (slot-value obj ts)) res)) - ((and (not ts) (not (gethash :set dbi))) + ((and (not ts) (not dbi-set)) (car res)) - ((and (not ts) (gethash :set dbi)) + ((and (not ts) dbi-set) 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 update-fault-join-normalized-slot (class object slot-def) + (if (and (normalizedp class) (key-slot-p slot-def)) + (setf (easy-slot-value object slot-def) + (normalized-key-value object)) + (update-slot-from-record object slot-def))) (defun join-qualifier (class object slot-def) (declare (ignore class)) -- 2.34.1