From e622ee6f4bf2b9fe81af59d566e651c983a4833b Mon Sep 17 00:00:00 2001 From: Marcus Pearce Date: Mon, 24 May 2004 21:16:52 +0000 Subject: [PATCH] r9457: Reworked CLSQL file structure. --- ChangeLog | 25 + clsql.asd | 46 +- db-aodbc/aodbc-sql.lisp | 2 +- .../postgresql-socket-sql.lisp | 2 +- db-sqlite/sqlite-sql.lisp | 2 +- sql/base-classes.lisp | 3 +- sql/basic-sql.lisp | 83 --- sql/database.lisp | 4 - sql/{classes.lisp => expressions.lisp} | 2 +- sql/{table.lisp => fddl.lisp} | 2 +- sql/{sql.lisp => fdml.lisp} | 39 +- sql/generics.lisp | 32 ++ sql/ooddl.lisp | 209 +++++++ sql/{objects.lisp => oodml.lisp} | 197 +------ sql/package.lisp | 515 +++++++++--------- sql/transaction.lisp | 4 +- 16 files changed, 597 insertions(+), 570 deletions(-) delete mode 100644 sql/basic-sql.lisp rename sql/{classes.lisp => expressions.lisp} (99%) rename sql/{table.lisp => fddl.lisp} (99%) rename sql/{sql.lisp => fdml.lisp} (93%) create mode 100644 sql/ooddl.lisp rename sql/{objects.lisp => oodml.lisp} (83%) diff --git a/ChangeLog b/ChangeLog index b454968..1965c5b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,28 @@ +24 May 2004: Marcus Pearce (m.t.pearce@city.ac.uk) + * db-postgresql-socket/postgresql-socket-sql.lisp: replace + CLSQL-SIMPLE-WARNING with SQL-WARNING. + * db-sqlite/sqlite-sql.lisp: replace CLSQL-SIMPLE-WARNING with + SQL-WARNING. + * db-aodbc/aodbc-sql.lisp: replace CLSQL-ERROR with SQL-ERROR. + * clsql.asd: reworked module structure in package definition and + file names to better reflect component functionality. + * sql/package.lisp: added SQL-FATAL-ERROR and SQL-TIMEOUT-ERROR to + exports list. Removed duplicate and obsolete exports. Exported + remaining SQL operations: SQL-SOME, SQL-<>, SQL-BETWEEN, SQL-DISTINCT, + SQL-NVL and SQL-FUNCTION. Organised exports by functionality/file and + according to whether they are specified by CommonSQL or CLSQL + extensions. + * sql/transaction.lisp: replace CLSQL-SIMPLE-WARNING with + SQL-WARNING. + * sql/generics.lisp: moved generics for QUERY and EXECUTE-COMMAND + here from basic-sql.lisp. + * sql/expressions.lisp: NEW FILE: renamed from classes.lisp (deleted). + * sql/fddl.lisp: NEW FILE: renamed from table.lisp (deleted). + * sql/fdml.lisp: NEW FILE: merger of basic-sql.lisp and sql.lisp + (both deleted). + * sql/ooddl.lisp: NEW FILE: ooddl from objects.lisp (deleted). + * sql/oodml.lisp: NEW FILE: oodml from objects.lisp (deleted). + 23 May 2004 Kevin Rosenberg * Version 2.10.22 released * sql/kmr-mop.lisp, sql/objects.lisp: Since SBCL is the only implementation that diff --git a/clsql.asd b/clsql.asd index c7b3d92..f9e8bff 100644 --- a/clsql.asd +++ b/clsql.asd @@ -36,35 +36,41 @@ oriented interface." :components ((:file "cmucl-compat") (:file "package") - (:file "utils" :depends-on ("package" "db-interface")) + (:file "kmr-mop" :depends-on ("package")) (:file "base-classes" :depends-on ("package")) - (:file "conditions" :depends-on ("base-classes")) - (:file "db-interface" :depends-on ("conditions")) - (:file "initialize" :depends-on ("db-interface" "utils")) - (:file "loop-extension" :depends-on ("db-interface")) - (:file "time" :depends-on ("package")) + (:file "conditions" :depends-on ("base-classes")) + (:file "db-interface" :depends-on ("conditions")) + (:file "time" :depends-on ("package" "conditions")) + (:file "utils" :depends-on ("package" "db-interface")) + (:file "generics" :depends-on ("package")))) + (:module :database + :pathname "" + :components + ((:file "initialize") (:file "database" :depends-on ("initialize")) - (:file "recording" :depends-on ("time" "database")) - (:file "basic-sql" :depends-on ("database" "cmucl-compat")) - (:file "pool" :depends-on ("basic-sql")) - (:file "transaction" :depends-on ("basic-sql")) - (:file "kmr-mop" :depends-on ("package")))) - (:module :core + (:file "recording" :depends-on ("database")) + (:file "pool")) + :depends-on (:base)) + (:module :syntax :pathname "" - :components ((:file "generics") - (:file "classes" :depends-on ("generics")) - (:file "operations" :depends-on ("classes")) + :components ((:file "expressions") + (:file "operations" + :depends-on ("expressions")) (:file "syntax" :depends-on ("operations"))) - :depends-on (:base)) + :depends-on (:database)) (:module :functional :pathname "" - :components ((:file "sql") - (:file "table" :depends-on ("sql"))) - :depends-on (:core)) + :components ((:file "fdml") + (:file "transaction" :depends-on ("fdml")) + (:file "loop-extension" + :depends-on ("fdml")) + (:file "fddl" :depends-on ("fdml"))) + :depends-on (:syntax)) (:module :object :pathname "" :components ((:file "metaclasses") - (:file "objects" :depends-on ("metaclasses"))) + (:file "ooddl" :depends-on ("metaclasses")) + (:file "oodml" :depends-on ("ooddl"))) :depends-on (:functional)) (:module :generic :pathname "" diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index 8a6ee00..7994892 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -57,7 +57,7 @@ (dbi:connect :user user :password password :data-source-name dsn)) - (clsql-error (e) + (sql-error (e) (error e)) (error () ;; Init or Connect failed (error 'sql-connection-error diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index ab4d710..46e82ce 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -182,7 +182,7 @@ doesn't depend on UFFI." (handler-case (handler-bind ((postgresql-warning (lambda (c) - (warn 'clsql-simple-warning + (warn 'sql-warning :format-control "~A" :format-arguments (list (princ-to-string c)))))) diff --git a/db-sqlite/sqlite-sql.lisp b/db-sqlite/sqlite-sql.lisp index 3c6d31e..17e8ff8 100644 --- a/db-sqlite/sqlite-sql.lisp +++ b/db-sqlite/sqlite-sql.lisp @@ -62,7 +62,7 @@ (sqlite:sqlite-get-table (sqlite-db database) sql-expression) (sqlite:sqlite-free-table data) (unless (= row-n 0) - (error 'clsql-simple-warning + (error 'sql-warning :format-control "Result set not empty: ~@(~A~) row~:P, ~@(~A~) column~:P " :format-arguments (list row-n col-n)))) diff --git a/sql/base-classes.lisp b/sql/base-classes.lisp index 7ebbc5c..4e33010 100644 --- a/sql/base-classes.lisp +++ b/sql/base-classes.lisp @@ -51,4 +51,5 @@ are a list of ACTION specified for table and any cached value of list-attributes "") (database-state object)))) - +(setf (documentation 'database-name 'function) + "Returns the name of a database.") diff --git a/sql/basic-sql.lisp b/sql/basic-sql.lisp deleted file mode 100644 index ae42dd9..0000000 --- a/sql/basic-sql.lisp +++ /dev/null @@ -1,83 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; -;;;; $Id$ -;;;; -;;;; Base SQL functions -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-sys) - -;;; Query - -(defgeneric query (query-expression &key database result-types flatp field-names) - (:documentation - "Executes the SQL query expression QUERY-EXPRESSION, which may -be an SQL expression or a string, on the supplied DATABASE which -defaults to *DEFAULT-DATABASE*. RESULT-TYPES is a list of symbols -which specifies the lisp type for each field returned by -QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned -as strings whereas the default value of :auto means that the lisp -types are automatically computed for each field. FIELD-NAMES is t -by default which means that the second value returned is a list -of strings representing the columns selected by -QUERY-EXPRESSION. If FIELD-NAMES is nil, the list of column names -is not returned as a second value. FLATP has a default value of -nil which means that the results are returned as a list of -lists. If FLATP is t and only one result is returned for each -record selected by QUERY-EXPRESSION, the results are returned as -elements of a list.")) - -(defmethod query ((query-expression string) &key (database *default-database*) - (result-types :auto) (flatp nil) (field-names t)) - (record-sql-command query-expression database) - (multiple-value-bind (rows names) - (database-query query-expression database result-types field-names) - (let ((result (if (and flatp (= 1 (length (car rows)))) - (mapcar #'car rows) - rows))) - (record-sql-result result database) - (if field-names - (values result names) - result)))) - -;;; Execute - -(defgeneric execute-command (expression &key database) - (:documentation - "Executes the SQL command EXPRESSION, which may be an SQL -expression or a string representing any SQL statement apart from -a query, on the supplied DATABASE which defaults to -*DEFAULT-DATABASE*.")) - -(defmethod execute-command ((sql-expression string) - &key (database *default-database*)) - (record-sql-command sql-expression database) - (let ((res (database-execute-command sql-expression database))) - (record-sql-result res database)) - (values)) - -;;; Large objects support - -(defun create-large-object (&key (database *default-database*)) - "Creates a new large object in the database and returns the object identifier" - (database-create-large-object database)) - -(defun write-large-object (object-id data &key (database *default-database*)) - "Writes data to the large object" - (database-write-large-object object-id data database)) - -(defun read-large-object (object-id &key (database *default-database*)) - "Reads the large object content" - (database-read-large-object object-id database)) - -(defun delete-large-object (object-id &key (database *default-database*)) - "Deletes the large object in the database" - (database-delete-large-object object-id database)) - diff --git a/sql/database.lisp b/sql/database.lisp index d592181..f155732 100644 --- a/sql/database.lisp +++ b/sql/database.lisp @@ -14,10 +14,6 @@ (in-package #:clsql-sys) -(setf (documentation 'database-name 'function) - "Returns the name of a database.") - -;;; Database handling (defvar *connect-if-exists* :error "Default value for the if-exists keyword argument in calls to diff --git a/sql/classes.lisp b/sql/expressions.lisp similarity index 99% rename from sql/classes.lisp rename to sql/expressions.lisp index 80d735c..fb9f3f7 100644 --- a/sql/classes.lisp +++ b/sql/expressions.lisp @@ -1,7 +1,7 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ +;;;; $Id: ;;;; ;;;; Classes defining SQL expressions and methods for formatting the ;;;; appropriate SQL commands. diff --git a/sql/table.lisp b/sql/fddl.lisp similarity index 99% rename from sql/table.lisp rename to sql/fddl.lisp index bc68a81..608a114 100644 --- a/sql/table.lisp +++ b/sql/fddl.lisp @@ -1,7 +1,7 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ +;;;; $Id: ;;;; ;;;; The CLSQL Functional Data Definition Language (FDDL) ;;;; including functions for schema manipulation. Currently supported diff --git a/sql/sql.lisp b/sql/fdml.lisp similarity index 93% rename from sql/sql.lisp rename to sql/fdml.lisp index e3e064a..1593030 100644 --- a/sql/sql.lisp +++ b/sql/fdml.lisp @@ -1,7 +1,7 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ +;;;; $Id: ;;;; ;;;; The CLSQL Functional Data Manipulation Language (FDML). ;;;; @@ -21,11 +21,30 @@ (database-query-result-set (sql-output expr database) database :full-set full-set :result-types result-types)) +(defmethod execute-command ((sql-expression string) + &key (database *default-database*)) + (record-sql-command sql-expression database) + (let ((res (database-execute-command sql-expression database))) + (record-sql-result res database)) + (values)) + (defmethod execute-command ((expr %sql-expression) &key (database *default-database*)) (execute-command (sql-output expr database) :database database) (values)) +(defmethod query ((query-expression string) &key (database *default-database*) + (result-types :auto) (flatp nil) (field-names t)) + (record-sql-command query-expression database) + (multiple-value-bind (rows names) + (database-query query-expression database result-types field-names) + (let ((result (if (and flatp (= 1 (length (car rows)))) + (mapcar #'car rows) + rows))) + (record-sql-result result database) + (if field-names + (values result names) + result)))) (defmethod query ((expr %sql-expression) &key (database *default-database*) (result-types :auto) (flatp nil) (field-names t)) @@ -545,4 +564,22 @@ computed for each field." (lisp->sql-name (cadr o)))))) +;;; Large objects support + +(defun create-large-object (&key (database *default-database*)) + "Creates a new large object in the database and returns the object identifier" + (database-create-large-object database)) + +(defun write-large-object (object-id data &key (database *default-database*)) + "Writes data to the large object" + (database-write-large-object object-id data database)) + +(defun read-large-object (object-id &key (database *default-database*)) + "Reads the large object content" + (database-read-large-object object-id database)) + +(defun delete-large-object (object-id &key (database *default-database*)) + "Deletes the large object in the database" + (database-delete-large-object object-id database)) + diff --git a/sql/generics.lisp b/sql/generics.lisp index f4b2848..d513bd3 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -18,6 +18,38 @@ (in-package #:clsql-sys) + +;; FDML + +(defgeneric execute-command (expression &key database) + (:documentation + "Executes the SQL command EXPRESSION, which may be an SQL +expression or a string representing any SQL statement apart from +a query, on the supplied DATABASE which defaults to +*DEFAULT-DATABASE*.")) + + +(defgeneric query (query-expression &key database result-types flatp field-names) + (:documentation + "Executes the SQL query expression QUERY-EXPRESSION, which may +be an SQL expression or a string, on the supplied DATABASE which +defaults to *DEFAULT-DATABASE*. RESULT-TYPES is a list of symbols +which specifies the lisp type for each field returned by +QUERY-EXPRESSION. If RESULT-TYPES is nil all results are returned +as strings whereas the default value of :auto means that the lisp +types are automatically computed for each field. FIELD-NAMES is t +by default which means that the second value returned is a list +of strings representing the columns selected by +QUERY-EXPRESSION. If FIELD-NAMES is nil, the list of column names +is not returned as a second value. FLATP has a default value of +nil which means that the results are returned as a list of +lists. If FLATP is t and only one result is returned for each +record selected by QUERY-EXPRESSION, the results are returned as +elements of a list.")) + + +;; OODML + (defgeneric update-record-from-slot (object slot &key database) (:documentation "Updates the value stored in the column represented by the diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp new file mode 100644 index 0000000..d37470d --- /dev/null +++ b/sql/ooddl.lisp @@ -0,0 +1,209 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id: +;;;; +;;;; The CLSQL Object Oriented Data Definitional Language (OODDL) +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + + +(in-package #:clsql-sys) + +(defclass standard-db-object () + ((view-database :initform nil :initarg :view-database :reader view-database + :db-kind :virtual)) + (:metaclass standard-db-class) + (:documentation "Superclass for all CLSQL View Classes.")) + +(defvar *db-auto-sync* nil + "A non-nil value means that creating View Class instances or + setting their slots automatically creates/updates the + corresponding records in the underlying database.") + +(defvar *db-deserializing* nil) +(defvar *db-initializing* nil) + +(defmethod slot-value-using-class ((class standard-db-class) instance slot-def) + (declare (optimize (speed 3))) + (unless *db-deserializing* + (let* ((slot-name (%svuc-slot-name slot-def)) + (slot-object (%svuc-slot-object slot-def class)) + (slot-kind (view-class-slot-db-kind slot-object))) + (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)))))) + (call-next-method)) + +(defmethod (setf slot-value-using-class) (new-value (class standard-db-class) + instance slot-def) + (declare (ignore new-value)) + (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))) + (call-next-method) + (when (and *db-auto-sync* + (not *db-initializing*) + (not *db-deserializing*) + (not (eql slot-kind :virtual))) + (update-record-from-slot instance slot-name)))) + +(defmethod initialize-instance ((object standard-db-object) + &rest all-keys &key &allow-other-keys) + (declare (ignore all-keys)) + (let ((*db-initializing* t)) + (call-next-method) + (when (and *db-auto-sync* + (not *db-deserializing*)) + (update-records-from-instance object)))) + +;; +;; Build the database tables required to store the given view class +;; + +(defun create-view-from-class (view-class-name + &key (database *default-database*)) + "Creates a table as defined by the View Class VIEW-CLASS-NAME +in DATABASE which defaults to *DEFAULT-DATABASE*." + (let ((tclass (find-class view-class-name))) + (if tclass + (let ((*default-database* database)) + (%install-class tclass database)) + (error "Class ~s not found." view-class-name))) + (values)) + +(defmethod %install-class ((self standard-db-class) database &aux schemadef) + (dolist (slotdef (ordered-class-slots self)) + (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 + :constraints (database-pkey-constraint self database)) + (push self (database-view-classes database)) + t) + +(defmethod database-pkey-constraint ((class standard-db-class) database) + (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) + (when keylist + (convert-to-db-default-case + (format nil "CONSTRAINT ~APK PRIMARY KEY~A" + (database-output-sql (view-table class) database) + (database-output-sql keylist database)) + database)))) + +(defmethod database-generate-column-definition (class slotdef database) + (declare (ignore database class)) + (when (member (view-class-slot-db-kind slotdef) '(:base :key)) + (let ((cdef + (list (sql-expression :attribute (view-class-slot-column slotdef)) + (specified-type slotdef)))) + (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) + (let ((const (view-class-slot-db-constraints slotdef))) + (when const + (setq cdef (append cdef (list const))))) + cdef))) + + +;; +;; Drop the tables which store the given view class +;; + +(defun drop-view-from-class (view-class-name &key (database *default-database*)) + "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))) + (if tclass + (let ((*default-database* database)) + (%uninstall-class tclass)) + (error "Class ~s not found." view-class-name))) + (values)) + +(defun %uninstall-class (self &key (database *default-database*)) + (drop-table (sql-expression :table (view-table self)) + :if-does-not-exist :ignore + :database database) + (setf (database-view-classes database) + (remove self (database-view-classes database)))) + + +;; +;; List all known view classes +;; + +(defun list-classes (&key (test #'identity) + (root-class (find-class 'standard-db-object)) + (database *default-database*)) + "Returns a list of all the View Classes which are connected to +DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend +from the class ROOT-CLASS and which satisfy the function TEST. By +default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY." + (flet ((find-superclass (class) + (member root-class (class-precedence-list class)))) + (let ((view-classes (and database (database-view-classes database)))) + (when view-classes + (remove-if #'(lambda (c) (or (not (funcall test c)) + (not (find-superclass c)))) + view-classes))))) + +;; +;; Define a new view class +;; + +(defmacro def-view-class (class supers slots &rest cl-options) + "Creates a View Class called CLASS whose slots SLOTS can map +onto the attributes of a table in a database. If SUPERS is nil +then the superclass of CLASS will be STANDARD-DB-OBJECT, +otherwise SUPERS is a list of superclasses for CLASS which must +include STANDARD-DB-OBJECT or a descendent of this class. The +syntax of DEFCLASS is extended through the addition of a class +option :base-table which defines the database table onto which +the View Class maps and which defaults to CLASS. The DEFCLASS +syntax is also extended through additional slot +options. The :db-kind slot option specifies the kind of DB +mapping which is performed for this slot and defaults to :base +which indicates that the slot maps to an ordinary column of the +database table. A :db-kind value of :key indicates that this slot +is a special kind of :base slot which maps onto a column which is +one of the unique keys for the database table, the value :join +indicates this slot represents a join onto another View Class +which contains View Class objects, and the value :virtual +indicates a standard CLOS slot which does not map onto columns of +the database table. If a slot is specified with :db-kind :join, +the slot option :db-info contains a list which specifies the +nature of the join. For slots of :db-kind :base or :key, +the :type slot option has a special interpretation such that Lisp +types, such as string, integer and float are automatically +converted into appropriate SQL types for the column onto which +the slot maps. This behaviour may be over-ridden using +the :db-type slot option which is a string specifying the +vendor-specific database type for this slot's column definition +in the database. The :column slot option specifies the name of +the SQL column which the slot maps onto, if :db-kind is +not :virtual, and defaults to the slot name. The :void-value slot +option specifies the value to store if the SQL value is NULL and +defaults to NIL. The :db-constraints slot option is a string +representing an SQL table constraint expression or a list of such +strings." + `(progn + (defclass ,class ,supers ,slots + ,@(if (find :metaclass `,cl-options :key #'car) + `,cl-options + (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) + (finalize-inheritance (find-class ',class)) + (find-class ',class))) + +(defun keyslots-for-class (class) + (slot-value class 'key-slots)) diff --git a/sql/objects.lisp b/sql/oodml.lisp similarity index 83% rename from sql/objects.lisp rename to sql/oodml.lisp index 63cef6a..d44b90b 100644 --- a/sql/objects.lisp +++ b/sql/oodml.lisp @@ -1,10 +1,9 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; -;;;; $Id$ +;;;; $Id: ;;;; -;;;; The CLSQL Object Oriented Data Definitional Language (OODDL) -;;;; and Object Oriented Data Manipulation Language (OODML). +;;;; The CLSQL Object Oriented Data Manipulation Language (OODML). ;;;; ;;;; This file is part of CLSQL. ;;;; @@ -15,198 +14,6 @@ (in-package #:clsql-sys) -(defclass standard-db-object () - ((view-database :initform nil :initarg :view-database :reader view-database - :db-kind :virtual)) - (:metaclass standard-db-class) - (:documentation "Superclass for all CLSQL View Classes.")) - -(defvar *db-auto-sync* nil - "A non-nil value means that creating View Class instances or - setting their slots automatically creates/updates the - corresponding records in the underlying database.") - -(defvar *db-deserializing* nil) -(defvar *db-initializing* nil) - -(defmethod slot-value-using-class ((class standard-db-class) instance slot-def) - (declare (optimize (speed 3))) - (unless *db-deserializing* - (let* ((slot-name (%svuc-slot-name slot-def)) - (slot-object (%svuc-slot-object slot-def class)) - (slot-kind (view-class-slot-db-kind slot-object))) - (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)))))) - (call-next-method)) - -(defmethod (setf slot-value-using-class) (new-value (class standard-db-class) - instance slot-def) - (declare (ignore new-value)) - (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))) - (call-next-method) - (when (and *db-auto-sync* - (not *db-initializing*) - (not *db-deserializing*) - (not (eql slot-kind :virtual))) - (update-record-from-slot instance slot-name)))) - -(defmethod initialize-instance ((object standard-db-object) - &rest all-keys &key &allow-other-keys) - (declare (ignore all-keys)) - (let ((*db-initializing* t)) - (call-next-method) - (when (and *db-auto-sync* - (not *db-deserializing*)) - (update-records-from-instance object)))) - -;; -;; Build the database tables required to store the given view class -;; - -(defun create-view-from-class (view-class-name - &key (database *default-database*)) - "Creates a table as defined by the View Class VIEW-CLASS-NAME -in DATABASE which defaults to *DEFAULT-DATABASE*." - (let ((tclass (find-class view-class-name))) - (if tclass - (let ((*default-database* database)) - (%install-class tclass database)) - (error "Class ~s not found." view-class-name))) - (values)) - -(defmethod %install-class ((self standard-db-class) database &aux schemadef) - (dolist (slotdef (ordered-class-slots self)) - (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 - :constraints (database-pkey-constraint self database)) - (push self (database-view-classes database)) - t) - -(defmethod database-pkey-constraint ((class standard-db-class) database) - (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) - (when keylist - (convert-to-db-default-case - (format nil "CONSTRAINT ~APK PRIMARY KEY~A" - (database-output-sql (view-table class) database) - (database-output-sql keylist database)) - database)))) - -(defmethod database-generate-column-definition (class slotdef database) - (declare (ignore database class)) - (when (member (view-class-slot-db-kind slotdef) '(:base :key)) - (let ((cdef - (list (sql-expression :attribute (view-class-slot-column slotdef)) - (specified-type slotdef)))) - (setf cdef (append cdef (list (view-class-slot-db-type slotdef)))) - (let ((const (view-class-slot-db-constraints slotdef))) - (when const - (setq cdef (append cdef (list const))))) - cdef))) - - -;; -;; Drop the tables which store the given view class -;; - -(defun drop-view-from-class (view-class-name &key (database *default-database*)) - "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))) - (if tclass - (let ((*default-database* database)) - (%uninstall-class tclass)) - (error "Class ~s not found." view-class-name))) - (values)) - -(defun %uninstall-class (self &key (database *default-database*)) - (drop-table (sql-expression :table (view-table self)) - :if-does-not-exist :ignore - :database database) - (setf (database-view-classes database) - (remove self (database-view-classes database)))) - - -;; -;; List all known view classes -;; - -(defun list-classes (&key (test #'identity) - (root-class (find-class 'standard-db-object)) - (database *default-database*)) - "Returns a list of all the View Classes which are connected to -DATABASE, which defaults to *DEFAULT-DATABASE*, and which descend -from the class ROOT-CLASS and which satisfy the function TEST. By -default ROOT-CLASS is STANDARD-DB-OBJECT and TEST is IDENTITY." - (flet ((find-superclass (class) - (member root-class (class-precedence-list class)))) - (let ((view-classes (and database (database-view-classes database)))) - (when view-classes - (remove-if #'(lambda (c) (or (not (funcall test c)) - (not (find-superclass c)))) - view-classes))))) - -;; -;; Define a new view class -;; - -(defmacro def-view-class (class supers slots &rest cl-options) - "Creates a View Class called CLASS whose slots SLOTS can map -onto the attributes of a table in a database. If SUPERS is nil -then the superclass of CLASS will be STANDARD-DB-OBJECT, -otherwise SUPERS is a list of superclasses for CLASS which must -include STANDARD-DB-OBJECT or a descendent of this class. The -syntax of DEFCLASS is extended through the addition of a class -option :base-table which defines the database table onto which -the View Class maps and which defaults to CLASS. The DEFCLASS -syntax is also extended through additional slot -options. The :db-kind slot option specifies the kind of DB -mapping which is performed for this slot and defaults to :base -which indicates that the slot maps to an ordinary column of the -database table. A :db-kind value of :key indicates that this slot -is a special kind of :base slot which maps onto a column which is -one of the unique keys for the database table, the value :join -indicates this slot represents a join onto another View Class -which contains View Class objects, and the value :virtual -indicates a standard CLOS slot which does not map onto columns of -the database table. If a slot is specified with :db-kind :join, -the slot option :db-info contains a list which specifies the -nature of the join. For slots of :db-kind :base or :key, -the :type slot option has a special interpretation such that Lisp -types, such as string, integer and float are automatically -converted into appropriate SQL types for the column onto which -the slot maps. This behaviour may be over-ridden using -the :db-type slot option which is a string specifying the -vendor-specific database type for this slot's column definition -in the database. The :column slot option specifies the name of -the SQL column which the slot maps onto, if :db-kind is -not :virtual, and defaults to the slot name. The :void-value slot -option specifies the value to store if the SQL value is NULL and -defaults to NIL. The :db-constraints slot option is a string -representing an SQL table constraint expression or a list of such -strings." - `(progn - (defclass ,class ,supers ,slots - ,@(if (find :metaclass `,cl-options :key #'car) - `,cl-options - (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) - (finalize-inheritance (find-class ',class)) - (find-class ',class))) - -(defun keyslots-for-class (class) - (slot-value class 'key-slots)) (defun key-qualifier-for-instance (obj &key (database *default-database*)) (let ((tb (view-table (class-of obj)))) diff --git a/sql/package.lisp b/sql/package.lisp index f196f5b..2a07e84 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -148,6 +148,9 @@ #:database-get-type-specifier #:read-sql-value #:database-output-sql-as-type + #:*loaded-database-types* + #:reload-database-types + #:is-database-open ;; Large objects #:database-create-large-object @@ -182,17 +185,6 @@ #:convert-to-db-default-case #:ensure-keyword #:getenv - - #:*loaded-database-types* - #:reload-database-types - #:*connect-if-exists* - #:connected-databases - #:database - #:find-database - #:is-database-open - #:database-type ; database x - - ;; utils.lisp #:number-to-sql-string #:float-to-sql-string #:sql-escape-quotes @@ -203,289 +195,294 @@ #:generic-odbc-database . + ;; Shared exports for re-export by CLSQL package. - ;; I = Implemented, D = Documented - ;; name file ID - ;;==================================================== - #1=(;;------------------------------------------------ - ;; CommonSQL API - ;;------------------------------------------------ - ;;FDML - #:select ; objects xx - #:cache-table-queries ; - #:*cache-table-queries-default* ; - #:delete-records ; sql xx - #:insert-records ; sql xx - #:update-records ; sql xx - #:execute-command ; sql xx - #:query ; sql xx - #:print-query ; sql xx - #:do-query ; sql xx - #:map-query ; sql xx - #:for-each-row - #:loop + #1=( - ;; conditions + ;; Condition system (conditions.lisp) #:sql-user-error #:sql-database-error #:sql-database-data-error #:sql-connection-error #:sql-temporary-error + #:sql-timeout-error + #:sql-fatal-error #:sql-error-error-id #:sql-error-secondary-error-id #:sql-error-database-message - ;; CLSQL Extensions #:sql-condition #:sql-error #:sql-warning #:sql-database-warning - - ;;FDDL - #:create-table ; table xx - #:drop-table ; table xx - #:list-tables ; table xx - #:table-exists-p ; table xx - #:list-attributes ; table xx - #:attribute-type ; table xx - #:list-attribute-types ; table xx - #:*cache-table-queries-default* ; table xx - #:create-view ; table xx - #:drop-view ; table xx - #:create-index ; table xx - #:drop-index ; table xx - #:truncate-database - ;;OODDL - #:standard-db-object ; objects xx - #:def-view-class ; objects xx - #:create-view-from-class ; objects xx - #:drop-view-from-class ; objects xx - ;;OODML - #:instance-refreshed ; objects xx - #:update-objects-joins ; objects xx - #:*default-update-objects-max-len* ; objects xx - #:update-slot-from-record ; objects xx - #:update-instance-from-records ; objects xx - #:update-records-from-instance ; objects xx - #:update-record-from-slot ; objects xx - #:update-record-from-slots ; objects xx - #:list-classes ; objects xx - #:delete-instance-records ; objects xx - ;;Symbolic SQL Syntax - #:sql ; syntax xx - #:sql-expression ; syntax xx - #:sql-operation ; syntax xx - #:sql-operator ; syntax xx - #:disable-sql-reader-syntax ; syntax xx - #:enable-sql-reader-syntax ; syntax xx - #:locally-disable-sql-reader-syntax ; syntax xx - #:locally-enable-sql-reader-syntax ; syntax xx - #:restore-sql-reader-syntax-state ; syntax xx - - ;;FDDL - #:list-views ; table xx - #:view-exists-p ; table xx - #:list-indexes ; table xx - #:list-table-indexes ; table xx - #:index-exists-p ; table xx - #:create-sequence ; table xx - #:drop-sequence ; table xx - #:list-sequences ; table xx - #:sequence-exists-p ; table xx - #:sequence-next ; table xx - #:sequence-last ; table xx - #:set-sequence-position ; table xx - ;;OODDL - #:view-table ; metaclass x - #:universal-time ; objects xx + #:*backend-warning-behavior* + + ;; Connection/initialisation (base-classes.lisp, database.lisp, + ;; initialize.lisp) + #:*default-database-type* + #:*default-database* + #:*initialized-database-types* + #:initialize-database-type + #:connect + #:disconnect + #:*connect-if-exists* + #:connected-databases + #:database + #:database-name + #:reconnect + #:find-database + #:status + ;; CLSQL Extensions + #:with-database + #:with-default-database + #:disconnect-pooled + #:list-databases + #:create-database + #:destroy-database + #:probe-database + #:truncate-database + + ;; I/O Recording (recording.lisp) + #:add-sql-stream + #:delete-sql-stream + #:list-sql-streams + #:sql-recording-p + #:sql-stream + #:start-sql-recording + #:stop-sql-recording + ;; CLSQL Extensions + #:record-sql-command + #:record-sql-result + + ;; FDDL (fddl.lisp) + #:create-table + #:drop-table + #:list-tables + #:table-exists-p + #:list-attributes + #:attribute-type + #:list-attribute-types + #:*cache-table-queries-default* + #:create-view + #:drop-view + #:create-index + #:drop-index + ;; CLSQL Extensions + #:describe-table + #:list-views + #:view-exists-p + #:list-indexes + #:list-table-indexes + #:index-exists-p + #:create-sequence + #:drop-sequence + #:list-sequences + #:sequence-exists-p + #:sequence-next + #:sequence-last + #:set-sequence-position + + ;; FDML (fdml.lisp) + #:select + #:cache-table-queries + #:*cache-table-queries-default* + #:delete-records + #:insert-records + #:update-records + #:execute-command + #:query + #:print-query + #:do-query + #:map-query + #:loop + ;; CLSQL Extensions + #:for-each-row + + ;; Transaction handling (transaction.lisp) + #:with-transaction + #:commit + #:rollback + ;; CLSQL Extensions + #:commit-transaction + #:rollback-transaction + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + #:start-transaction + #:in-transaction-p + #:database-start-transaction + #:database-abort-transaction + #:database-commit-transaction + #:transaction-level + #:transaction + + ;; OODDL (ooddl.lisp) + #:standard-db-object + #:def-view-class + #:create-view-from-class + #:drop-view-from-class + #:list-classes + #:universal-time + ;; CLSQL Extensions + #:view-table #:bigint - ;;OODML - #:*db-auto-sync* ; objects xx - - ;; conditions - #:clsql-condition - #:clsql-error - #:clsql-simple-error - #:clsql-simple-warning + + ;; OODML (oodml.lisp) + #:instance-refreshed + #:update-objects-joins + #:*default-update-objects-max-len* + #:update-slot-from-record + #:update-instance-from-records + #:update-records-from-instance + #:update-record-from-slot + #:update-record-from-slots + #:delete-instance-records + ;; CLSQL Extensions + #:*db-auto-sync* + + ;; Symbolic SQL Syntax (syntax.lisp) + #:sql + #:sql-expression + #:sql-operation + #:sql-operator + #:disable-sql-reader-syntax + #:enable-sql-reader-syntax + #:locally-disable-sql-reader-syntax + #:locally-enable-sql-reader-syntax + #:restore-sql-reader-syntax-state - ;;----------------------------------------------- - ;; Symbolic Sql Syntax - ;;----------------------------------------------- - #:sql-and-qualifier - #:sql-escape + ;; SQL operations (operations.lisp) #:sql-query #:sql-object-query #:sql-any + #:sql-some #:sql-all #:sql-not #:sql-union - #:sql-intersection + #:sql-intersect #:sql-minus - #:sql-group-by - #:sql-having + #:sql-except + #:sql-order-by #:sql-null - #:sql-not-null - #:sql-exists #:sql-* #:sql-+ #:sql-/ + #:sql-- #:sql-like - #:sql-uplike #:sql-and #:sql-or #:sql-in - #:sql-|| - #:sql-is + #:sql-concat + #:sql-substr #:sql-= - #:sql-== #:sql-< - #:sql-> - #:sql->= - #:sql-<= - #:sql-count - #:sql-max - #:sql-min - #:sql-avg - #:sql-sum - #:sql-view-class - #:sql_slot-value - - - - ;; time.lisp - #:bad-component - #:current-day - #:current-month - #:current-year - #:day-duration - #:db-timestring - #:decode-duration - #:decode-time - #:duration - #:duration+ - #:duration< - #:duration<= - #:duration= - #:duration> - #:duration>= - #:duration-day - #:duration-hour - #:duration-minute - #:duration-month - #:duration-second - #:duration-year - #:duration-reduce - #:duration-timestring - #:extract-roman - #:format-duration - #:format-time - #:get-time - #:utime->time - #:interval-clear - #:interval-contained - #:interval-data - #:interval-edit - #:interval-end - #:interval-match - #:interval-push - #:interval-relation - #:interval-start - #:interval-type - #:make-duration - #:make-interval - #:make-time - #:merged-time - #:midnight - #:month-name - #:parse-date-time - #:parse-timestring - #:parse-yearstring - #:print-date - #:roll - #:roll-to - #:time - #:time+ - #:time- - #:time-by-adding-duration - #:time-compare - #:time-difference - #:time-dow - #:time-element - #:time-max - #:time-min - #:time-mjd - #:time-msec - #:time-p - #:time-sec - #:time-well-formed - #:time-ymd - #:time< - #:time<= - #:time= - #:time> - #:time>= - #:timezone - #:universal-time - #:wall-time - #:wall-timestring - #:week-containing - #:gregorian-to-mjd - #:mjd-to-gregorian - - ;; recording.lisp -- SQL I/O Recording - #:record-sql-command - #:record-sql-result - #:add-sql-stream ; recording xx - #:delete-sql-stream ; recording xx - #:list-sql-streams ; recording xx - #:sql-recording-p ; recording xx - #:sql-stream ; recording xx - #:start-sql-recording ; recording xx - #:stop-sql-recording ; recording xx + #:sql-> + #:sql->= + #:sql-<= + #:sql-<> + #:sql-count + #:sql-max + #:sql-min + #:sql-avg + #:sql-sum + #:sql-function + #:sql-between + #:sql-distinct + #:sql-nvl + #:sql-slot-value + ;; CLSQL Extensions + #:sql-limit + #:sql-group-by + #:sql-having + #:sql-not-null + #:sql-exists + #:sql-uplike + #:sql-is + #:sql-== + #:sql-the + #:sql-coalesce + #:sql-view-class - ;; database.lisp -- Connection - #:*default-database-type* ; clsql-base xx - #:*default-database* ; classes xx - #:*initialized-database-types* - #:initialize-database-type - #:connect ; database xx - #:disconnect ; database xx - #:*connect-if-exists* ; database xx - #:connected-databases ; database xx - #:database ; database xx - #:database-name ; database xx - #:reconnect ; database - #:find-database ; database xx - #:status ; database xx - #:with-database - #:with-default-database - #:disconnect-pooled - #:create-database - #:destroy-database - #:probe-database - #:list-databases - - #:describe-table - #:*backend-warning-behavior* - - ;; Transactions - #:with-transaction - #:commit-transaction - #:rollback-transaction - #:add-transaction-commit-hook - #:add-transaction-rollback-hook - #:commit ; transact xx - #:rollback ; transact xx - #:with-transaction ; transact xx . - #:start-transaction ; transact xx - #:in-transaction-p ; transact xx - #:database-start-transaction - #:database-abort-transaction - #:database-commit-transaction - #:transaction-level - #:transaction - )) - (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) + ;; Time handling (time.lisp) + #:bad-component + #:current-day + #:current-month + #:current-year + #:day-duration + #:db-timestring + #:decode-duration + #:decode-time + #:duration + #:duration+ + #:duration< + #:duration<= + #:duration= + #:duration> + #:duration>= + #:duration-day + #:duration-hour + #:duration-minute + #:duration-month + #:duration-second + #:duration-year + #:duration-reduce + #:duration-timestring + #:extract-roman + #:format-duration + #:format-time + #:get-time + #:utime->time + #:interval-clear + #:interval-contained + #:interval-data + #:interval-edit + #:interval-end + #:interval-match + #:interval-push + #:interval-relation + #:interval-start + #:interval-type + #:make-duration + #:make-interval + #:make-time + #:merged-time + #:midnight + #:month-name + #:parse-date-time + #:parse-timestring + #:parse-yearstring + #:print-date + #:roll + #:roll-to + #:time + #:time+ + #:time- + #:time-by-adding-duration + #:time-compare + #:time-difference + #:time-dow + #:time-element + #:time-max + #:time-min + #:time-mjd + #:time-msec + #:time-p + #:time-sec + #:time-well-formed + #:time-ymd + #:time< + #:time<= + #:time= + #:time> + #:time>= + #:timezone + #:universal-time + #:wall-time + #:wall-timestring + #:week-containing + #:gregorian-to-mjd + #:mjd-to-gregorian + )) + (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) (defpackage #:clsql diff --git a/sql/transaction.lisp b/sql/transaction.lisp index 6ea37b6..286839b 100644 --- a/sql/transaction.lisp +++ b/sql/transaction.lisp @@ -47,7 +47,7 @@ (when (zerop (decf (transaction-level database))) (execute-command "COMMIT" :database database) (map nil #'funcall (commit-hooks (transaction database)))) - (warn 'clsql-simple-warning + (warn 'sql-warning :format-control "Cannot commit transaction against ~A because there is no transaction in progress." :format-arguments (list database)))) @@ -57,7 +57,7 @@ (unwind-protect (execute-command "ROLLBACK" :database database) (map nil #'funcall (rollback-hooks (transaction database))))) - (warn 'clsql-simple-warning + (warn 'sql-warning :format-control "Cannot abort transaction against ~A because there is no transaction in progress." :format-arguments (list database)))) -- 2.34.1