From a244caf265fff60cc9d00083e15951762dd7f1ca Mon Sep 17 00:00:00 2001 From: Kevin Rosenberg Date: Thu, 10 Dec 2009 11:21:24 -0700 Subject: [PATCH] Add normalized view classes Large patch from Thijs Oppermann to add support for normalized view classes. When having view class that inherit from others, CLSQL by default builds tab all the columns from the parent in the child. This patch is meant to normali so that a join is done on the primary keys of the concerned tables to get a set. --- .gitignore | 1 + ChangeLog | 8 + doc/csql.xml | 29 ++ doc/ref-ooddl.xml | 155 +++++++-- sql/metaclasses.lisp | 27 +- sql/ooddl.lisp | 78 +++-- sql/oodml.lisp | 715 +++++++++++++++++++++++++----------------- tests/test-fddl.lisp | 3 +- tests/test-init.lisp | 101 +++++- tests/test-ooddl.lisp | 27 +- tests/test-oodml.lisp | 602 ++++++++++++++++++++++++++++++++++- 11 files changed, 1386 insertions(+), 360 deletions(-) diff --git a/.gitignore b/.gitignore index 7109e63..ee7d837 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ configure-stamp build-stamp +*~ diff --git a/ChangeLog b/ChangeLog index 4e59172..4caaa4b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,11 @@ + 10 Dec 2009 Kevin Rosenberg + Large patch from Thijs Oppermann to add + support for normalized view classes. When having view class that + inherit from others, CLSQL by default builds tab all the columns + from the parent in the child. This patch is meant to normali so + that a join is done on the primary keys of the concerned tables to + get a set. + 10 Dec 2009 Kevin Rosenberg * sql/time.lisp: Patch from Oleg Tihonov to SYNTAX-PARSE-ISO-8601 to properly parse fractions of seconds. diff --git a/doc/csql.xml b/doc/csql.xml index f84dd50..4374d93 100644 --- a/doc/csql.xml +++ b/doc/csql.xml @@ -292,6 +292,17 @@ mapped into a database). They would be defined as follows: :base-table option specifies what the table name for the view class will be when it is mapped into the database. + + + Another class option is :normalisedp, which signals + &clsql; to use a normalised schema for the mapping from slots to + &sql; columns. By default &clsql; includes all the slots of a parent + class that map to &sql; columns into the child class. This option + tells &clsql; to normalise the schema, so that a join is done on the + primary keys of the concerned tables to get a complete column set + for the classes. For more information, see + def-view-class. + @@ -454,6 +465,24 @@ There are other :join-info options available in &clsql;, but we will save those till we get to the many-to-many relation examples. + + Object Oriented Class Relations + + +&clsql; provides an Object Oriented Data Definition Language, which +provides a mapping from &sql; tables to CLOS objects. By default class +inheritance is handled by including all the columns from parent +classes into the child class. This means your database schema becomes +very much denormalised. The class option :normalisedp +can be used to disable the default behaviour and have &clsql; +normalise the database schemas of inherited classes. + + + +See def-view-class +for more information. + + diff --git a/doc/ref-ooddl.xml b/doc/ref-ooddl.xml index e3ad2f3..ee8f601 100644 --- a/doc/ref-ooddl.xml +++ b/doc/ref-ooddl.xml @@ -5,9 +5,9 @@ %myents; ]> - - - Object Oriented Data Definition Language (OODDL) + + + Object Oriented Data Definition Language (OODDL) The Object Oriented Data Definition Language (OODDL) provides @@ -15,7 +15,7 @@ (CLOS) objects. SQL tables are mapped to CLOS objects with the SQL columns being mapped to slots of the CLOS object. - + The mapping between SQL tables and CLOS objects is defined with the macro def-view-class. SQL @@ -59,11 +59,11 @@ Slots - + slot VIEW-DATABASE is of type (OR NULL DATABASE) which stores the associated database for the instance. - + @@ -78,14 +78,14 @@ Value Type Fixnum - + Initial Value 255 - Description + Description If a slot of a class defined by def-view-class is of the type @@ -105,9 +105,9 @@ (c :type varchar)))) => #<Standard-Db-Class S80 {480A431D}> -(create-view-from-class 's80) -=> -(table-exists-p [s80]) +(create-view-from-class 's80) +=> +(table-exists-p [s80]) => T @@ -193,7 +193,7 @@ (def-view-class foo () ((a :type (string 80)))) => #<Standard-Db-Class FOO {4807F7CD}> (create-view-from-class 'foo) -=> +=> (list-tables) => ("FOO") @@ -453,7 +453,7 @@ wide. [not supported by all database backends] - bigint - An integer column + bigint - An integer column 64-bits wide. [not supported by all database backends] @@ -495,7 +495,7 @@ keyword - stores a keyword - + symbol - stores a symbol list - stores a list by writing @@ -508,7 +508,7 @@ similarly to list - + @@ -587,6 +587,16 @@ are converted to underscore characters. + + + :normalisedp - specifies whether + this class uses normalised inheritance from parent classes. + Defaults to nil, i.e. non-normalised schemas. When true, + SQL database tables that map to this class and parent + classes are joined on their primary keys to get the full + set of database columns for this class. + + @@ -606,6 +616,105 @@ this class. + Normalised inheritance schemas + + Specifying that :normalisedp is T + tells &clsql; to normalise the database schema for inheritance. + What this means is shown in the examples below. + + + + With :normalisedp equal to NIL + (the default) the class inheritance would result in the following: + + +(def-view-class node () + ((title :accessor title :initarg :title :type (varchar 240)))) + +SQL table NODE: ++-------+--------------+------+-----+---------+-------+ +| Field | Type | Null | Key | Default | Extra | ++-------+--------------+------+-----+---------+-------+ +| TITLE | varchar(240) | YES | | NULL | | ++-------+--------------+------+-----+---------+-------+ + +(def-view-class user (node) + ((user-id :accessor user-id :initarg :user-id + :type integer :db-kind :key :db-constraints (:not-null)) + (nick :accessor nick :initarg :nick :type (varchar 64)))) + +SQL table USER: ++---------+--------------+------+-----+---------+-------+ +| Field | Type | Null | Key | Default | Extra | ++---------+--------------+------+-----+---------+-------+ +| USER_ID | int(11) | NO | PRI | | | +| NICK | varchar(64) | YES | | NULL | | +| TITLE | varchar(240) | YES | | NULL | | ++---------+--------------+------+-----+---------+-------+ + + + + Using :normalisedp T, both + view-classes need a primary key to join them on: + + +(def-view-class node () + ((node-id :accessor node-id :initarg :node-id + :type integer :db-kind :key + :db-constraints (:not-null)) + (title :accessor title :initarg :title :type (varchar 240)))) + +SQL table NODE: ++---------+--------------+------+-----+---------+-------+ +| Field | Type | Null | Key | Default | Extra | ++---------+--------------+------+-----+---------+-------+ +| NODE_ID | int(11) | NO | PRI | | | +| TITLE | varchar(240) | YES | | NULL | | ++---------+--------------+------+-----+---------+-------+ + +(def-view-class user (node) + ((user-id :accessor user-id :initarg :user-id + :type integer :db-kind :key :db-constraints (:not-null)) + (nick :accessor nick :initarg :nick :type (varchar 64))) + (:normalisedp t)) + +SQL table USER: ++---------+-------------+------+-----+---------+-------+ +| Field | Type | Null | Key | Default | Extra | ++---------+-------------+------+-----+---------+-------+ +| USER_ID | int(11) | NO | PRI | | | +| NICK | varchar(64) | YES | | NULL | | ++---------+-------------+------+-----+---------+-------+ + + + + In this second case, all slots of the view-class 'node + are also available in view-class 'user, and can be used + as one would expect. For example, with the above normalised + view-classes 'node and 'user, and SQL tracing turned on: + + +CLSQL> (setq test-user (make-instance 'user :node-id 1 :nick "test-user" + :title "This is a test user")) +# + +CLSQL> (update-records-from-instance test-user :database db) +;; .. => INSERT INTO NODE (NODE_ID,TITLE) VALUES (1,'This is a test user') +;; .. <= T +;; .. => INSERT INTO USER (USER_ID,NICK) VALUES (1,'test-user') +;; .. <= T +1 + +CLSQL> (node-id test-user) +1 + +CLSQL> (title test-user) +"This is a test user" + +CLSQL> (nick test-user) +"test-user" + + Examples @@ -621,7 +730,7 @@ (birthday :type clsql:wall-time :initarg :birthday) (bd-utime :type clsql:universal-time :initarg :bd-utime) (hobby :db-kind :virtual :initarg :hobby :initform nil))) - + (def-view-class employee (person) ((emplid :db-kind :key @@ -853,11 +962,11 @@ Examples (list-tables) -=> ("FOO" "BAR") +=> ("FOO" "BAR") (drop-view-from-class 'foo) -=> +=> (list-tables) -=> ("BAR") +=> ("BAR") @@ -892,7 +1001,7 @@ Notes - None. + None. @@ -965,7 +1074,7 @@ (list-classes) => (#<clsql-sys::standard-db-class big> #<clsql-sys::standard-db-class employee-address> - #<clsql-sys::standard-db-class address> #<clsql-sys::standard-db-class company> + #<clsql-sys::standard-db-class address> #<clsql-sys::standard-db-class company> #<clsql-sys::standard-db-class employee>) (list-classes :test #'(lambda (c) (> (length (symbol-name (class-name c))) 3))) @@ -1005,10 +1114,10 @@ Notes - None. + None. - + diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index a9e3ccd..0d6471b 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -46,6 +46,9 @@ (key-slots :accessor key-slots :initform nil) + (normalisedp + :accessor normalisedp + :initform nil) (class-qualifier :accessor view-class-qualifier :initarg :qualifier @@ -109,10 +112,20 @@ base-table)) (class-name class))))) +(defmethod ordered-class-direct-slots ((self standard-db-class)) + (let ((direct-slot-names + (mapcar #'slot-definition-name (class-direct-slots self))) + (ordered-direct-class-slots '())) + (dolist (slot (ordered-class-slots self)) + (let ((slot-name (slot-definition-name slot))) + (when (find slot-name direct-slot-names) + (push slot ordered-direct-class-slots)))) + (nreverse ordered-direct-class-slots))) + (defmethod initialize-instance :around ((class standard-db-class) &rest all-keys &key direct-superclasses base-table - qualifier + qualifier normalisedp &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) (vmc 'standard-db-class)) @@ -129,17 +142,19 @@ (remove-keyword-arg all-keys :direct-superclasses))) (call-next-method)) (set-view-table-slot class base-table) + (setf (normalisedp class) (car normalisedp)) (register-metaclass class (nth (1+ (position :direct-slots all-keys)) all-keys)))) (defmethod reinitialize-instance :around ((class standard-db-class) &rest all-keys - &key base-table + &key base-table normalisedp direct-superclasses qualifier &allow-other-keys) (let ((root-class (find-class 'standard-db-object nil)) (vmc 'standard-db-class)) (set-view-table-slot class base-table) + (setf (normalisedp class) (car normalisedp)) (setf (view-class-qualifier class) (car qualifier)) (if (and root-class (not (equal class root-class))) @@ -194,14 +209,18 @@ (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) - (ordered-class-slots class))))) + (if (normalisedp class) + (ordered-class-direct-slots class) + (ordered-class-slots class)))))) #+(or sbcl allegro) (defmethod finalize-inheritance :after ((class standard-db-class)) (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) - (ordered-class-slots class)))) + (if (normalisedp class) + (ordered-class-direct-slots class) + (ordered-class-slots class))))) ;; return the deepest view-class ancestor for a given view class diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp index eae4f0e..2a81f8a 100644 --- a/sql/ooddl.lisp +++ b/sql/ooddl.lisp @@ -17,7 +17,7 @@ (defclass standard-db-object () ((view-database :initform nil :initarg :view-database :reader view-database - :db-kind :virtual)) + :db-kind :virtual)) (:metaclass standard-db-class) (:documentation "Superclass for all CLSQL View Classes.")) @@ -38,13 +38,23 @@ (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))) - (when (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)))))) + (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 (normalisedp 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-normalised-slot class instance slot-object)) + (setf (slot-value instance slot-name) nil))))))) (call-next-method)) (defmethod (setf slot-value-using-class) (new-value (class standard-db-class) @@ -54,7 +64,7 @@ (slot-object (%svuc-slot-object slot-def class)) (slot-kind (view-class-slot-db-kind slot-object))) (prog1 - (call-next-method) + (call-next-method) (when (and *db-auto-sync* (not *db-initializing*) (not *db-deserializing*) @@ -62,7 +72,7 @@ (update-record-from-slot instance slot-name))))) (defmethod initialize-instance ((object standard-db-object) - &rest all-keys &key &allow-other-keys) + &rest all-keys &key &allow-other-keys) (declare (ignore all-keys)) (let ((*db-initializing* t)) (call-next-method) @@ -81,26 +91,36 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." (let ((tclass (find-class view-class-name))) (if tclass - (let ((*default-database* database)) + (let ((*default-database* database) + (pclass (car (class-direct-superclasses tclass)))) + (when (and (normalisedp tclass) (not (table-exists-p (view-table pclass)))) + (create-view-from-class (class-name pclass) + :database database :transactions transactions)) (%install-class tclass database :transactions transactions)) (error "Class ~s not found." view-class-name))) (values)) + (defmethod %install-class ((self standard-db-class) database &key (transactions t)) - (let ((schemadef '())) - (dolist (slotdef (ordered-class-slots self)) + (let ((schemadef '()) + (ordered-slots (if (normalisedp self) + (ordered-class-direct-slots self) + (ordered-class-slots self)))) + (dolist (slotdef ordered-slots) (let ((res (database-generate-column-definition (class-name self) slotdef database))) (when res (push res schemadef)))) - (unless schemadef - (error "Class ~s has no :base slots" self)) - (create-table (sql-expression :table (view-table self)) (nreverse schemadef) - :database database - :transactions transactions - :constraints (database-pkey-constraint self database)) - (push self (database-view-classes database))) + (if (not schemadef) + (unless (normalisedp self) + (error "Class ~s has no :base slots" self)) + (progn + (create-table (sql-expression :table (view-table self)) (nreverse schemadef) + :database database + :transactions transactions + :constraints (database-pkey-constraint self database)) + (push self (database-view-classes database))))) t) (defmethod database-pkey-constraint ((class standard-db-class) database) @@ -133,7 +153,7 @@ in DATABASE which defaults to *DEFAULT-DATABASE*." ;; (defun drop-view-from-class (view-class-name &key (database *default-database*) - (owner nil)) + (owner nil)) "Removes a table defined by the View Class VIEW-CLASS-NAME from DATABASE which defaults to *DEFAULT-DATABASE*." (let ((tclass (find-class view-class-name))) @@ -144,8 +164,8 @@ DATABASE which defaults to *DEFAULT-DATABASE*." (values)) (defun %uninstall-class (self &key - (database *default-database*) - (owner nil)) + (database *default-database*) + (owner nil)) (drop-table (sql-expression :table (view-table self)) :if-does-not-exist :ignore :database database @@ -213,12 +233,12 @@ defaults to NIL. The :db-constraints slot option is a string representing an SQL table constraint expression or a list of such strings." `(progn - (defclass ,class ,supers ,slots - ,@(if (find :metaclass `,cl-options :key #'car) - `,cl-options - (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) - (finalize-inheritance (find-class ',class)) - (find-class ',class))) + (defclass ,class ,supers ,slots + ,@(if (find :metaclass `,cl-options :key #'car) + `,cl-options + (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) + (finalize-inheritance (find-class ',class)) + (find-class ',class))) (defun keyslots-for-class (class) (slot-value class 'key-slots)) diff --git a/sql/oodml.lisp b/sql/oodml.lisp index f797be0..9910ab4 100644 --- a/sql/oodml.lisp +++ b/sql/oodml.lisp @@ -15,8 +15,9 @@ (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 @@ -26,7 +27,7 @@ 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) @@ -39,22 +40,33 @@ (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 (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))) ;; ;; 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 (normalisedp 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 @@ -153,35 +165,46 @@ ;; (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)) + (view-class (class-of obj))) + (when (normalisedp view-class) + ;; If it's normalised, 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 (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 :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*)) @@ -211,8 +234,10 @@ (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 (or database (view-database obj) *default-database*)) + (pk nil)) (labels ((slot-storedp (slot) (and (member (view-class-slot-db-kind slot) '(:base :key)) (slot-boundp obj (slot-definition-name slot)))) @@ -221,25 +246,53 @@ (check-slot-type slot value) (list (sql-expression :attribute (view-class-slot-column slot)) (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))) (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)) + (pclass (car (class-direct-superclasses view-class)))) + (when (normalisedp 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))) + (let* ((slots (remove-if-not #'slot-storedp + (if (normalisedp view-class) + (ordered-class-direct-slots view-class) + (ordered-class-slots view-class)))) + (record-values (mapcar #'slot-value-list slots))) + (cond ((and (not (normalisedp view-class)) + (not record-values)) + (error "No settable slots.")) + ((and (normalisedp view-class) + (not record-values)) + nil) + ((view-database obj) + (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 (slot-definition-name pk-slot)))))) + (t + (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))))))) + pk)) (defmethod delete-instance-records ((instance standard-db-object)) (let ((vt (sql-expression :table (view-table (class-of instance)))) @@ -253,33 +306,54 @@ (signal-no-database-error vd)))) (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 (normalisedp 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 (or (view-database 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 + (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 (normalisedp view-class) + ;; If it's normalised, 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 (or (view-database 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 + (get-slot-values-from-view instance (list slot-def) (car res)))))) (defmethod update-slot-with-null ((object standard-db-object) slotname @@ -289,17 +363,17 @@ (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 (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)))) (defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*)) (declare (ignore database)) @@ -317,7 +391,7 @@ (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." @@ -425,12 +499,12 @@ (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)) @@ -453,11 +527,11 @@ (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)) @@ -665,25 +739,25 @@ 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 (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)))))))) ;;; Remote Joins @@ -693,8 +767,8 @@ 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 @@ -716,13 +790,13 @@ maximum of MAX-LEN instances updated in each query." (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)) @@ -732,12 +806,12 @@ maximum of MAX-LEN instances updated in each query." (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))) @@ -745,15 +819,15 @@ maximum of MAX-LEN instances updated in each query." ((>= 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))) @@ -798,44 +872,89 @@ maximum of MAX-LEN instances updated in each query." ((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-normalised-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 + (view-class-slot-column + (slotdef-for-slot-with-class fk sc)) + :table (view-table sc))) + (t fk)) + (typecase hk + (symbol + (slot-value object hk)) + (t hk))))) + + ;; Caching nil in next select, because in normalised 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 (view-database object)))) + (slot-name (slot-definition-name slot-def))) + + ;; If current class is normalised and wanted slot is not + ;; a direct member, recurse up + (if (and (normalisedp 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-normalised-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 + (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)))))) ;; FIXME: add retrieval immediate for efficiency ;; For example, for (select 'employee-address) in test suite => @@ -858,7 +977,11 @@ maximum of MAX-LEN instances updated in each query." (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 (normalisedp jo-class) + (class-direct-slots jo-class) + (class-slots jo-class))) (pos-list (remove-if #'null (mapcar #'(lambda (s) @@ -876,12 +999,14 @@ maximum of MAX-LEN instances updated in each query." 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) @@ -896,15 +1021,15 @@ maximum of MAX-LEN instances updated in each query." sclasses immediate-join-classes sels immediate-joins instances))) (if (and flatp (= (length sclasses) 1)) (car objects) - objects)))) + objects)))) (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) "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)) @@ -957,39 +1082,39 @@ maximum of MAX-LEN instances updated in each query." (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))))) + (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)))))) + (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)))))) + (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))))) + ((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) @@ -1007,14 +1132,14 @@ maximum of MAX-LEN instances updated in each query." (res nil)) ((= i instances-to-add) res) (push (make-list (length sclasses) :initial-element nil) res))) - instances)) + 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))) + instance))) rows perhaps-extended-instances))) objects)))) @@ -1025,7 +1150,7 @@ maximum of MAX-LEN instances updated in each query." 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 @@ -1069,89 +1194,89 @@ 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." - (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))) + (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 - ((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 - (mapcar #'(lambda (attrib) - (if (typep attrib 'sql-ident-attribute) - (let ((type (slot-value attrib 'type))) - (if 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)))))))) + (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))) + + (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 + (mapcar #'(lambda (attrib) + (if (typep attrib 'sql-ident-attribute) + (let ((type (slot-value attrib 'type))) + (if 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)))))))) (defun compute-records-cache-key (targets qualifiers) (list targets diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp index 0d98c0f..e3dc1b2 100644 --- a/tests/test-fddl.lisp +++ b/tests/test-fddl.lisp @@ -27,7 +27,8 @@ (sort (mapcar #'string-downcase (clsql:list-tables :owner *test-database-user*)) #'string<) - ("addr" "big" "company" "ea_join" "employee" "type_bigint" "type_table")) + ("addr" "big" "company" "ea_join" "employee" "node" "setting" + "subloc" "theme" "type_bigint" "type_table" "user")) ;; create a table, test for its existence, drop it and test again (deftest :fddl/table/2 diff --git a/tests/test-init.lisp b/tests/test-init.lisp index b0a902c..3307198 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -3,7 +3,6 @@ ;;;; File: test-init.lisp ;;;; Authors: Marcus Pearce , Kevin Rosenberg ;;;; Created: 30/03/2004 -;;;; Updated: $Id$ ;;;; ;;;; Initialisation utilities for running regression tests on CLSQL. ;;;; @@ -190,6 +189,48 @@ ((i :type integer :initarg :i) (bi :type bigint :initarg :bi))) +;; classes for testing the normalisedp stuff +(def-view-class node () + ((node-id :accessor node-id :initarg :node-id + :type integer :db-kind :key + :db-constraints (:not-null :auto-increment)) + (title :accessor title :initarg :title :type (varchar 240)) + (createtime :accessor createtime :initarg :createtime :type wall-time + :db-constraints (:not-null) :initform (get-time)) + (modifiedtime :accessor modifiedtime :initarg :modifiedtime :type wall-time + :initform (make-time :year 1900 :month 1 :day 1)))) + +(def-view-class setting (node) + ((setting-id :accessor setting-id :initarg :setting-id + :type integer :db-kind :key :db-constraints (:not-null)) + (vars :accessor vars :initarg :vars :type (varchar 240))) + (:normalisedp t)) + +(def-view-class user (node) + ((user-id :accessor user-id :initarg :user-id + :type integer :db-kind :key :db-constraints (:not-null)) + (nick :accessor nick :initarg :nick :type (varchar 64))) + (:normalisedp t)) + +(def-view-class theme (setting) + ((theme-id :accessor theme-id :initarg :theme-id + :type integer :db-kind :key :db-constraints (:not-null)) + (doc :accessor doc :initarg :doc :type (varchar 240))) + (:normalisedp t)) + +;; A class that uses only a superclass db table +(def-view-class location (node) + () + (:base-table node) + (:normalisedp t)) + +(def-view-class subloc (location) + ((subloc-id :accessor subloc-id :initarg :subloc-id + :type integer :db-kind :key :db-constraints (:not-null)) + (loc :accessor loc :initarg :loc :type (varchar 64))) + (:normalisedp t)) + + (defun test-connect-to-database (db-type spec) (when (clsql-sys:db-backend-has-create/destroy-db? db-type) (ignore-errors (destroy-database spec :database-type db-type)) @@ -233,9 +274,25 @@ (defparameter employee-address3 nil) (defparameter employee-address4 nil) (defparameter employee-address5 nil) +(defparameter basenode nil) +(defparameter derivednode1 nil) +(defparameter derivednode2 nil) +(defparameter node nil) +(defparameter setting1 nil) +(defparameter setting2 nil) +(defparameter user1 nil) +(defparameter user2 nil) +(defparameter theme1 nil) +(defparameter theme2 nil) +(defparameter loc1 nil) +(defparameter loc2 nil) +(defparameter subloc1 nil) +(defparameter subloc2 nil) + (defun test-initialise-database () (test-basic-initialize) +;; (start-sql-recording :type :both) (let ((*backend-warning-behavior* (if (member *test-database-type* '(:postgresql :postgresql-socket)) :ignore @@ -244,7 +301,13 @@ (clsql:create-view-from-class 'company) (clsql:create-view-from-class 'address) (clsql:create-view-from-class 'employee-address) - (clsql:create-view-from-class 'big)) + (clsql:create-view-from-class 'big) + (clsql:create-view-from-class 'node) + (clsql:create-view-from-class 'setting) + (clsql:create-view-from-class 'user) + (clsql:create-view-from-class 'theme) + (clsql:create-view-from-class 'location) + (clsql:create-view-from-class 'subloc)) (setq *test-start-utime* (get-universal-time)) (let* ((*db-auto-sync* t) @@ -399,7 +462,39 @@ :verified nil) employee-address5 (make-instance 'employee-address :emplid 3 - :addressid 2)) + :addressid 2) + node (make-instance 'node + :title "Bare node") + setting1 (make-instance 'setting + :title "Setting1" + :vars "var 1") + setting2 (make-instance 'setting + :title "Setting2" + :vars "var 2") + user1 (make-instance 'user + :title "user-1" + :nick "first user") + user2 (make-instance 'user + :title "user-2" + :nick "second user") + theme1 (make-instance 'theme + :title "theme-1" + :vars "empty" + :doc "first theme") + theme2 (make-instance 'theme + :title "theme-2" + :doc "second theme") + loc1 (make-instance 'location + :title "location-1") + loc2 (make-instance 'location + :title "location-2") + subloc1 (make-instance 'subloc + :title "subloc-1" + :loc "a subloc") + subloc2 (make-instance 'subloc + :title "subloc-2" + :loc "second subloc")) + (let ((max (expt 2 60))) (dotimes (i 555) diff --git a/tests/test-ooddl.lisp b/tests/test-ooddl.lisp index bd54611..d7a1933 100644 --- a/tests/test-ooddl.lisp +++ b/tests/test-ooddl.lisp @@ -42,10 +42,35 @@ (every #'(lambda (slotd) (typep slotd 'clsql-sys::view-class-effective-slot-definition)) (clsql-sys::class-slots (find-class 'employee))) + (every #'(lambda (slotd) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'setting))) + (every #'(lambda (slotd) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'theme))) + (every #'(lambda (slotd) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'node))) (every #'(lambda (slotd) (typep slotd 'clsql-sys::view-class-effective-slot-definition)) (clsql-sys::class-slots (find-class 'company)))) - t t t) + t t t t t t) + +;; Ensure classes are correctly marked normalised or not, default not +;(deftest :ooddl/metaclass/3 +; (values +; (clsql-sys::normalisedp derivednode1) +; (clsql-sys::normalisedp basenode) +; (clsql-sys::normalisedp company1) +; (clsql-sys::normalisedp employee3) +; (clsql-sys::normalisedp derivednode-sc-2)) +; t nil nil nil t) + +;(deftest :ooddl/metaclass/3 +; (values +; (normalisedp (find-class 'baseclass)) +; (normalisedp (find-class 'normderivedclass))) +; nil t) (deftest :ooddl/join/1 (mapcar #'(lambda (e) (slot-value e 'ecompanyid)) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp index a5fefe0..6dd7617 100644 --- a/tests/test-oodml.lisp +++ b/tests/test-oodml.lisp @@ -3,7 +3,6 @@ ;;;; File: test-oodml.lisp ;;;; Author: Marcus Pearce ;;;; Created: 01/04/2004 -;;;; Updated: $Id$ ;;;; ;;;; Tests for the CLSQL Object Oriented Data Definition Language ;;;; (OODML). @@ -115,6 +114,82 @@ (1 2 3 4 5 6 7 8 9 10) (10 9 8 7 6 5 4 3 2 1)) + ;; test retrieval of node, derived nodes etc + (deftest :oodml/select/12 + (length (clsql:select 'node :where [node-id] :flatp t :caching nil)) + 11) + + (deftest :oodml/select/13 + (let ((a (car (clsql:select 'node :where [= 1 [node-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'title))) + 1 "Bare node") + + (deftest :oodml/select/14 + (length (clsql:select 'setting :where [setting-id] :flatp t :caching nil)) + 4) + + (deftest :oodml/select/15 + (let ((a (car (clsql:select 'setting :where [= 3 [setting-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'setting-id) + (slot-value a 'title) + (slot-value a 'vars))) + 3 3 "Setting2" "var 2") + + (deftest :oodml/select/16 + (length (clsql:select 'user :where [user-id] :flatp t :caching nil)) + 2) + + (deftest :oodml/select/17 + (let ((a (car (clsql:select 'user :where [= 4 [user-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'user-id) + (slot-value a 'title) + (slot-value a 'nick))) + 4 4 "user-1" "first user") + + (deftest :oodml/select/18 + (length (clsql:select 'theme :where [theme-id] :flatp t :caching nil)) + 2) + + (deftest :oodml/select/19 + (let ((a (car (clsql:select 'theme :where [= 6 [theme-id]] :flatp t :caching nil)))) + (slot-value a 'theme-id)) + 6) + + (deftest :oodml/select/20 + (let ((a (car (clsql:select 'theme :where [= 7 [theme-id]] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'theme-id) + (slot-value a 'title) + (slot-value a 'vars) + (slot-value a 'doc) + )) + 7 7 "theme-2" + nil "second theme") + + ;; Some tests to check weird subclassed nodes (node without own table, or subclassed of same) + (deftest :oodml/select/21 + (let ((a (car (clsql:select 'location :where [= [title] "location-1"] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'title))) + 8 "location-1") + + (deftest :oodml/select/22 + (let ((a (car (clsql:select 'subloc :where [subloc-id] :flatp t :caching nil)))) + (values + (slot-value a 'node-id) + (slot-value a 'subloc-id) + (slot-value a 'title) + (slot-value a 'loc))) + 10 10 "subloc-1" "a subloc") + ;; test retrieval is deferred (deftest :oodm/retrieval/1 (every #'(lambda (e) (not (slot-boundp e 'company))) @@ -289,6 +364,296 @@ "Dimitriy Ivanovich: ivanovich@soviet.org" "Vladimir Lenin: lenin@soviet.org") + (deftest :oodml/update-records/4 + (values + (progn + (let ((base (car (clsql:select 'node + :where [= [slot-value 'node 'node-id] + 1] + :flatp t + :caching nil)))) + (with-output-to-string (out) + (format out "~a ~a" + (slot-value base 'node-id) + (slot-value base 'title))))) + (progn + (let ((base (car (clsql:select 'node + :where [= [slot-value 'node 'node-id] + 1] + :flatp t + :caching nil)))) + (setf (slot-value base 'title) "Altered title") + (clsql:update-records-from-instance base) + (with-output-to-string (out) + (format out "~a ~a" + (slot-value base 'node-id) + (slot-value base 'title))))) + (progn + (let ((base (car (clsql:select 'node + :where [= [slot-value 'node 'node-id] + 1] + :flatp t + :caching nil)))) + (setf (slot-value base 'title) "Bare node") + (clsql:update-records-from-instance base) + (with-output-to-string (out) + (format out "~a ~a" + (slot-value base 'node-id) + (slot-value base 'title)))))) + "1 Bare node" + "1 Altered title" + "1 Bare node") + + (deftest :oodml/update-records/5 + (values + (progn + (let ((node (car (clsql:select 'setting + :where [= [slot-value 'setting 'setting-id] + 3] + :flatp t + :caching nil)))) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (progn + (let ((node (car (clsql:select 'setting + :where [= [slot-value 'setting 'setting-id] + 3] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (progn + (let ((node (car (clsql:select 'setting + :where [= [slot-value 'setting 'setting-id] + 3] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "Setting2") + (setf (slot-value node 'vars) "var 2") + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars)))))) + "3 Setting2 var 2" + "3 Altered title Altered vars" + "3 Setting2 var 2") + + (deftest :oodml/update-records/6 + (values + (progn + (let ((node (car (clsql:select 'setting + :where [= [slot-value 'setting 'setting-id] + 7] + :flatp t + :caching nil)))) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (progn + (let ((node (car (clsql:select 'setting + :where [= [slot-value 'setting 'setting-id] + 7] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) "Altered vars") + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (progn + (let ((node (car (clsql:select 'setting + :where [= [slot-value 'setting 'setting-id] + 7] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "theme-2") + (setf (slot-value node 'vars) nil) + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars)))))) + "7 theme-2 NIL" + "7 Altered title Altered vars" + "7 theme-2 NIL") + + (deftest :oodml/update-records/7 + (values + (progn + (let ((node (car (clsql:select 'user + :where [= [slot-value 'user 'user-id] + 5] + :flatp t + :caching nil)))) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'user-id) + (slot-value node 'title) + (slot-value node 'nick))))) + (progn + (let ((node (car (clsql:select 'user + :where [= [slot-value 'user 'user-id] + 5] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'nick) "Altered nick") + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'user-id) + (slot-value node 'title) + (slot-value node 'nick))))) + (progn + (let ((node (car (clsql:select 'user + :where [= [slot-value 'user 'user-id] + 5] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "user-2") + (setf (slot-value node 'nick) "second user") + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'user-id) + (slot-value node 'title) + (slot-value node 'nick)))))) + "5 user-2 second user" + "5 Altered title Altered nick" + "5 user-2 second user") + + (deftest :oodml/update-records/8 + (values + (progn + (let ((node (car (clsql:select 'theme + :where [= [slot-value 'theme 'theme-id] + 6] + :flatp t + :caching nil)))) + (with-output-to-string (out) + (format out "~a ~a ~a ~a ~a ~a" + (slot-value node 'node-id) + (slot-value node 'setting-id) + (slot-value node 'theme-id) + (slot-value node 'title) + (slot-value node 'vars) + (slot-value node 'doc))))) + (progn + (let ((node (car (clsql:select 'setting + :where [= [slot-value 'setting 'setting-id] + 6] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "Altered title") + (setf (slot-value node 'vars) nil) + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value node 'setting-id) + (slot-value node 'title) + (slot-value node 'vars))))) + (progn + (let ((node (car (clsql:select 'theme + :where [= [slot-value 'theme 'theme-id] + 6] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "Altered title again") + (setf (slot-value node 'doc) "altered doc") + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a ~a ~a ~a" + (slot-value node 'node-id) + (slot-value node 'setting-id) + (slot-value node 'theme-id) + (slot-value node 'title) + (slot-value node 'vars) + (slot-value node 'doc))))) + (progn + (let ((node (car (clsql:select 'theme + :where [= [slot-value 'theme 'theme-id] + 6] + :flatp t + :caching nil)))) + (setf (slot-value node 'title) "theme-1") + (setf (slot-value node 'vars) "empty") + (setf (slot-value node 'doc) "first theme") + (clsql:update-records-from-instance node) + (with-output-to-string (out) + (format out "~a ~a ~a ~a ~a ~a" + (slot-value node 'node-id) + (slot-value node 'setting-id) + (slot-value node 'theme-id) + (slot-value node 'title) + (slot-value node 'vars) + (slot-value node 'doc)))))) + "6 6 6 theme-1 empty first theme" + "6 Altered title NIL" + "6 6 6 Altered title again NIL altered doc" + "6 6 6 theme-1 empty first theme") + + (deftest :oodml/update-records/9 + (values + (progn + (let ((sl (car (clsql:select 'subloc + :where [= [slot-value 'subloc 'subloc-id] + 10] + :flatp t + :caching nil)))) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value sl 'subloc-id) + (slot-value sl 'title) + (slot-value sl 'loc))))) + (progn + (let ((sl (car (clsql:select 'subloc + :where [= [slot-value 'subloc 'subloc-id] + 10] + :flatp t + :caching nil)))) + (setf (slot-value sl 'title) "Altered subloc title") + (setf (slot-value sl 'loc) "Altered loc") + (clsql:update-records-from-instance sl) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value sl 'subloc-id) + (slot-value sl 'title) + (slot-value sl 'loc))))) + (progn + (let ((sl (car (clsql:select 'subloc + :where [= [slot-value 'subloc 'subloc-id] + 10] + :flatp t + :caching nil)))) + (setf (slot-value sl 'title) "subloc-1") + (setf (slot-value sl 'loc) "a subloc") + (clsql:update-records-from-instance sl) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value sl 'subloc-id) + (slot-value sl 'title) + (slot-value sl 'loc)))))) + "10 subloc-1 a subloc" + "10 Altered subloc title Altered loc" + "10 subloc-1 a subloc") + ;; tests update-instance-from-records (deftest :oodml/update-instance/1 (values @@ -346,6 +711,174 @@ (slot-value employee1 'email))) "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") + ;; tests normalisedp update-instance-from-records + (deftest :oodml/update-instance/3 + (values + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (slot-value theme2 'theme-id) + (slot-value theme2 'title) + (slot-value theme2 'vars) + (slot-value theme2 'doc))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 7]) + (clsql:update-records [setting] :av-pairs '(([vars] "Altered vars")) + :where [= [setting-id] 7]) + (clsql:update-records [theme] :av-pairs '(([doc] "Altered doc")) + :where [= [theme-id] 7]) + (clsql:update-instance-from-records theme2) + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (slot-value theme2 'theme-id) + (slot-value theme2 'title) + (slot-value theme2 'vars) + (slot-value theme2 'doc)))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "theme-2")) + :where [= [node-id] 7]) + (clsql:update-records [setting] :av-pairs '(([vars] nil)) + :where [= [setting-id] 7]) + (clsql:update-records [theme] :av-pairs '(([doc] "second theme")) + :where [= [theme-id] 7]) + (clsql:update-instance-from-records theme2) + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (slot-value theme2 'theme-id) + (slot-value theme2 'title) + (slot-value theme2 'vars) + (slot-value theme2 'doc))))) + "7 theme-2 NIL second theme" + "7 Altered title Altered vars Altered doc" + "7 theme-2 NIL second theme") + + (deftest :oodml/update-instance/4 + (values + (progn + (setf loc2 (car (clsql:select 'location + :where [= [node-id] 9] + :flatp t :caching nil))) + (with-output-to-string (out) + (format out "~a ~a" + (slot-value loc2 'node-id) + (slot-value loc2 'title)))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 9]) + (clsql:update-instance-from-records loc2) + (with-output-to-string (out) + (format out "~a ~a" + (slot-value loc2 'node-id) + (slot-value loc2 'title)))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "location-2")) + :where [= [node-id] 9]) + (clsql:update-instance-from-records loc2) + (with-output-to-string (out) + (format out "~a ~a" + (slot-value loc2 'node-id) + (slot-value loc2 'title))))) + "9 location-2" + "9 Altered title" + "9 location-2") + + (deftest :oodml/update-instance/5 + (values + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value subloc2 'subloc-id) + (slot-value subloc2 'title) + (slot-value subloc2 'loc))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "Altered title")) + :where [= [node-id] 11]) + (clsql:update-records [subloc] :av-pairs '(([loc] "Altered loc")) + :where [= [subloc-id] 11]) + (clsql:update-instance-from-records subloc2) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value subloc2 'subloc-id) + (slot-value subloc2 'title) + (slot-value subloc2 'loc)))) + (progn + (clsql:update-records [node] :av-pairs '(([title] "subloc-2")) + :where [= [node-id] 11]) + (clsql:update-records [subloc] :av-pairs '(([loc] "second subloc")) + :where [= [subloc-id] 11]) + (clsql:update-instance-from-records subloc2) + (with-output-to-string (out) + (format out "~a ~a ~a" + (slot-value subloc2 'subloc-id) + (slot-value subloc2 'title) + (slot-value subloc2 'loc))))) + "11 subloc-2 second subloc" + "11 Altered title Altered loc" + "11 subloc-2 second subloc") + + ;; tests update-slot-from-record with normalisedp stuff + (deftest :oodml/update-instance/6 + (values + (slot-value theme1 'doc) + (slot-value theme1 'vars) + (progn + (clsql:update-records [theme] + :av-pairs '(([doc] "altered doc")) + :where [= [theme-id] 6]) + (clsql:update-slot-from-record theme1 'doc) + (slot-value theme1 'doc)) + (progn + (clsql:update-records [setting] + :av-pairs '(([vars] "altered vars")) + :where [= [setting-id] 6]) + (clsql:update-slot-from-record theme1 'vars) + (slot-value theme1 'vars)) + (progn + (clsql:update-records [theme] + :av-pairs '(([doc] "first theme")) + :where [= [theme-id] 6]) + (clsql:update-slot-from-record theme1 'doc) + (slot-value theme1 'doc)) + (progn + (clsql:update-records [setting] + :av-pairs '(([vars] "empty")) + :where [= [setting-id] 6]) + (clsql:update-slot-from-record theme1 'vars) + (slot-value theme1 'vars))) + "first theme" "empty" + "altered doc" "altered vars" + "first theme" "empty") + + (deftest :oodml/update-instance/7 + (values + (slot-value loc2 'title) + (slot-value subloc2 'loc) + (progn + (clsql:update-records [node] + :av-pairs '(([title] "altered title")) + :where [= [node-id] 9]) + (clsql:update-slot-from-record loc2 'title) + (slot-value loc2 'title)) + (progn + (clsql:update-records [subloc] + :av-pairs '(([loc] "altered loc")) + :where [= [subloc-id] 11]) + (clsql:update-slot-from-record subloc2 'loc) + (slot-value subloc2 'loc)) + (progn + (clsql:update-records [node] + :av-pairs '(([title] "location-2")) + :where [= [node-id] 9]) + (clsql:update-slot-from-record loc2 'title) + (slot-value loc2 'title)) + (progn + (clsql:update-records [subloc] + :av-pairs '(([loc] "second subloc")) + :where [= [subloc-id] 11]) + (clsql:update-slot-from-record subloc2 'loc) + (slot-value subloc2 'loc))) + "location-2" "second subloc" + "altered title" "altered loc" + "location-2" "second subloc") (deftest :oodml/do-query/1 (let ((result '())) @@ -515,6 +1048,69 @@ (delete-records :from [employee] :where [= [emplid] 20])))) nil ("Bulgakov")) + (deftest :oodml/db-auto-sync/3 + (values + (progn + (make-instance 'theme :title "test-theme" :vars "test-vars" + :doc "test-doc") + (select [node-id] :from [node] :where [= [title] "test-theme"] + :flatp t :field-names nil)) + (let ((*db-auto-sync* t)) + (make-instance 'theme :title "test-theme" :vars "test-vars" + :doc "test-doc") + (prog1 (select [title] :from [node] :where [= [title] "test-theme"] + :flatp t :field-names nil) + (delete-records :from [node] :where [= [title] "test-theme"]) + (delete-records :from [setting] :where [= [vars] "test-vars"]) + (delete-records :from [theme] :where [= [doc] "test-doc"])))) + nil ("test-theme")) + + (deftest :oodml/db-auto-sync/4 + (values + (let ((inst (make-instance 'theme + :title "test-theme" :vars "test-vars" + :doc "test-doc"))) + (setf (slot-value inst 'title) "alternate-test-theme") + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (select [title] :from [node] + :where [= [title] "test-theme"] + :flatp t :field-names nil) + (select [vars] :from [setting] + :where [= [vars] "test-vars"] + :flatp t :field-names nil) + (select [doc] :from [theme] + :where [= [doc] "test-doc"] + :flatp t :field-names nil) + (select [title] :from [node] + :where [= [title] "alternate-test-theme"] + :flatp t :field-names nil)))) + (let* ((*db-auto-sync* t) + (inst (make-instance 'theme + :title "test-theme" :vars "test-vars" + :doc "test-doc"))) + (setf (slot-value inst 'title) "alternate-test-theme") + (prog1 + (with-output-to-string (out) + (format out "~a ~a ~a ~a" + (select [title] :from [node] + :where [= [title] "test-theme"] + :flatp t :field-names nil) + (select [vars] :from [setting] + :where [= [vars] "test-vars"] + :flatp t :field-names nil) + (select [doc] :from [theme] + :where [= [doc] "test-doc"] + :flatp t :field-names nil) + (select [title] :from [node] + :where [= [title] "alternate-test-theme"] + :flatp t :field-names nil))) + (delete-records :from [node] :where [= [title] "alternate-test-theme"]) + (delete-records :from [setting] :where [= [vars] "test-vars"]) + (delete-records :from [theme] :where [= [doc] "test-doc"])))) + "NIL NIL NIL NIL" + "NIL (test-vars) (test-doc) (alternate-test-theme)") + (deftest :oodml/setf-slot-value/1 (let* ((*db-auto-sync* t) (instance (make-instance 'employee :emplid 20 :groupid 1))) @@ -623,9 +1219,7 @@ 1)) (setf (slot-value emp1 'height) height) (clsql:update-record-from-slot emp1 'height))) - t) - - )) + t))) -- 2.34.1