configure-stamp
build-stamp
+*~
+ 10 Dec 2009 Kevin Rosenberg <kevin@rosenberg.net>
+ Large patch from Thijs Oppermann <thijso+clsql@gmail.com> 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 <kevin@rosenberg.net>
* sql/time.lisp: Patch from Oleg Tihonov to SYNTAX-PARSE-ISO-8601
to properly parse fractions of seconds.
<symbol>:base-table</symbol> option specifies what the table name
for the view class will be when it is mapped into the database.
</para>
+
+<para>
+ Another class option is <symbol>:normalisedp</symbol>, 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 <link linkend="def-view-class">
+ <function>def-view-class</function></link>.
+</para>
</sect1>
<sect1 id="csql-rel">
save those till we get to the many-to-many relation examples.
</para>
+
+ <title>Object Oriented Class Relations</title>
+
+<para>
+&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 <symbol>:normalisedp</symbol>
+can be used to disable the default behaviour and have &clsql;
+normalise the database schemas of inherited classes.
+</para>
+
+<para>
+See <link linkend="def-view-class"><function>def-view-class</function></link>
+for more information.
+</para>
+
</sect1>
<sect1 id="csql-creat">
%myents;
]>
-<!-- Object Oriented Data Definition Language -->
-<reference id="ref-ooddl">
- <title>Object Oriented Data Definition Language (OODDL)</title>
+<!-- Object Oriented Data Definition Language -->
+<reference id="ref-ooddl">
+ <title>Object Oriented Data Definition Language (OODDL)</title>
<partintro>
<para>
The Object Oriented Data Definition Language (OODDL) provides
(CLOS) objects. SQL tables are mapped to CLOS objects with the
SQL columns being mapped to slots of the CLOS object.
</para>
- <para>
+ <para>
The mapping between SQL tables and CLOS objects is defined with
the macro <link
linkend="def-view-class"><function>def-view-class</function></link>. SQL
<refsect1>
<title>Slots</title>
<para>
- <simplelist>
+ <simplelist>
<member>slot VIEW-DATABASE is of type (OR NULL DATABASE)
which stores the associated database for the
instance.</member>
- </simplelist>
+ </simplelist>
</para>
</refsect1>
</refentry>
<title>Value Type</title>
<para>
Fixnum
- </para>
+ </para>
</refsect1>
<refsect1>
<title>Initial Value</title>
<para><parameter>255</parameter></para>
</refsect1>
<refsect1>
- <title>Description</title>
+ <title>Description</title>
<para>
If a slot of a class defined by
<function>def-view-class</function> is of the type
(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
</screen>
<para>
(def-view-class foo () ((a :type (string 80))))
=> #<Standard-Db-Class FOO {4807F7CD}>
(create-view-from-class 'foo)
-=>
+=>
(list-tables)
=> ("FOO")
</screen>
wide. [not supported by all database backends]
</member>
<member>
- <parameter>bigint</parameter> - An integer column
+ <parameter>bigint</parameter> - An integer column
64-bits wide. [not supported by all database backends]
</member>
<member>
</member>
<member>
<parameter>keyword</parameter> - stores a keyword
- </member>
+ </member>
<member><parameter>symbol</parameter> - stores a symbol</member>
<member>
<parameter>list</parameter> - stores a list by writing
similarly to <parameter>list</parameter></member>
</simplelist>
</para>
-
+
</listitem>
<listitem>
<para>
are converted to underscore characters.
</para>
</listitem>
+ <listitem>
+ <para>
+ <parameter>:normalisedp</parameter> - 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.
+ </para>
+ </listitem>
</itemizedlist>
</para>
</refsect1>
this class.
</para>
+ <title>Normalised inheritance schemas</title>
+ <para>
+ Specifying that <symbol>:normalisedp</symbol> is <symbol>T</symbol>
+ tells &clsql; to normalise the database schema for inheritance.
+ What this means is shown in the examples below.
+ </para>
+
+ <para>
+ With <symbol>:normalisedp</symbol> equal to <symbol>NIL</symbol>
+ (the default) the class inheritance would result in the following:
+ </para>
+ <screen>
+(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 | |
++---------+--------------+------+-----+---------+-------+
+ </screen>
+
+ <para>
+ Using <symbol>:normalisedp</symbol> <symbol>T</symbol>, both
+ view-classes need a primary key to join them on:
+ </para>
+ <screen>
+(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 | |
++---------+-------------+------+-----+---------+-------+
+ </screen>
+
+ <para>
+ 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:
+ </para>
+ <screen>
+CLSQL> (setq test-user (make-instance 'user :node-id 1 :nick "test-user"
+ :title "This is a test user"))
+#<USER {1003B392E1}>
+
+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"
+ </screen>
+
</refsect1>
<refsect1>
<title>Examples</title>
(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
<title>Examples</title>
<screen>
(list-tables)
-=> ("FOO" "BAR")
+=> ("FOO" "BAR")
(drop-view-from-class 'foo)
-=>
+=>
(list-tables)
-=> ("BAR")
+=> ("BAR")
</screen>
</refsect1>
<refsect1>
<refsect1>
<title>Notes</title>
<para>
- None.
+ None.
</para>
</refsect1>
</refentry>
<screen>
(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)))
<refsect1>
<title>Notes</title>
<para>
- None.
+ None.
</para>
</refsect1>
</refentry>
-</reference>
+</reference>
(key-slots
:accessor key-slots
:initform nil)
+ (normalisedp
+ :accessor normalisedp
+ :initform nil)
(class-qualifier
:accessor view-class-qualifier
:initarg :qualifier
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))
(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)))
(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
(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."))
(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)
(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*)
(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)
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)
;;
(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)))
(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
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))
(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
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 (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
;;
(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*))
(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))))
(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))))
(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
(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))
(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))
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
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)))
((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 =>
(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)
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))))
(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))
(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)
(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))))
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
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
(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
;;;; File: test-init.lisp
;;;; Authors: Marcus Pearce <m.t.pearce@city.ac.uk>, Kevin Rosenberg
;;;; Created: 30/03/2004
-;;;; Updated: $Id$
;;;;
;;;; Initialisation utilities for running regression tests on CLSQL.
;;;;
((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))
(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
(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)
: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)
(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))
;;;; File: test-oodml.lisp
;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
;;;; Created: 01/04/2004
-;;;; Updated: $Id$
;;;;
;;;; Tests for the CLSQL Object Oriented Data Definition Language
;;;; (OODML).
(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)))
"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
(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 '()))
(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)))
1))
(setf (slot-value emp1 'height) height)
(clsql:update-record-from-slot emp1 'height)))
- t)
-
- ))
+ t)))
projects / clsql.git / commitdiff