+29 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net>
+ * sql/oodml.lisp: Fix for UPDATE-RECORD-FROM-SLOTS for normalized
+ view classes
+
+28 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net>
+ * Version 4.3.2
+ * Change "normalise" from British spelling for consistency with
+ other American spellings in CLSQL.
+
+28 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net>
+ * db-mysql/Makefile: Add directory for Fedora 11/12 on 64-bit
+ platform (Thanks to Michael Pheasant) and remove a 32-bit directory
+
+28 Jan 2009 Kevin Rosenberg <kevin@rosenberg.net>
+ * Version 4.3.1
+ * sql/utils.lisp: Ensure Lispworks 6 lock is created in sharing mode
+
20 Jan 2009 Nathan Bird <nathan@acceleration.net>
* Version 4.3.0
* Rewrite tests to use datasets
+clsql_mysql64.so
clsql_mysql.so
.mysql.so
*.fasl*
all: $(shared_lib)
CFLAGS=-I /usr/local/include/mysql -I /usr/include/mysql -I /sw/include/mysql -I /opt/local/include/mysql -I /opt/local/include/mysql5/mysql -I /usr/local/mysql/include
-LDFLAGS=-L/usr/local/lib64/mysql -L/usr/local/mysql/lib32 -L/usr/local/lib/mysql -L/usr/lib/mysql -L/sw/lib -L/opt/local/lib/mysql -L/opt/local/lib/mysql5/mysql -L/usr/local/mysql/lib -L/usr/lib/gcc/i686-pc-cygwin/3.4.4 -lmysqlclient -lz -lc
+LDFLAGS=-L/usr/local/lib64/mysql -L/usr/local/lib/mysql -L/usr/lib64/mysql -L/usr/lib/mysql -L/sw/lib -L/opt/local/lib/mysql -L/opt/local/lib/mysql5/mysql -L/usr/local/mysql/lib -L/usr/lib/gcc/i686-pc-cygwin/3.4.4 -lmysqlclient -lz -lc
CFLAGS32=-I /usr/local/include/mysql -I /usr/include/mysql -I /sw/include/mysql -I /opt/local/include/mysql -I /opt/local/include/mysql5/mysql -I /usr/local/mysql/include -m32
LDFLAGS32=-L/lib32 -L/usr/lib32 -melf_i386 -lmysqlclient -lz -lc
+cl-sql (4.3.2-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Thu, 28 Jan 2010 18:36:06 -0700
+
+cl-sql (4.3.1-1) unstable; urgency=low
+
+ * New upstream
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Thu, 28 Jan 2010 15:10:11 -0700
+
cl-sql (4.3.0-1) unstable; urgency=low
* New upstream
</para>
<para>
- Another class option is <symbol>:normalisedp</symbol>, which signals
- &clsql; to use a normalised schema for the mapping from slots to
+ Another class option is <symbol>:normalizedp</symbol>, which signals
+ &clsql; to use a normalized 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
+ tells &clsql; to normalize 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>.
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>
+very much denormalized. The class option <symbol>:normalizedp</symbol>
can be used to disable the default behaviour and have &clsql;
-normalise the database schemas of inherited classes.
+normalize the database schemas of inherited classes.
</para>
<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,
+ <parameter>:normalizedp</parameter> - specifies whether
+ this class uses normalized inheritance from parent classes.
+ Defaults to nil, i.e. non-normalized 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.
this class.
</para>
- <title>Normalised inheritance schemas</title>
+ <title>Normalized inheritance schemas</title>
<para>
- Specifying that <symbol>:normalisedp</symbol> is <symbol>T</symbol>
- tells &clsql; to normalise the database schema for inheritance.
+ Specifying that <symbol>:normalizedp</symbol> is <symbol>T</symbol>
+ tells &clsql; to normalize 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>
+ With <symbol>:normalizedp</symbol> equal to <symbol>NIL</symbol>
(the default) the class inheritance would result in the following:
</para>
<screen>
</screen>
<para>
- Using <symbol>:normalisedp</symbol> <symbol>T</symbol>, both
+ Using <symbol>:normalizedp</symbol> <symbol>T</symbol>, both
view-classes need a primary key to join them on:
</para>
<screen>
((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))
+ (:normalizedp t))
SQL table USER:
+---------+-------------+------+-----+---------+-------+
<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
+ as one would expect. For example, with the above normalized
view-classes 'node and 'user, and SQL tracing turned on:
</para>
<screen>
(key-slots
:accessor key-slots
:initform nil)
- (normalisedp
- :accessor normalisedp
+ (normalizedp
+ :accessor normalizedp
:initform nil)
(class-qualifier
:accessor view-class-qualifier
base-table))
(class-name class)))))
+(defgeneric ordered-class-direct-slots (class))
(defmethod ordered-class-direct-slots ((self standard-db-class))
(let ((direct-slot-names
(mapcar #'slot-definition-name (class-direct-slots self)))
(defmethod initialize-instance :around ((class standard-db-class)
&rest all-keys
&key direct-superclasses base-table
- qualifier normalisedp
+ qualifier normalizedp
&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))
+ (setf (normalizedp class) (car normalizedp))
(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 normalisedp
+ &key base-table normalizedp
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 (normalizedp class) (car normalizedp))
(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))
- (if (normalisedp class)
+ (if (normalizedp class)
(ordered-class-direct-slots class)
(ordered-class-slots class))))))
(setf (key-slots class) (remove-if-not (lambda (slot)
(eql (slot-value slot 'db-kind)
:key))
- (if (normalisedp class)
+ (if (normalizedp class)
(ordered-class-direct-slots class)
(ordered-class-slots class)))))
(setf (slot-value instance slot-name)
(fault-join-slot class instance slot-object))
(setf (slot-value instance slot-name) nil)))
- (when (and (normalisedp class)
+ (when (and (normalizedp class)
(not (member slot-name
(mapcar #'(lambda (esd) (slot-definition-name esd))
(ordered-class-direct-slots class))))
(let ((*db-deserializing* t))
(if (view-database instance)
(setf (slot-value instance slot-name)
- (fault-join-normalised-slot class instance slot-object))
+ (fault-join-normalized-slot class instance slot-object))
(setf (slot-value instance slot-name) nil)))))))
(call-next-method))
(if tclass
(let ((*default-database* database)
(pclass (car (class-direct-superclasses tclass))))
- (when (and (normalisedp tclass) (not (table-exists-p (view-table pclass))))
+ (when (and (normalizedp 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))
(defmethod %install-class ((self standard-db-class) database
&key (transactions t))
(let ((schemadef '())
- (ordered-slots (if (normalisedp self)
+ (ordered-slots (if (normalizedp self)
(ordered-class-direct-slots self)
(ordered-class-slots self))))
(dolist (slotdef ordered-slots)
(when res
(push res schemadef))))
(if (not schemadef)
- (unless (normalisedp self)
+ (unless (normalizedp self)
(error "Class ~s has no :base slots" self))
(progn
(create-table (sql-expression :table (view-table self)) (nreverse schemadef)
;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;;
-;;;; $Id$
-;;;;
;;;; The CLSQL Object Oriented Data Manipulation Language (OODML).
;;;;
;;;; This file is part of CLSQL.
(defun generate-selection-list (vclass)
(let* ((sels nil)
(this-class vclass)
- (slots (if (normalisedp vclass)
+ (slots (if (normalizedp vclass)
(labels ((getdslots ()
(let ((sl (ordered-class-direct-slots this-class)))
(cond (sl)
(database *default-database*))
(let* ((database (or (view-database obj) database))
(view-class (class-of obj)))
- (when (normalisedp view-class)
- ;; If it's normalised, find the class that actually contains
+ (when (normalizedp view-class)
+ ;; If it's normalized, find the class that actually contains
;; the slot that's tied to the db
(setf view-class
(do ((this-class view-class
(defmethod update-record-from-slots ((obj standard-db-object) slots &key
(database *default-database*))
+ (when (normalizedp (class-of obj))
+ ;; FIXME: Rewrite to bundle slots for same table to be written
+ ;; as avpairs (like how is done for non-normalized view-classes below)
+ (dolist (slot slots)
+ (update-record-from-slot obj slot :database database))
+ (return-from update-record-from-slots (values)))
+
(let* ((database (or (view-database obj) database))
(vct (view-table (class-of obj)))
(sds (slotdefs-for-slots-with-class slots (class-of obj)))
(pk-slot (car (keyslots-for-class view-class)))
(view-class-table (view-table view-class))
(pclass (car (class-direct-superclasses view-class))))
- (when (normalisedp view-class)
+ (when (normalizedp view-class)
(setf pk (update-records-from-instance obj :database database
:this-class pclass))
(when pk-slot
(setf (slot-value obj (slot-definition-name pk-slot)) pk)))
(let* ((slots (remove-if-not #'slot-storedp
- (if (normalisedp view-class)
+ (if (normalizedp view-class)
(ordered-class-direct-slots view-class)
(ordered-class-slots view-class))))
(record-values (mapcar #'slot-value-list slots)))
- (cond ((and (not (normalisedp view-class))
+ (cond ((and (not (normalizedp view-class))
(not record-values))
(error "No settable slots."))
- ((and (normalisedp view-class)
+ ((and (normalizedp view-class)
(not record-values))
nil)
((view-database obj)
(let* ((view-class (or this-class (class-of instance)))
(pclass (car (class-direct-superclasses view-class)))
(pres nil))
- (when (normalisedp view-class)
+ (when (normalizedp view-class)
(setf pres (update-instance-from-records instance :database database
:this-class pclass)))
(let* ((view-table (sql-expression :table (view-table view-class)))
slot &key (database *default-database*))
(let* ((view-class (find-class (class-name (class-of instance))))
(slot-def (slotdef-for-slot-with-class slot view-class)))
- (when (normalisedp view-class)
- ;; If it's normalised, find the class that actually contains
+ (when (normalizedp view-class)
+ ;; If it's normalized, find the class that actually contains
;; the slot that's tied to the db
(setf view-class
(do ((this-class view-class
;;;; 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)
+(defun fault-join-normalized-slot (class object slot-def)
(labels ((getsc (this-class)
(let ((sc (car (class-direct-superclasses this-class))))
(if (key-slots sc)
(slot-value object hk))
(t hk)))))
- ;; Caching nil in next select, because in normalised mode
+ ;; Caching nil in next select, because in normalized mode
;; records can be changed through other instances (children,
;; parents) so changes possibly won't be noticed
(let ((res (car (select (class-name sc) :where jq
:database (view-database object))))
(slot-name (slot-definition-name slot-def)))
- ;; If current class is normalised and wanted slot is not
+ ;; If current class is normalized and wanted slot is not
;; a direct member, recurse up
- (if (and (normalisedp class)
+ (if (and (normalizedp class)
(not (member slot-name
(mapcar #'(lambda (esd) (slot-definition-name esd))
(ordered-class-direct-slots class))))
(not (slot-boundp res slot-name)))
- (fault-join-normalised-slot sc res slot-def)
+ (fault-join-normalized-slot sc res slot-def)
(slot-value res slot-name)))))) )
(defun join-qualifier (class object slot-def)
;; find all immediate-select slots and join-vals for this object
(let* ((jo-class (class-of jo))
(slots
- (if (normalisedp jo-class)
+ (if (normalizedp jo-class)
(class-direct-slots jo-class)
(class-slots jo-class)))
(pos-list (remove-if #'null
#+lispworks
(defvar +lw-global-lock+
(unless +lw-has-without-preemption+
- (mp:make-lock :name "CLSQL" :important-p nil :safep t :recursivep nil)))
+ (mp:make-lock :name "CLSQL" :important-p nil :safep t :recursivep nil
+ :sharing t)))
(defmacro without-interrupts (&body body)
#+allegro `(mp:without-scheduling ,@body)
-;; classes for testing the normalisedp stuff
+;; classes for testing the normalizedp stuff
(def-view-class node ()
((node-id :accessor node-id :initarg :node-id
:type integer :db-kind :key
((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))
+ (:normalizedp 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))
+ (:normalizedp 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))
+ (:normalizedp t))
;; A class that uses only a superclass db table
(def-view-class location (node)
()
(:base-table node)
- (:normalisedp t))
+ (:normalizedp 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))
+ (:normalizedp t))
(if skip-tests
(dolist (skipped skip-tests)
(format *report-stream*
- "~& ~20A ~A~%" (car skipped) (cdr skipped)))
+ "~& ~30A ~A~%" (car skipped) (cdr skipped)))
(format *report-stream* " None~%")))
(disconnect)))
(cond
((and (null (clsql-sys:db-type-has-views? db-underlying-type))
(clsql-sys:in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4))
- (push (cons test "views not supported") skip-tests))
+ (push (cons test "views not supported.") skip-tests))
((and (null (clsql-sys:db-type-has-boolean-where? db-underlying-type))
(clsql-sys:in test :fdml/select/11 :oodml/select/5))
- (push (cons test "boolean where not supported") skip-tests))
+ (push (cons test "boolean where not supported.") skip-tests))
((and (null (clsql-sys:db-type-has-subqueries? db-underlying-type))
(clsql-sys:in test :fdml/select/5 :fdml/select/10
:fdml/select/32 :fdml/select/33))
- (push (cons test "subqueries not supported") skip-tests))
+ (push (cons test "subqueries not supported.") skip-tests))
((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type
*default-database*))
(clsql-sys:in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4))
- (push (cons test "transactions not supported") skip-tests))
+ (push (cons test "transactions not supported.") skip-tests))
((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type))
(clsql-sys:in test :fdml/select/1))
- (push (cons test "fancy math not supported") skip-tests))
+ (push (cons test "fancy math not supported.") skip-tests))
((and (eql *test-database-type* :sqlite)
(clsql-sys:in test :fddl/view/4 :fdml/select/10
:fdml/select/21 :fdml/select/32
:fdml/select/33))
- (push (cons test "not supported by sqlite") skip-tests))
+ (push (cons test "not supported by sqlite.") skip-tests))
((and (eql *test-database-type* :sqlite3)
(clsql-sys:in test :fddl/view/4 :fdml/select/10
:fdml/select/21 :fdml/select/32
:fdml/select/33))
- (push (cons test "not supported by sqlite3") skip-tests))
+ (push (cons test "not supported by sqlite3.") skip-tests))
((and (not (clsql-sys:db-type-has-bigint? db-type))
(clsql-sys:in test :basic/bigint/1))
- (push (cons test "bigint not supported") skip-tests))
+ (push (cons test "bigint not supported.") skip-tests))
((and (eql *test-database-underlying-type* :mysql)
(clsql-sys:in test :fdml/select/26))
- (push (cons test "string table aliases not supported on all mysql versions") skip-tests))
+ (push (cons test "string table aliases not supported on all mysql versions.") skip-tests))
((and (eql *test-database-underlying-type* :mysql)
(clsql-sys:in test :fdml/select/22 :fdml/query/5
:fdml/query/7 :fdml/query/8))
- (push (cons test "not supported by mysql") skip-tests))
+ (push (cons test "not supported by mysql.") skip-tests))
((and (null (clsql-sys:db-type-has-union? db-underlying-type))
(clsql-sys:in test :fdml/query/6 :fdml/select/31))
(push (cons test "union not supported") skip-tests))
((and (eq *test-database-type* :oracle)
(clsql-sys:in test :fdml/query/8 :fdml/select/21
:fddl/table/6))
- (push (cons test "syntax not supported") skip-tests))
+ (push (cons test "syntax not supported.") skip-tests))
((and (eq *test-database-type* :odbc)
(eq *test-database-underlying-type* :postgresql)
(clsql-sys:in test :fddl/owner/1 :fddl/owner/table
:fddl/owner/attribute-types
:fddl/owner/index
:fddl/owner/sequence))
- (push (cons test "table ownership not supported by postgresql odbc driver") skip-tests))
+ (push (cons test "table ownership not supported by postgresql odbc driver.") skip-tests))
((and (not (member *test-database-underlying-type*
'(:postgresql :oracle)))
(clsql-sys:in test :fddl/owner/1 :fddl/owner/table
:fddl/owner/attribute-types
:fddl/owner/index
:fddl/owner/sequence))
- (push (cons test "table ownership not supported") skip-tests))
+ (push (cons test "table ownership not supported.") skip-tests))
((and (null (clsql-sys:db-type-has-intersect? db-underlying-type))
(clsql-sys:in test :fdml/query/7))
- (push (cons test "intersect not supported") skip-tests))
+ (push (cons test "intersect not supported.") skip-tests))
((and (null (clsql-sys:db-type-has-except? db-underlying-type))
(clsql-sys:in test :fdml/query/8))
- (push (cons test "except not supported") skip-tests))
+ (push (cons test "except not supported.") skip-tests))
((and (eq *test-database-underlying-type* :mssql)
(clsql-sys:in test :fdml/select/9))
- (push (cons test "mssql uses integer math for AVG") skip-tests))
+ (push (cons test "mssql uses integer math for AVG.") skip-tests))
((and (not (member *test-database-underlying-type*
'(:postgresql :mysql :sqlite3)))
(clsql-sys:in test :fdml/select/37 :fdml/select/38))
- (push (cons test "LIMIT keyword not supported in SELECT") skip-tests))
+ (push (cons test "LIMIT keyword not supported in SELECT.") skip-tests))
((and (not (clsql-sys:db-type-has-auto-increment? db-underlying-type))
(clsql-sys:in test :oodml/select/12 :oodml/select/13 :oodml/select/14
:oodml/select/15 :oodml/select/16 :oodml/select/17
:oodml/update-instance/4 :oodml/update-instance/5
:oodml/update-instance/6 :oodml/update-instance/7
:oodml/db-auto-sync/3 :oodml/db-auto-sync/4))
- (push (cons test ":auto-increment not by backend.") skip-tests))
+ (push (cons test ":auto-increment not supported.") skip-tests))
(t
(push test-form test-forms)))))
(values (nreverse test-forms) (nreverse skip-tests))))
(clsql-sys::class-slots (find-class 'company))))
t t t t t t)
-;; Ensure classes are correctly marked normalised or not, default not
+;; Ensure classes are correctly marked normalized 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))
+; (clsql-sys::normalizedp derivednode1)
+; (clsql-sys::normalizedp basenode)
+; (clsql-sys::normalizedp company1)
+; (clsql-sys::normalizedp employee3)
+; (clsql-sys::normalizedp derivednode-sc-2))
; t nil nil nil t)
;(deftest :ooddl/metaclass/3
; (values
-; (normalisedp (find-class 'baseclass))
-; (normalisedp (find-class 'normderivedclass)))
+; (normalizedp (find-class 'baseclass))
+; (normalizedp (find-class 'normderivedclass)))
; nil t)
(deftest :ooddl/join/1
(slot-value employee1 'email))))
"lenin@soviet.org" "lenin-nospam@soviet.org")
-;; tests normalisedp update-instance-from-records
+;; tests normalizedp update-instance-from-records
(deftest :oodml/update-instance/3
(with-dataset *ds-nodes*
(values
"11 subloc-2 second subloc"
"11 Altered title Altered loc")
-;; tests update-slot-from-record with normalisedp stuff
+;; tests update-slot-from-record with normalizedp stuff
(deftest :oodml/update-instance/6
(with-dataset *ds-nodes*
(values
projects / clsql.git / commitdiff