From: Kevin M. Rosenberg Date: Wed, 7 Apr 2004 14:42:39 +0000 (+0000) Subject: r8848: more usql to clsql renaming X-Git-Tag: v3.8.6~727 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=7f0e4a65d1b425f2fa58fc7cce8296c1a6c52c2f r8848: more usql to clsql renaming --- diff --git a/CONTRIBUTORS b/CONTRIBUTORS index 43bd401..c0d8591 100644 --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -2,7 +2,7 @@ CLSQL Contributors ------------------ Kevin Rosenberg (main author CLSQL) Pierre Mai (original author MaiSQL from which CLSQL was based) -Marcus Pearce (initial port of USQL to CLSQL) +Marcus Pearce (initial port of USQL to CLSQL) Marc Battyani diff --git a/clsql-tests.asd b/clsql-tests.asd new file mode 100644 index 0000000..a9486ac --- /dev/null +++ b/clsql-tests.asd @@ -0,0 +1,38 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; File: clsql-tests.asd +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 12:34:41 marcusp> +;;;; +;;;; $Id: clsql-classic.asd 8847 2004-04-07 14:38:14Z kevin $ +;;;; +;;;; 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 #:cl-user) + +(asdf:defsystem clsql-tests + :name "CLSQL Tests" + :author "" + :maintainer "" + :version "" + :licence "" + :description "A regression test suite for CLSQL-USQL." + :components + ((:module tests + :serial t + :components ((:file "package") + (:file "test-init") + (:file "test-connection") + (:file "test-fddl") + (:file "test-fdml") + (:file "test-ooddl") + (:file "test-oodml") + (:file "test-syntax")))) + :depends-on (:clsql :rt)) diff --git a/clsql-usql-tests.asd b/clsql-usql-tests.asd deleted file mode 100644 index 07cbdbd..0000000 --- a/clsql-usql-tests.asd +++ /dev/null @@ -1,36 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: clsql-usql-tests.asd -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 12:34:41 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; ASDF system definition for CLSQL-USQL test suite. -;;;; -;;;; ====================================================================== - -(in-package #:cl-user) - -(asdf:defsystem :clsql-usql-tests - :name "CLSQL-USQL Tests" - :author "" - :maintainer "" - :version "" - :licence "" - :description "A regression test suite for CLSQL-USQL." - :components - ((:module usql-tests - :serial t - :components ((:file "package") - (:file "test-init") - (:file "test-connection") - (:file "test-fddl") - (:file "test-fdml") - (:file "test-ooddl") - (:file "test-oodml") - (:file "test-syntax")))) - :depends-on (:clsql-usql :rt)) diff --git a/clsql-usql.asd b/clsql-usql.asd deleted file mode 100644 index e10d556..0000000 --- a/clsql-usql.asd +++ /dev/null @@ -1,51 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: usql.asd -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 11:58:21 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; ASDF system definition for CLSQL-USQL. -;;;; -;;;; ====================================================================== - -(asdf:defsystem #:clsql-usql - :name "CLSQL-USQL" - :author "" - :maintainer "" - :version "" - :licence "" - :description "A high level Common Lisp interface to SQL RDBMS." - :long-description "A high level Common Lisp interface to SQL RDBMS -based on the Xanalys CommonSQL interface for Lispworks. It depends on -the low-level database interfaces provided by CLSQL and includes both -a functional and an object oriented interface." - :depends-on (clsql-base) - :components - ((:module usql - :components - ((:module :package - :pathname "" - :components ((:file "package") - (:file "kmr-mop" :depends-on ("package")))) - (:module :core - :pathname "" - :components ((:file "classes") - (:file "operations" :depends-on ("classes")) - (:file "syntax")) - :depends-on (:package)) - (:module :functional - :pathname "" - :components ((:file "sql") - (:file "table")) - :depends-on (:core)) - (:module :object - :pathname "" - :components ((:file "metaclasses") - (:file "objects" :depends-on ("metaclasses"))) - :depends-on (:functional)))))) - diff --git a/clsql.asd b/clsql.asd new file mode 100644 index 0000000..cebcee1 --- /dev/null +++ b/clsql.asd @@ -0,0 +1,52 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: clsql-classic.asd +;;;; Purpose: System definition for CLSQL-CLASSIC +;;;; Authors: Marcus Pearce and Kevin M. Rosenberg +;;;; Created: March 2004 +;;;; +;;;; $Id: clsql-classic.asd 8847 2004-04-07 14:38:14Z kevin $ +;;;; +;;;; 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. +;;;; ************************************************************************* + +(asdf:defsystem #:clsql-usql + :name "CLSQL-USQL" + :author "" + :maintainer "" + :version "" + :licence "" + :description "A high level Common Lisp interface to SQL RDBMS." + :long-description "A high level Common Lisp interface to SQL RDBMS +based on the Xanalys CommonSQL interface for Lispworks. It depends on +the low-level database interfaces provided by CLSQL and includes both +a functional and an object oriented interface." + :depends-on (clsql-base) + :components + ((:module sql + :components + ((:module :package + :pathname "" + :components ((:file "package") + (:file "kmr-mop" :depends-on ("package")))) + (:module :core + :pathname "" + :components ((:file "classes") + (:file "operations" :depends-on ("classes")) + (:file "syntax")) + :depends-on (:package)) + (:module :functional + :pathname "" + :components ((:file "sql") + (:file "table")) + :depends-on (:core)) + (:module :object + :pathname "" + :components ((:file "metaclasses") + (:file "objects" :depends-on ("metaclasses"))) + :depends-on (:functional)))))) + diff --git a/sql/README b/sql/README new file mode 100644 index 0000000..c0ea747 --- /dev/null +++ b/sql/README @@ -0,0 +1,64 @@ +INTRODUCTIION + +CLSQL-USQL is a high level SQL interface for Common Lisp which is +based on the CommonSQL package from Xanalys. It was originally +developed at Onshore Development, Inc. based on Pierre Mai's MaiSQL +package. It now incorporates some of the code developed for CLSQL. See +the files CONTRIBUTORS and COPYING for more details. + +CLSQL-USQL depends on the low-level database interfaces provided by +CLSQL and includes both a functional and an object oriented +interface to SQL RDBMS. + +DOCUMENTATION + +A CLSQL-USQL tutorial can be found in the directory doc/ + +Also see the CommonSQL documentation avaialble on the Lispworks website: + +Xanalys LispWorks User Guide - The CommonSQL Package +http://www.lispworks.com/reference/lw43/LWUG/html/lwuser-167.htm + +Xanalys LispWorks Reference Manual -- The SQL Package +http://www.lispworks.com/reference/lw43/LWRM/html/lwref-383.htm + +CommonSQL Tutorial by Nick Levine +http://www.ravenbrook.com/doc/2002/09/13/common-sql/ + + +PREREQUISITES + + o COMMON LISP: currently CMUCL, SBCL, Lispworks + o RDBMS: currently Postgresql, Mysql, Sqlite + o ASDF (from http://cvs.sourceforge.net/viewcvs.py/cclan/asdf/) + o CLSQL-2.0.0 or later (from http://clsql.b9.com) + o RT for running the test suite (from http://files.b9.com/rt/rt.tar.gz) + + +INSTALLATION + +Just load clsql-usql.asd or put it somewhere where ASDF can find it +and call: + +(asdf:oos 'asdf:load-op :clsql-usql) + +You'll then need to load a CLSQL backend before you can do anything. + +To run the regression tests load clsql-usql-tests.asd or put it +somewhere where ASDF can find it, edit the file tests/test-init.lisp +and set the following variables to appropriate values: + + *test-database-server* + *test-database-name* + *test-database-user* + *test-database-password* + +And then call: + +(asdf:oos 'asdf:load-op :clsql-usql-tests) +(usql-tests:test-usql BACKEND) + +where BACKEND is the CLSQL database interface to use (currently one of +:postgresql, :postgresql-socket, :sqlite or :mysql). + + diff --git a/sql/basic-cmds.lisp b/sql/basic-cmds.lisp new file mode 100644 index 0000000..a8241b9 --- /dev/null +++ b/sql/basic-cmds.lisp @@ -0,0 +1,32 @@ + +(defmethod database-query (query-expression (database closed-database) types) + (declare (ignore query-expression types)) + (signal-closed-database-error database)) + +(defmethod database-query (query-expression (database t) types) + (declare (ignore query-expression types)) + (signal-no-database-error)) + +(defmethod database-execute-command (sql-expression (database closed-database)) + (declare (ignore sql-expression)) + (signal-closed-database-error database)) + +(defmethod database-execute-command (sql-expression (database t)) + (declare (ignore sql-expression)) + (signal-no-database-error)) + +(defgeneric execute-command (expression &key database) + (:documentation + "Executes the SQL command specified by EXPRESSION for the database +specified by DATABASE, which has a default value of +*DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement +other than a query. To run a stored procedure, pass an appropriate +string. The call to the procedure needs to be wrapped in a BEGIN END +pair.")) + +(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)) diff --git a/sql/classes.lisp b/sql/classes.lisp new file mode 100644 index 0000000..c390c5f --- /dev/null +++ b/sql/classes.lisp @@ -0,0 +1,737 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: classes.lisp +;;;; Updated: <04/04/2004 12:08:49 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Classes defining SQL expressions and methods for formatting the +;;;; appropriate SQL commands. +;;;; +;;;; ====================================================================== + +(in-package #:clsql-usql-sys) + + +(defvar +empty-string+ "''") + +(defvar +null-string+ "NULL") + +(defvar *sql-stream* nil + "stream which accumulates SQL output") + +(defvar *default-schema* "UNCOMMONSQL") + +(defvar *object-schemas* (make-hash-table :test #'equal) + "Hash of schema name to class constituent lists.") + +(defun in-schema (schemaname) + (setf *default-schema* schemaname)) + +(defun sql-output (sql-expr &optional database) + (progv '(*sql-stream*) + `(,(make-string-output-stream)) + (output-sql sql-expr database) + (get-output-stream-string *sql-stream*))) + + +(defclass %sql-expression () + ()) + +(defmethod output-sql ((expr %sql-expression) &optional + (database *default-database*)) + (declare (ignore database)) + (write-string +null-string+ *sql-stream*)) + +(defmethod print-object ((self %sql-expression) stream) + (print-unreadable-object + (self stream :type t) + (write-string (sql-output self) stream))) + +;; For straight up strings + +(defclass sql (%sql-expression) + ((text + :initarg :string + :initform "")) + (:documentation "A literal SQL expression.")) + +(defmethod make-load-form ((sql sql) &optional environment) + (declare (ignore environment)) + (with-slots (text) + sql + `(make-instance 'sql :string ',text))) + +(defmethod output-sql ((expr sql) &optional (database *default-database*)) + (declare (ignore database)) + (write-string (slot-value expr 'text) *sql-stream*) + t) + +(defmethod print-object ((ident sql) stream) + (format stream "#<~S \"~A\">" + (type-of ident) + (sql-output ident))) + +;; For SQL Identifiers of generic type +(defclass sql-ident (%sql-expression) + ((name + :initarg :name + :initform "NULL")) + (:documentation "An SQL identifer.")) + +(defmethod make-load-form ((sql sql-ident) &optional environment) + (declare (ignore environment)) + (with-slots (name) + sql + `(make-instance 'sql-ident :name ',name))) + +(defvar *output-hash* (make-hash-table :test #'equal)) + +(defmethod output-sql-hash-key (expr &optional (database *default-database*)) + (declare (ignore expr database)) + nil) + +(defmethod output-sql :around ((sql t) &optional (database *default-database*)) + (declare (ignore database)) + (let* ((hash-key (output-sql-hash-key sql)) + (hash-value (when hash-key (gethash hash-key *output-hash*)))) + (cond ((and hash-key hash-value) + (write-string hash-value *sql-stream*)) + (hash-key + (let ((*sql-stream* (make-string-output-stream))) + (call-next-method) + (setf hash-value (get-output-stream-string *sql-stream*)) + (setf (gethash hash-key *output-hash*) hash-value)) + (write-string hash-value *sql-stream*)) + (t + (call-next-method))))) + +(defmethod output-sql ((expr sql-ident) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (name) + expr + (etypecase name + (string + (write-string name *sql-stream*)) + (symbol + (write-string (symbol-name name) *sql-stream*))) + t)) + +;; For SQL Identifiers for attributes + +(defclass sql-ident-attribute (sql-ident) + ((qualifier + :initarg :qualifier + :initform "NULL") + (type + :initarg :type + :initform "NULL") + (params + :initarg :params + :initform nil)) + (:documentation "An SQL Attribute identifier.")) + +(defmethod collect-table-refs (sql) + (declare (ignore sql)) + nil) + +(defmethod collect-table-refs ((sql sql-ident-attribute)) + (let ((qual (slot-value sql 'qualifier))) + (if (and qual (symbolp (slot-value sql 'qualifier))) + (list (make-instance 'sql-ident-table :name + (slot-value sql 'qualifier)))))) + +(defmethod make-load-form ((sql sql-ident-attribute) &optional environment) + (declare (ignore environment)) + (with-slots (qualifier type name) + sql + `(make-instance 'sql-ident-attribute :name ',name + :qualifier ',qualifier + :type ',type))) + +(defmethod output-sql ((expr sql-ident-attribute) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (qualifier name type params) + expr + (if (and name (not qualifier) (not type)) + (write-string (sql-escape (symbol-name name)) *sql-stream*) + (format *sql-stream* "~@[~A.~]~A~@[ ~A~]" + (if qualifier (sql-escape qualifier) qualifier) + (sql-escape name) + type)) + t)) + +(defmethod output-sql-hash-key ((expr sql-ident-attribute) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (qualifier name type params) + expr + (list 'sql-ident-attribute qualifier name type params))) + +;; For SQL Identifiers for tables +(defclass sql-ident-table (sql-ident) + ((alias + :initarg :table-alias :initform nil)) + (:documentation "An SQL table identifier.")) + +(defmethod make-load-form ((sql sql-ident-table) &optional environment) + (declare (ignore environment)) + (with-slots (alias name) + sql + `(make-instance 'sql-ident-table :name name :alias ',alias))) + +(defun generate-sql (expr) + (let ((*sql-stream* (make-string-output-stream))) + (output-sql expr) + (get-output-stream-string *sql-stream*))) + +(defmethod output-sql ((expr sql-ident-table) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (name alias) + expr + (if (null alias) + (write-string (sql-escape (symbol-name name)) *sql-stream*) + (progn + (write-string (sql-escape (symbol-name name)) *sql-stream*) + (write-char #\Space *sql-stream*) + (format *sql-stream* "~s" alias)))) + t) + +(defmethod output-sql-hash-key ((expr sql-ident-table) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (name alias) + expr + (list 'sql-ident-table name alias))) + +(defclass sql-relational-exp (%sql-expression) + ((operator + :initarg :operator + :initform nil) + (sub-expressions + :initarg :sub-expressions + :initform nil)) + (:documentation "An SQL relational expression.")) + +(defmethod collect-table-refs ((sql sql-relational-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'sub-expressions)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name)))))) + + + + +;; Write SQL for relational operators (like 'AND' and 'OR'). +;; should do arity checking of subexpressions + +(defmethod output-sql ((expr sql-relational-exp) &optional + (database *default-database*)) + (with-slots (operator sub-expressions) + expr + (let ((subs (if (consp (car sub-expressions)) + (car sub-expressions) + sub-expressions))) + (write-char #\( *sql-stream*) + (do ((sub subs (cdr sub))) + ((null (cdr sub)) (output-sql (car sub) database)) + (output-sql (car sub) database) + (write-char #\Space *sql-stream*) + (output-sql operator database) + (write-char #\Space *sql-stream*)) + (write-char #\) *sql-stream*))) + t) + +(defclass sql-upcase-like (sql-relational-exp) + () + (:documentation "An SQL 'like' that upcases its arguments.")) + +;; Write SQL for relational operators (like 'AND' and 'OR'). +;; should do arity checking of subexpressions + +(defmethod output-sql ((expr sql-upcase-like) &optional + (database *default-database*)) + (flet ((write-term (term) + (write-string "upper(" *sql-stream*) + (output-sql term database) + (write-char #\) *sql-stream*))) + (with-slots (sub-expressions) + expr + (let ((subs (if (consp (car sub-expressions)) + (car sub-expressions) + sub-expressions))) + (write-char #\( *sql-stream*) + (do ((sub subs (cdr sub))) + ((null (cdr sub)) (write-term (car sub))) + (write-term (car sub)) + (write-string " LIKE " *sql-stream*)) + (write-char #\) *sql-stream*)))) + t) + +(defclass sql-assignment-exp (sql-relational-exp) + () + (:documentation "An SQL Assignment expression.")) + + +(defmethod output-sql ((expr sql-assignment-exp) &optional + (database *default-database*)) + (with-slots (operator sub-expressions) + expr + (do ((sub sub-expressions (cdr sub))) + ((null (cdr sub)) (output-sql (car sub) database)) + (output-sql (car sub) database) + (write-char #\Space *sql-stream*) + (output-sql operator database) + (write-char #\Space *sql-stream*))) + t) + +(defclass sql-value-exp (%sql-expression) + ((modifier + :initarg :modifier + :initform nil) + (components + :initarg :components + :initform nil)) + (:documentation + "An SQL value expression.") + ) + +(defmethod collect-table-refs ((sql sql-value-exp)) + (let ((tabs nil)) + (if (listp (slot-value sql 'components)) + (progn + (dolist (exp (slot-value sql 'components)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name))))) + nil))) + + + +(defmethod output-sql ((expr sql-value-exp) &optional + (database *default-database*)) + (with-slots (modifier components) + expr + (if modifier + (progn + (write-char #\( *sql-stream*) + (output-sql modifier database) + (write-char #\Space *sql-stream*) + (output-sql components database) + (write-char #\) *sql-stream*)) + (output-sql components database)))) + +(defclass sql-typecast-exp (sql-value-exp) + () + (:documentation "An SQL typecast expression.")) + +(defmethod output-sql ((expr sql-typecast-exp) &optional + (database *default-database*)) + (database-output-sql expr database)) + +(defmethod database-output-sql ((expr sql-typecast-exp) database) + (with-slots (components) + expr + (output-sql components database))) + + +(defmethod collect-table-refs ((sql sql-typecast-exp)) + (when (slot-value sql 'components) + (collect-table-refs (slot-value sql 'components)))) + +(defclass sql-function-exp (%sql-expression) + ((name + :initarg :name + :initform nil) + (args + :initarg :args + :initform nil)) + (:documentation + "An SQL function expression.")) + +(defmethod collect-table-refs ((sql sql-function-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'components)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name)))))) + +(defmethod output-sql ((expr sql-function-exp) &optional + (database *default-database*)) + (with-slots (name args) + expr + (output-sql name database) + (when args (output-sql args database))) + t) + +(defclass sql-query (%sql-expression) + ((selections + :initarg :selections + :initform nil) + (all + :initarg :all + :initform nil) + (flatp + :initarg :flatp + :initform nil) + (set-operation + :initarg :set-operation + :initform nil) + (distinct + :initarg :distinct + :initform nil) + (from + :initarg :from + :initform nil) + (where + :initarg :where + :initform nil) + (group-by + :initarg :group-by + :initform nil) + (having + :initarg :having + :initform nil) + (limit + :initarg :limit + :initform nil) + (offset + :initarg :offset + :initform nil) + (order-by + :initarg :order-by + :initform nil) + (order-by-descending + :initarg :order-by-descending + :initform nil)) + (:documentation "An SQL SELECT query.")) + +(defmethod collect-table-refs ((sql sql-query)) + (remove-duplicates (collect-table-refs (slot-value sql 'where)) + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name))))) + +(defvar *select-arguments* + '(:all :database :distinct :flatp :from :group-by :having :order-by + :order-by-descending :set-operation :where :offset :limit)) + +(defun query-arg-p (sym) + (member sym *select-arguments*)) + +(defun query-get-selections (select-args) + "Return two values: the list of select-args up to the first keyword, +uninclusive, and the args from that keyword to the end." + (let ((first-key-arg (position-if #'query-arg-p select-args))) + (if first-key-arg + (values (subseq select-args 0 first-key-arg) + (subseq select-args first-key-arg)) + select-args))) + +(defmethod make-query (&rest args) + (multiple-value-bind (selections arglist) + (query-get-selections args) + (destructuring-bind (&key all flatp set-operation distinct from where + group-by having order-by order-by-descending + offset limit &allow-other-keys) + arglist + (if (null selections) + (error "No target columns supplied to select statement.")) + (if (null from) + (error "No source tables supplied to select statement.")) + (make-instance 'sql-query :selections selections + :all all :flatp flatp :set-operation set-operation + :distinct distinct :from from :where where + :limit limit :offset offset + :group-by group-by :having having :order-by order-by + :order-by-descending order-by-descending)))) + +(defvar *in-subselect* nil) + +(defmethod output-sql ((query sql-query) &optional + (database *default-database*)) + (with-slots (distinct selections from where group-by having order-by + order-by-descending limit offset) + query + (when *in-subselect* + (write-string "(" *sql-stream*)) + (write-string "SELECT " *sql-stream*) + (when distinct + (write-string "DISTINCT " *sql-stream*) + (unless (eql t distinct) + (write-string "ON " *sql-stream*) + (output-sql distinct database) + (write-char #\Space *sql-stream*))) + (output-sql (apply #'vector selections) database) + (write-string " FROM " *sql-stream*) + (if (listp from) + (output-sql (apply #'vector from) database) + (output-sql from database)) + (when where + (write-string " WHERE " *sql-stream*) + (let ((*in-subselect* t)) + (output-sql where database))) + (when group-by + (write-string " GROUP BY " *sql-stream*) + (output-sql group-by database)) + (when having + (write-string " HAVING " *sql-stream*) + (output-sql having database)) + (when order-by + (write-string " ORDER BY " *sql-stream*) + (if (listp order-by) + (do ((order order-by (cdr order))) + ((null order)) + (output-sql (car order) database) + (when (cdr order) + (write-char #\, *sql-stream*))) + (output-sql order-by database))) + (when order-by-descending + (write-string " ORDER BY " *sql-stream*) + (if (listp order-by-descending) + (do ((order order-by-descending (cdr order))) + ((null order)) + (output-sql (car order) database) + (when (cdr order) + (write-char #\, *sql-stream*))) + (output-sql order-by-descending database)) + (write-string " DESC " *sql-stream*)) + (when limit + (write-string " LIMIT " *sql-stream*) + (output-sql limit database)) + (when offset + (write-string " OFFSET " *sql-stream*) + (output-sql offset database)) + (when *in-subselect* + (write-string ")" *sql-stream*))) + t) + +;; INSERT + +(defclass sql-insert (%sql-expression) + ((into + :initarg :into + :initform nil) + (attributes + :initarg :attributes + :initform nil) + (values + :initarg :values + :initform nil) + (query + :initarg :query + :initform nil)) + (:documentation + "An SQL INSERT statement.")) + +(defmethod output-sql ((ins sql-insert) &optional + (database *default-database*)) + (with-slots (into attributes values query) + ins + (write-string "INSERT INTO " *sql-stream*) + (output-sql into database) + (when attributes + (write-char #\Space *sql-stream*) + (output-sql attributes database)) + (when values + (write-string " VALUES " *sql-stream*) + (output-sql values database)) + (when query + (write-char #\Space *sql-stream*) + (output-sql query database))) + t) + +;; DELETE + +(defclass sql-delete (%sql-expression) + ((from + :initarg :from + :initform nil) + (where + :initarg :where + :initform nil)) + (:documentation + "An SQL DELETE statement.")) + +(defmethod output-sql ((stmt sql-delete) &optional + (database *default-database*)) + (with-slots (from where) + stmt + (write-string "DELETE FROM " *sql-stream*) + (typecase from + (symbol (write-string (sql-escape from) *sql-stream*)) + (t (output-sql from database))) + (when where + (write-string " WHERE " *sql-stream*) + (output-sql where database))) + t) + +;; UPDATE + +(defclass sql-update (%sql-expression) + ((table + :initarg :table + :initform nil) + (attributes + :initarg :attributes + :initform nil) + (values + :initarg :values + :initform nil) + (where + :initarg :where + :initform nil)) + (:documentation "An SQL UPDATE statement.")) + +(defmethod output-sql ((expr sql-update) &optional + (database *default-database*)) + (with-slots (table where attributes values) + expr + (flet ((update-assignments () + (mapcar #'(lambda (a b) + (make-instance 'sql-assignment-exp + :operator '= + :sub-expressions (list a b))) + attributes values))) + (write-string "UPDATE " *sql-stream*) + (output-sql table database) + (write-string " SET " *sql-stream*) + (output-sql (apply #'vector (update-assignments)) database) + (when where + (write-string " WHERE " *sql-stream*) + (output-sql where database)))) + t) + +;; CREATE TABLE + +(defclass sql-create-table (%sql-expression) + ((name + :initarg :name + :initform nil) + (columns + :initarg :columns + :initform nil) + (modifiers + :initarg :modifiers + :initform nil)) + (:documentation + "An SQL CREATE TABLE statement.")) + +;; Here's a real warhorse of a function! + +(defun listify (x) + (if (atom x) + (list x) + x)) + +(defmethod output-sql ((stmt sql-create-table) &optional + (database *default-database*)) + (flet ((output-column (column-spec) + (destructuring-bind (name type &rest constraints) + column-spec + (let ((type (listify type))) + (output-sql name database) + (write-char #\Space *sql-stream*) + (write-string + (database-get-type-specifier (car type) (cdr type) database) + *sql-stream*) + (let ((constraints + (database-constraint-statement constraints database))) + (when constraints + (write-string " " *sql-stream*) + (write-string constraints *sql-stream*))))))) + (with-slots (name columns modifiers) + stmt + (write-string "CREATE TABLE " *sql-stream*) + (output-sql name database) + (write-string " (" *sql-stream*) + (do ((column columns (cdr column))) + ((null (cdr column)) + (output-column (car column))) + (output-column (car column)) + (write-string ", " *sql-stream*)) + (when modifiers + (do ((modifier (listify modifiers) (cdr modifier))) + ((null modifier)) + (write-string ", " *sql-stream*) + (write-string (car modifier) *sql-stream*))) + (write-char #\) *sql-stream*))) + t) + + +;; CREATE VIEW + +(defclass sql-create-view (%sql-expression) + ((name :initarg :name :initform nil) + (column-list :initarg :column-list :initform nil) + (query :initarg :query :initform nil) + (with-check-option :initarg :with-check-option :initform nil)) + (:documentation "An SQL CREATE VIEW statement.")) + +(defmethod output-sql ((stmt sql-create-view) &optional database) + (with-slots (name column-list query with-check-option) stmt + (write-string "CREATE VIEW " *sql-stream*) + (output-sql name database) + (when column-list (write-string " " *sql-stream*) + (output-sql (listify column-list) database)) + (write-string " AS " *sql-stream*) + (output-sql query database) + (when with-check-option (write-string " WITH CHECK OPTION" *sql-stream*)))) + + +;; +;; Column constraint types +;; +(defparameter *constraint-types* + '(("NOT-NULL" . "NOT NULL") + ("PRIMARY-KEY" . "PRIMARY KEY"))) + +;; +;; Convert type spec to sql syntax +;; + +(defmethod database-constraint-description (constraint database) + (declare (ignore database)) + (let ((output (assoc (symbol-name constraint) *constraint-types* + :test #'equal))) + (if (null output) + (error 'clsql-sql-syntax-error + :reason (format nil "unsupported column constraint '~a'" + constraint)) + (cdr output)))) + +(defmethod database-constraint-statement (constraint-list database) + (declare (ignore database)) + (make-constraints-description constraint-list)) + +(defun make-constraints-description (constraint-list) + (if constraint-list + (let ((string "")) + (do ((constraint constraint-list (cdr constraint))) + ((null constraint) string) + (let ((output (assoc (symbol-name (car constraint)) + *constraint-types* + :test #'equal))) + (if (null output) + (error 'clsql-sql-syntax-error + :reason (format nil "unsupported column constraint '~a'" + constraint)) + (setq string (concatenate 'string string (cdr output)))) + (if (< 1 (length constraint)) + (setq string (concatenate 'string string " ")))))))) + diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp new file mode 100644 index 0000000..32cc35d --- /dev/null +++ b/sql/kmr-mop.lisp @@ -0,0 +1,48 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: kmr-mop.lisp +;;;; Purpose: MOP support for multiple-implementions +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Apr 2003 +;;;; +;;;; $Id: mop.lisp 8573 2004-01-29 23:30:50Z kevin $ +;;;; +;;;; This file was extracted from the KMRCL utilities +;;;; ************************************************************************* + +;;; This file imports MOP symbols into the USQL-MOP package and then +;;; re-exports into CLSQL-USQL-SYS them to hide differences in +;;; MOP implementations. + +(in-package #:clsql-usql-sys) + +#+lispworks +(defun intern-eql-specializer (slot) + `(eql ,slot)) + +(defmacro process-class-option (metaclass slot-name &optional required) + #+lispworks + `(defmethod clos:process-a-class-option ((class ,metaclass) + (name (eql ,slot-name)) + value) + (when (and ,required (null value)) + (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name)) + (list name `',value)) + #-lispworks + (declare (ignore metaclass slot-name required)) + ) + +(defmacro process-slot-option (metaclass slot-name) + #+lispworks + `(defmethod clos:process-a-slot-option ((class ,metaclass) + (option (eql ,slot-name)) + value + already-processed-options + slot) + (list* option `',value already-processed-options)) + #-lispworks + (declare (ignore metaclass slot-name)) + ) + diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp new file mode 100644 index 0000000..60679fb --- /dev/null +++ b/sql/metaclasses.lisp @@ -0,0 +1,528 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: metaclasses.lisp +;;;; Updated: <04/04/2004 12:08:11 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; CLSQL-USQL metaclass for standard-db-objects created in the OODDL. +;;;; +;;;; ====================================================================== + + +(in-package #:clsql-usql-sys) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'compute-effective-slot-definition))) + 3) + (pushnew :kmr-normal-cesd cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'direct-slot-definition-class))) + 3) + (pushnew :kmr-normal-dsdc cl:*features*)) + + (when (>= (length (generic-function-lambda-list + (ensure-generic-function + 'effective-slot-definition-class))) + 3) + (pushnew :kmr-normal-esdc cl:*features*))) + + +;; ------------------------------------------------------------ +;; metaclass: view-class + +(defclass standard-db-class (standard-class) + ((view-table + :accessor view-table + :initarg :view-table) + (definition + :accessor object-definition + :initarg :definition + :initform nil) + (version + :accessor object-version + :initarg :version + :initform 0) + (key-slots + :accessor key-slots + :initform nil) + (class-qualifier + :accessor view-class-qualifier + :initarg :qualifier + :initform nil)) + (:documentation "VIEW-CLASS metaclass.")) + +#+lispworks +(defmacro push-on-end (value location) + `(setf ,location (nconc ,location (list ,value)))) + +;; As Heiko Kirscke (author of PLOB!) would say: !@##^@%! Lispworks! +#+lispworks +(defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok + :db-writer :db-type :db-info)) + +#+lispworks +(define-setf-expander assoc (key alist &environment env) + (multiple-value-bind (temps vals stores store-form access-form) + (get-setf-expansion alist env) + (let ((new-value (gensym "NEW-VALUE-")) + (keyed (gensym "KEYED-")) + (accessed (gensym "ACCESSED-")) + (store-new-value (car stores))) + (values (cons keyed temps) + (cons key vals) + `(,new-value) + `(let* ((,accessed ,access-form) + (,store-new-value (assoc ,keyed ,accessed))) + (if ,store-new-value + (rplacd ,store-new-value ,new-value) + (progn + (setq ,store-new-value + (acons ,keyed ,new-value ,accessed)) + ,store-form)) + ,new-value) + `(assoc ,new-value ,access-form))))) + +#+lispworks +(defmethod clos::canonicalize-defclass-slot :around + ((prototype standard-db-class) slot) + "\\lw\\ signals an error on unknown slot options; so this method +removes any extra allowed options before calling the default method +and returns the canonicalized extra options concatenated to the result +of the default method. The extra allowed options are the value of the +\\fcite{+extra-slot-options+}." + (let ((extra-slot-options ()) + (rest-options ()) + (result ())) + (do ((olist (cdr slot) (cddr olist))) + ((null olist)) + (let ((option (car olist))) + (cond + ((find option +extra-slot-options+) + ;;(push (cons option (cadr olist)) extra-slot-options)) + (setf (assoc option extra-slot-options) (cadr olist))) + (t + (push (cadr olist) rest-options) + (push (car olist) rest-options))))) + (setf result (call-next-method prototype (cons (car slot) rest-options))) + (dolist (option extra-slot-options) + (push-on-end (car option) result) + (push-on-end `(quote ,(cdr option)) result)) + result)) + +#+lispworks +(defconstant +extra-class-options+ '(:base-table :version :schemas)) + +#+lispworks +(defmethod clos::canonicalize-class-options :around + ((prototype standard-db-class) class-options) + "\\lw\\ signals an error on unknown class options; so this method +removes any extra allowed options before calling the default method +and returns the canonicalized extra options concatenated to the result +of the default method. The extra allowed options are the value of the +\\fcite{+extra-class-options+}." + (let ((extra-class-options nil) + (rest-options ()) + (result ())) + (dolist (o class-options) + (let ((option (car o))) + (cond + ((find option +extra-class-options+) + ;;(push (cons option (cadr o)) extra-class-options)) + (setf (assoc option extra-class-options) (cadr o))) + (t + (push o rest-options))))) + (setf result (call-next-method prototype rest-options)) + (dolist (option extra-class-options) + (push-on-end (car option) result) + (push-on-end `(quote ,(cdr option)) result)) + result)) + + +(defmethod validate-superclass ((class standard-db-class) + (superclass standard-class)) + t) + +(defun table-name-from-arg (arg) + (cond ((symbolp arg) + arg) + ((typep arg 'sql-ident) + (slot-value arg 'name)) + ((stringp arg) + (intern (string-upcase arg))))) + +(defun column-name-from-arg (arg) + (cond ((symbolp arg) + arg) + ((typep arg 'sql-ident) + (slot-value arg 'name)) + ((stringp arg) + (intern (string-upcase arg))))) + + +(defun remove-keyword-arg (arglist akey) + (let ((mylist arglist) + (newlist ())) + (labels ((pop-arg (alist) + (let ((arg (pop alist)) + (val (pop alist))) + (unless (equal arg akey) + (setf newlist (append (list arg val) newlist))) + (when alist (pop-arg alist))))) + (pop-arg mylist)) + newlist)) + +(defmethod initialize-instance :around ((class standard-db-class) + &rest all-keys + &key direct-superclasses base-table + schemas version qualifier + &allow-other-keys) + (let ((root-class (find-class 'standard-db-object nil)) + (vmc (find-class 'standard-db-class))) + (setf (view-class-qualifier class) + (car qualifier)) + (if root-class + (if (member-if #'(lambda (super) + (eq (class-of super) vmc)) direct-superclasses) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses (append (list root-class) + direct-superclasses) + (remove-keyword-arg all-keys :direct-superclasses))) + (call-next-method)) + (setf (view-table class) + (table-name-from-arg (sql-escape (or (and base-table + (if (listp base-table) + (car base-table) + base-table)) + (class-name class))))) + (setf (object-version class) version) + (mapc (lambda (schema) + (pushnew (class-name class) (gethash schema *object-schemas*))) + (if (listp schemas) schemas (list schemas))) + (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 schemas version + direct-superclasses qualifier + &allow-other-keys) + (let ((root-class (find-class 'standard-db-object nil)) + (vmc (find-class 'standard-db-class))) + (setf (view-table class) + (table-name-from-arg (sql-escape (or (and base-table + (if (listp base-table) + (car base-table) + base-table)) + (class-name class))))) + (setf (view-class-qualifier class) + (car qualifier)) + (if (and root-class (not (equal class root-class))) + (if (member-if #'(lambda (super) + (eq (class-of super) vmc)) direct-superclasses) + (call-next-method) + (apply #'call-next-method + class + :direct-superclasses (append (list root-class) + direct-superclasses) + (remove-keyword-arg all-keys :direct-superclasses))) + (call-next-method))) + (setf (object-version class) version) + (mapc (lambda (schema) + (pushnew (class-name class) (gethash schema *object-schemas*))) + (if (listp schemas) schemas (list schemas))) + (register-metaclass class (nth (1+ (position :direct-slots all-keys)) + all-keys))) + + +(defun get-keywords (keys list) + (flet ((extract (key) + (let ((pos (position key list))) + (when pos + (nth (1+ pos) list))))) + (mapcar #'extract keys))) + +(defun describe-db-layout (class) + (flet ((not-db-col (col) + (not (member (nth 2 col) '(nil :base :key)))) + (frob-slot (slot) + (let ((type (slot-value slot 'type))) + (if (eq type t) + (setq type nil)) + (list (slot-value slot 'name) + type + (slot-value slot 'db-kind) + (and (slot-boundp slot 'column) + (slot-value slot 'column)))))) + (let ((all-slots (mapcar #'frob-slot (class-slots class)))) + (setq all-slots (remove-if #'not-db-col all-slots)) + (setq all-slots (stable-sort all-slots #'string< :key #'car)) + ;;(mapcar #'dink-type all-slots) + all-slots))) + +(defun register-metaclass (class slots) + (labels ((not-db-col (col) + (not (member (nth 2 col) '(nil :base :key)))) + (frob-slot (slot) + (get-keywords '(:name :type :db-kind :column) slot))) + (let ((all-slots (mapcar #'frob-slot slots))) + (setq all-slots (remove-if #'not-db-col all-slots)) + (setq all-slots (stable-sort all-slots #'string< :key #'car)) + (setf (object-definition class) all-slots)) + #-(or allegro openmcl) + (setf (key-slots class) (remove-if-not (lambda (slot) + (eql (slot-value slot 'db-kind) + :key)) + (class-slots class))))) + +#+(or allegro openmcl) +(defmethod finalize-inheritance :after ((class standard-db-class)) + (setf (key-slots class) (remove-if-not (lambda (slot) + (eql (slot-value slot 'db-kind) + :key)) + (class-slots class)))) + +;; return the deepest view-class ancestor for a given view class + +(defun base-db-class (classname) + (let* ((class (find-class classname)) + (db-class (find-class 'standard-db-object))) + (loop + (let ((cds (class-direct-superclasses class))) + (cond ((null cds) + (error "not a db class")) + ((member db-class cds) + (return (class-name class)))) + (setq class (car cds)))))) + +(defun db-ancestors (classname) + (let ((class (find-class classname)) + (db-class (find-class 'standard-db-object))) + (labels ((ancestors (class) + (let ((scs (class-direct-superclasses class))) + (if (member db-class scs) + (list class) + (append (list class) (mapcar #'ancestors scs)))))) + (ancestors class)))) + +(defclass view-class-slot-definition-mixin () + ((column + :accessor view-class-slot-column + :initarg :column + :documentation + "The name of the SQL column this slot is stored in. Defaults to +the slot name.") + (db-kind + :accessor view-class-slot-db-kind + :initarg :db-kind + :initform :base + :type keyword + :documentation + "The kind of DB mapping which is performed for this slot. :base +indicates the slot maps to an ordinary column of the DB view. :key +indicates that this slot corresponds to part of the unique keys for +this view, :join indicates ... and :virtual indicates that this slot +is an ordinary CLOS slot. Defaults to :base.") + (db-reader + :accessor view-class-slot-db-reader + :initarg :db-reader + :initform nil + :documentation + "If a string, then when reading values from the DB, the string +will be used for a format string, with the only value being the value +from the database. The resulting string will be used as the slot +value. If a function then it will take one argument, the value from +the database, and return the value that should be put into the slot.") + (db-writer + :accessor view-class-slot-db-writer + :initarg :db-writer + :initform nil + :documentation + "If a string, then when reading values from the slot for the DB, +the string will be used for a format string, with the only value being +the value of the slot. The resulting string will be used as the +column value in the DB. If a function then it will take one argument, +the value of the slot, and return the value that should be put into +the database.") + (db-type + :accessor view-class-slot-db-type + :initarg :db-type + :initform nil + :documentation + "A string which will be used as the type specifier for this slots +column definition in the database.") + (db-constraints + :accessor view-class-slot-db-constraints + :initarg :db-constraints + :initform nil + :documentation + "A single constraint or list of constraints for this column") + (nulls-ok + :accessor view-class-slot-nulls-ok + :initarg :nulls-ok + :initform nil + :documentation + "If t, all sql NULL values retrieved from the database become nil; if nil, +all NULL values retrieved are converted by DATABASE-NULL-VALUE") + (db-info + :accessor view-class-slot-db-info + :initarg :db-info + :documentation "Description of the join."))) + +(defparameter *db-info-lambda-list* + '(&key join-class + home-key + foreign-key + (key-join nil) + (target-slot nil) + (retrieval :immmediate) + (set nil))) + +(defun parse-db-info (db-info-list) + (destructuring-bind + (&key join-class home-key key-join foreign-key (delete-rule nil) + (target-slot nil) (retrieval :deferred) (set nil)) + db-info-list + (let ((ih (make-hash-table :size 6))) + (if join-class + (setf (gethash :join-class ih) join-class) + (error "Must specify :join-class in :db-info")) + (if home-key + (setf (gethash :home-key ih) home-key) + (error "Must specify :home-key in :db-info")) + (when delete-rule + (setf (gethash :delete-rule ih) delete-rule)) + (if foreign-key + (setf (gethash :foreign-key ih) foreign-key) + (error "Must specify :foreign-key in :db-info")) + (when key-join + (setf (gethash :key-join ih) t)) + (when target-slot + (setf (gethash :target-slot ih) target-slot)) + (when set + (setf (gethash :set ih) set)) + (when retrieval + (progn + (setf (gethash :retrieval ih) retrieval) + (if (eql retrieval :immediate) + (setf (gethash :set ih) nil)))) + ih))) + +(defclass view-class-direct-slot-definition (view-class-slot-definition-mixin + standard-direct-slot-definition) + ()) + +(defclass view-class-effective-slot-definition (view-class-slot-definition-mixin + standard-effective-slot-definition) + ()) + +(defmethod direct-slot-definition-class ((class standard-db-class) + #+kmr-normal-dsdc &rest + initargs) + (declare (ignore initargs)) + (find-class 'view-class-direct-slot-definition)) + +(defmethod effective-slot-definition-class ((class standard-db-class) + #+kmr-normal-esdc &rest + initargs) + (declare (ignore initargs)) + (find-class 'view-class-effective-slot-definition)) + +;; Compute the slot definition for slots in a view-class. Figures out +;; what kind of database value (if any) is stored there, generates and +;; verifies the column name. + +(defmethod compute-effective-slot-definition ((class standard-db-class) + #+kmr-normal-cesd slot-name + direct-slots) + #+kmr-normal-cesd (declare (ignore slot-name)) + (let ((slotd (call-next-method)) + (sd (car direct-slots))) + + (typecase sd + (view-class-slot-definition-mixin + ;; Use the specified :column argument if it is supplied, otherwise + ;; the column slot is filled in with the slot-name, but transformed + ;; to be sql safe, - to _ and such. + (setf (slot-value slotd 'column) + (column-name-from-arg + (if (slot-boundp sd 'column) + (view-class-slot-column sd) + (column-name-from-arg + (sql-escape (slot-definition-name sd)))))) + + (setf (slot-value slotd 'db-type) + (when (slot-boundp sd 'db-type) + (view-class-slot-db-type sd))) + + + (setf (slot-value slotd 'nulls-ok) + (view-class-slot-nulls-ok sd)) + + ;; :db-kind slot value defaults to :base (store slot value in + ;; database) + + (setf (slot-value slotd 'db-kind) + (if (slot-boundp sd 'db-kind) + (view-class-slot-db-kind sd) + :base)) + + (setf (slot-value slotd 'db-writer) + (when (slot-boundp sd 'db-writer) + (view-class-slot-db-writer sd))) + (setf (slot-value slotd 'db-constraints) + (when (slot-boundp sd 'db-constraints) + (view-class-slot-db-constraints sd))) + + + ;; I wonder if this slot option and the previous could be merged, + ;; so that :base and :key remain keyword options, but :db-kind + ;; :join becomes :db-kind (:join )? + + (setf (slot-value slotd 'db-info) + (when (slot-boundp sd 'db-info) + (if (listp (view-class-slot-db-info sd)) + (parse-db-info (view-class-slot-db-info sd)) + (view-class-slot-db-info sd))))) + ;; all other slots + (t + (change-class slotd 'view-class-effective-slot-definition + #+allegro :name + #+allegro (slot-definition-name sd)) + (setf (slot-value slotd 'column) + (column-name-from-arg + (sql-escape (slot-definition-name sd)))) + + (setf (slot-value slotd 'db-info) nil) + (setf (slot-value slotd 'db-kind) + :virtual))) + slotd)) + +(defun slotdefs-for-slots-with-class (slots class) + (let ((result nil)) + (dolist (s slots) + (let ((c (slotdef-for-slot-with-class s class))) + (if c (setf result (cons c result))))) + result)) + +(defun slotdef-for-slot-with-class (slot class) + (find-if #'(lambda (d) (eql slot (slot-definition-name d))) + (class-slots class))) + +#+ignore +(eval-when (:compile-toplevel :load-toplevel :execute) + #+kmr-normal-cesd + (setq cl:*features* (delete :kmr-normal-cesd cl:*features*)) + #+kmr-normal-dsdc + (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*)) + #+kmr-normal-esdc + (setq cl:*features* (delete :kmr-normal-esdc cl:*features*)) + ) diff --git a/sql/objects.lisp b/sql/objects.lisp new file mode 100644 index 0000000..14bb76f --- /dev/null +++ b/sql/objects.lisp @@ -0,0 +1,1110 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: objects.lisp +;;;; Updated: <04/04/2004 12:07:55 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; The CLSQL-USQL Object Oriented Data Definitional Language (OODDL) +;;;; and Object Oriented Data Manipulation Language (OODML). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + +(defclass standard-db-object () + ((view-database + :initform nil + :initarg :view-database + :db-kind :virtual)) + (:metaclass standard-db-class) + (:documentation "Superclass for all CLSQL-USQL View Classes.")) + +(defmethod view-database ((self standard-db-object)) + (slot-value self 'view-database)) + +(defvar *db-deserializing* nil) +(defvar *db-initializing* nil) + +(defmethod slot-value-using-class ((class standard-db-class) instance slot) + (declare (optimize (speed 3))) + (unless *db-deserializing* + (let ((slot-name (%slot-name slot)) + (slot-object (%slot-object slot class))) + (when (and (eql (view-class-slot-db-kind slot-object) :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) + (declare (ignore new-value instance slot)) + (call-next-method)) + +;; JMM - Can't go around trying to slot-access a symbol! Guess in +;; CMUCL slot-name is the actual slot _object_, while in lispworks it +;; is a lowly symbol (the variable is called slot-name after all) so +;; the object (or in MOP terminology- the "slot definition") has to be +;; retrieved using find-slot-definition + +(defun %slot-name (slot) + #+lispworks slot + #-lispworks (slot-definition-name slot)) + +(defun %slot-object (slot class) + (declare (ignorable class)) + #+lispworks (clos:find-slot-definition slot class) + #-lispworks slot) + +(defmethod initialize-instance :around ((class standard-db-object) + &rest all-keys + &key &allow-other-keys) + (declare (ignore all-keys)) + (let ((*db-deserializing* t)) + (call-next-method))) + +(defun sequence-from-class (view-class-name) + (sql-escape + (concatenate + 'string + (symbol-name (view-table (find-class view-class-name))) + "-SEQ"))) + +(defun create-sequence-from-class (view-class-name + &key (database *default-database*)) + (create-sequence (sequence-from-class view-class-name) :database database)) + +(defun drop-sequence-from-class (view-class-name + &key (if-does-not-exist :error) + (database *default-database*)) + (drop-sequence (sequence-from-class view-class-name) + :if-does-not-exist if-does-not-exist + :database database)) + +;; +;; Build the database tables required to store the given view class +;; + +(defmethod database-pkey-constraint ((class standard-db-class) database) + (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) + (when keylist + (format nil "CONSTRAINT ~APK PRIMARY KEY~A" + (database-output-sql (view-table class) database) + (database-output-sql keylist database))))) + + +#.(locally-enable-sql-reader-syntax) + +(defun ensure-schema-version-table (database) + (unless (table-exists-p "usql_object_v" :database database) + (create-table [usql_object_v] '(([name] (string 32)) + ([vers] integer) + ([def] (string 32))) + :database database))) + +(defun update-schema-version-records (view-class-name + &key (database *default-database*)) + (let ((schemadef nil) + (tclass (find-class view-class-name))) + (dolist (slotdef (class-slots tclass)) + (let ((res (database-generate-column-definition view-class-name + slotdef database))) + (when res (setf schemadef (cons res schemadef))))) + (when schemadef + (delete-records :from [usql_object_v] + :where [= [name] (sql-escape (class-name tclass))] + :database database) + (insert-records :into [usql_object_v] + :av-pairs `(([name] ,(sql-escape (class-name tclass))) + ([vers] ,(car (object-version tclass))) + ([def] ,(prin1-to-string + (object-definition tclass)))) + :database database)))) + +#.(restore-sql-reader-syntax-state) + +(defun create-view-from-class (view-class-name + &key (database *default-database*)) + "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines +the view. The argument DATABASE has a default value of +*DEFAULT-DATABASE*." + (let ((tclass (find-class view-class-name))) + (if tclass + (let ((*default-database* database)) + (%install-class tclass database) + (ensure-schema-version-table database) + (update-schema-version-records view-class-name :database database)) + (error "Class ~s not found." view-class-name))) + (values)) + +(defmethod %install-class ((self standard-db-class) database &aux schemadef) + (dolist (slotdef (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)) schemadef + :database database + :constraints (database-pkey-constraint self database)) + (push self (database-view-classes database)) + t) + +;; +;; Drop the tables which store the given view class +;; + +#.(locally-enable-sql-reader-syntax) + +(defun drop-view-from-class (view-class-name &key (database *default-database*)) + "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME +which defines that view. The argument DATABASE has a default value of +*DEFAULT-DATABASE*." + (let ((tclass (find-class view-class-name))) + (if tclass + (let ((*default-database* database)) + (%uninstall-class tclass) + (delete-records :from [usql_object_v] + :where [= [name] (sql-escape view-class-name)])) + (error "Class ~s not found." view-class-name))) + (values)) + +#.(restore-sql-reader-syntax-state) + +(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 'standard-db-object) + (database *default-database*)) + "Returns a list of View Classes connected to a given DATABASE which +defaults to *DEFAULT-DATABASE*." + (declare (ignore root-class)) + (remove-if #'(lambda (c) (not (funcall test c))) + (database-view-classes database))) + +;; +;; Define a new view class +;; + +(defmacro def-view-class (class supers slots &rest options) + "Extends the syntax of defclass to allow special slots to be mapped +onto the attributes of database views. The macro DEF-VIEW-CLASS +creates a class called CLASS which maps onto a database view. Such a +class is called a View Class. The macro DEF-VIEW-CLASS extends the +syntax of DEFCLASS to allow special base slots to be mapped onto the +attributes of database views (presently single tables). When a select +query that names a View Class is submitted, then the corresponding +database view is queried, and the slots in the resulting View Class +instances are filled with attribute values from the database. If +SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the +superclass of the newly-defined View Class." + `(progn + (defclass ,class ,supers ,slots ,@options + (:metaclass standard-db-class)) + (finalize-inheritance (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)))) + (flet ((qfk (k) + (sql-operation '== + (sql-expression :attribute + (view-class-slot-column k) + :table tb) + (db-value-from-slot + k + (slot-value obj (slot-definition-name k)) + database)))) + (let* ((keys (keyslots-for-class (class-of obj))) + (keyxprs (mapcar #'qfk (reverse keys)))) + (cond + ((= (length keyxprs) 0) nil) + ((= (length keyxprs) 1) (car keyxprs)) + ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs))))))) + +;; +;; Function used by 'generate-selection-list' +;; + +(defun generate-attribute-reference (vclass slotdef) + (cond + ((eq (view-class-slot-db-kind slotdef) :base) + (sql-expression :attribute (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 (class-slots vclass)) + (let ((res (generate-attribute-reference vclass slotdef))) + (when res + (push (cons slotdef res) sels)))) + (if sels + sels + (error "No slots of type :base in view-class ~A" (class-name vclass))))) + +;; +;; Used by 'create-view-from-class' +;; + + +(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)) + (slot-type slotdef)))) + (let ((const (view-class-slot-db-constraints slotdef))) + (when const + (setq cdef (append cdef (list const))))) + cdef))) + +;; +;; Called by 'get-slot-values-from-view' +;; + +(declaim (inline delistify)) +(defun delistify (list) + (if (listp list) + (car list) + list)) + +(defun slot-type (slotdef) + (let ((slot-type (slot-definition-type slotdef))) + (if (listp slot-type) + (cons (find-symbol (symbol-name (car slot-type)) :usql-sys) + (cdr slot-type)) + (find-symbol (symbol-name slot-type) :usql-sys)))) + +(defmethod update-slot-from-db ((instance standard-db-object) slotdef value) + (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) + (let ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-name (slot-definition-name slotdef)) + (slot-type (slot-type slotdef))) + (cond ((and value (null slot-reader)) + (setf (slot-value instance slot-name) + (read-sql-value value (delistify slot-type) + (view-database instance)))) + ((null value) + (update-slot-with-null instance slot-name slotdef)) + ((typep slot-reader 'string) + (setf (slot-value instance slot-name) + (format nil slot-reader value))) + ((typep slot-reader 'function) + (setf (slot-value instance slot-name) + (apply slot-reader (list value)))) + (t + (error "Slot reader is of an unusual type."))))) + +(defmethod key-value-from-db (slotdef value database) + (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) + (let ((slot-reader (view-class-slot-db-reader slotdef)) + (slot-type (slot-type slotdef))) + (cond ((and value (null slot-reader)) + (read-sql-value value (delistify slot-type) database)) + ((null value) + nil) + ((typep slot-reader 'string) + (format nil slot-reader value)) + ((typep slot-reader 'function) + (apply slot-reader (list value))) + (t + (error "Slot reader is of an unusual type."))))) + +(defun db-value-from-slot (slotdef val database) + (let ((dbwriter (view-class-slot-db-writer slotdef)) + (dbtype (slot-type slotdef))) + (typecase dbwriter + (string (format nil dbwriter val)) + (function (apply dbwriter (list val))) + (t + (typecase dbtype + (cons + (database-output-sql-as-type (car dbtype) val database)) + (t + (database-output-sql-as-type dbtype val database))))))) + +(defun check-slot-type (slotdef val) + (let* ((slot-type (slot-type slotdef)) + (basetype (if (listp slot-type) (car slot-type) slot-type))) + (when (and slot-type val) + (unless (typep val basetype) + (error 'clsql-type-error + :slotname (slot-definition-name slotdef) + :typespec slot-type + :value val))))) + +;; +;; Called by find-all +;; + +(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)) + + +(defun synchronize-keys (src srckey dest destkey) + (let ((skeys (if (listp srckey) srckey (list srckey))) + (dkeys (if (listp destkey) destkey (list destkey)))) + (mapcar #'(lambda (sk dk) + (setf (slot-value dest dk) + (typecase sk + (symbol + (slot-value src sk)) + (t sk)))) + skeys dkeys))) + +(defun desynchronize-keys (dest destkey) + (let ((dkeys (if (listp destkey) destkey (list destkey)))) + (mapcar #'(lambda (dk) + (setf (slot-value dest dk) nil)) + dkeys))) + +(defmethod add-to-relation ((target standard-db-object) + slot-name + (value standard-db-object)) + (let* ((objclass (class-of target)) + (sdef (or (slotdef-for-slot-with-class slot-name objclass) + (error "~s is not an known slot on ~s" slot-name target))) + (dbinfo (view-class-slot-db-info sdef)) + (join-class (gethash :join-class dbinfo)) + (homekey (gethash :home-key dbinfo)) + (foreignkey (gethash :foreign-key dbinfo)) + (to-many (gethash :set dbinfo))) + (unless (equal (type-of value) join-class) + (error 'clsql-type-error :slotname slot-name :typespec join-class + :value value)) + (when (gethash :target-slot dbinfo) + (error "add-to-relation does not work with many-to-many relations yet.")) + (if to-many + (progn + (synchronize-keys target homekey value foreignkey) + (if (slot-boundp target slot-name) + (unless (member value (slot-value target slot-name)) + (setf (slot-value target slot-name) + (append (slot-value target slot-name) (list value)))) + (setf (slot-value target slot-name) (list value)))) + (progn + (synchronize-keys value foreignkey target homekey) + (setf (slot-value target slot-name) value))))) + +(defmethod remove-from-relation ((target standard-db-object) + slot-name (value standard-db-object)) + (let* ((objclass (class-of target)) + (sdef (slotdef-for-slot-with-class slot-name objclass)) + (dbinfo (view-class-slot-db-info sdef)) + (homekey (gethash :home-key dbinfo)) + (foreignkey (gethash :foreign-key dbinfo)) + (to-many (gethash :set dbinfo))) + (when (gethash :target-slot dbinfo) + (error "remove-relation does not work with many-to-many relations yet.")) + (if to-many + (progn + (desynchronize-keys value foreignkey) + (if (slot-boundp target slot-name) + (setf (slot-value target slot-name) + (remove value + (slot-value target slot-name) + :test #'equal)))) + (progn + (desynchronize-keys target homekey) + (setf (slot-value target slot-name) + nil))))) + +(defgeneric update-record-from-slot (object slot &key database) + (:documentation + "The generic function UPDATE-RECORD-FROM-SLOT updates an individual +data item in the column represented by SLOT. The DATABASE is only used +if OBJECT is not yet associated with any database, in which case a +record is created in DATABASE. Only SLOT is initialized in this case; +other columns in the underlying database receive default values. The +argument SLOT is the CLOS slot name; the corresponding column names +are derived from the View Class definition.")) + +(defmethod update-record-from-slot ((obj standard-db-object) slot &key + (database *default-database*)) + (let* ((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 (view-database obj))) + ((and vct sd (not (view-database obj))) + (install-instance obj :database database)) + (t + (error "Unable to update record."))))) + (values)) + +(defgeneric update-record-from-slots (object slots &key database) + (:documentation + "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the +columns represented by SLOTS. The DATABASE is only used if OBJECT is +not yet associated with any database, in which case a record is +created in DATABASE. Only slots are initialized in this case; other +columns in the underlying database receive default values. The +argument SLOTS contains the CLOS slot names; the corresponding column +names are derived from the view class definition.")) + +(defmethod update-record-from-slots ((obj standard-db-object) slots &key + (database *default-database*)) + (let* ((vct (view-table (class-of obj))) + (sds (slotdefs-for-slots-with-class slots (class-of obj))) + (avps (mapcar #'(lambda (s) + (let ((val (slot-value + obj (slot-definition-name s)))) + (check-slot-type s val) + (list (sql-expression + :attribute (view-class-slot-column s)) + (db-value-from-slot s val database)))) + sds))) + (cond ((and avps (view-database obj)) + (update-records (sql-expression :table vct) + :av-pairs avps + :where (key-qualifier-for-instance + obj :database database) + :database (view-database obj))) + ((and avps (not (view-database obj))) + (insert-records :into (sql-expression :table vct) + :av-pairs avps + :database database) + (setf (slot-value obj 'view-database) database)) + (t + (error "Unable to update records")))) + (values)) + +(defgeneric update-records-from-instance (object &key database) + (:documentation + "Using an instance of a view class, update the database table that +stores its instance data. If the instance is already associated with a +database, that database is used, and database is ignored. If instance +is not yet associated with a database, a record is created for +instance in the appropriate table of database and the instance becomes +associated with that database.")) + +(defmethod update-records-from-instance ((obj standard-db-object) + &key (database *default-database*)) + (labels ((slot-storedp (slot) + (and (member (view-class-slot-db-kind slot) '(:base :key)) + (slot-boundp obj (slot-definition-name slot)))) + (slot-value-list (slot) + (let ((value (slot-value 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)) + (view-class-table (view-table view-class)) + (slots (remove-if-not #'slot-storedp (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 (view-database obj)) + (progn + (insert-records :into (sql-expression :table view-class-table) + :av-pairs record-values + :database database) + (setf (slot-value obj 'view-database) database))) + (values)))) + +(defmethod install-instance ((obj standard-db-object) + &key (database *default-database*)) + (labels ((slot-storedp (slot) + (and (member (view-class-slot-db-kind slot) '(:base :key)) + (slot-boundp obj (slot-definition-name slot)))) + (slot-value-list (slot) + (let ((value (slot-value 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)) + (view-class-table (view-table view-class)) + (slots (remove-if-not #'slot-storedp (class-slots view-class))) + (record-values (mapcar #'slot-value-list slots))) + (unless record-values + (error "No settable slots.")) + (unless + (let ((obj-db (slot-value obj 'view-database))) + (when obj-db + (equal obj-db database)))) + (insert-records :into (sql-expression :table view-class-table) + :av-pairs record-values + :database database) + (setf (slot-value obj 'view-database) database)) + (values))) + +;; Perhaps the slot class is not correct in all CLOS implementations, +;; tho I have not run across a problem yet. + +(defmethod handle-cascade-delete-rule ((instance standard-db-object) + (slot + view-class-effective-slot-definition)) + (let ((val (slot-value instance (slot-definition-name slot)))) + (typecase val + (list + (if (gethash :target-slot (view-class-slot-db-info slot)) + ;; For relations with target-slot, we delete just the join instance + (mapcar #'(lambda (obj) + (delete-instance-records obj)) + (fault-join-slot-raw (class-of instance) instance slot)) + (dolist (obj val) + (delete-instance-records obj)))) + (standard-db-object + (delete-instance-records val))))) + +(defmethod nullify-join-foreign-keys ((instance standard-db-object) slot) + (let* ((dbi (view-class-slot-db-info slot)) + (fkeys (gethash :foreign-keys dbi))) + (mapcar #'(lambda (fk) + (if (view-class-slot-nulls-ok slot) + (setf (slot-value instance fk) nil) + (warn "Nullify delete rule cannot set slot not allowing nulls to nil"))) + (if (listp fkeys) fkeys (list fkeys))))) + +(defmethod handle-nullify-delete-rule ((instance standard-db-object) + (slot + view-class-effective-slot-definition)) + (let ((dbi (view-class-slot-db-info slot))) + (if (gethash :set dbi) + (if (gethash :target-slot (view-class-slot-db-info slot)) + ;;For relations with target-slot, we delete just the join instance + (mapcar #'(lambda (obj) + (nullify-join-foreign-keys obj slot)) + (fault-join-slot-raw (class-of instance) instance slot)) + (dolist (obj (slot-value instance (slot-definition-name slot))) + (nullify-join-foreign-keys obj slot))) + (nullify-join-foreign-keys + (slot-value instance (slot-definition-name slot)) slot)))) + +(defmethod propogate-deletes ((instance standard-db-object)) + (let* ((view-class (class-of instance)) + (joins (remove-if #'(lambda (sd) + (not (equal (view-class-slot-db-kind sd) :join))) + (class-slots view-class)))) + (dolist (slot joins) + (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot)))) + (cond + ((eql delete-rule :cascade) + (handle-cascade-delete-rule instance slot)) + ((eql delete-rule :deny) + (when (slot-value instance (slot-definition-name slot)) + (error + "Unable to delete slot ~A, because it has a deny delete rule." + slot))) + ((eql delete-rule :nullify) + (handle-nullify-delete-rule instance slot)) + (t t)))))) + +(defgeneric delete-instance-records (instance) + (:documentation + "Deletes the records represented by INSTANCE from the database +associated with it. If instance has no associated database, an error +is signalled.")) + +(defmethod delete-instance-records ((instance standard-db-object)) + (let ((vt (sql-expression :table (view-table (class-of instance)))) + (vd (or (view-database instance) *default-database*))) + (when vd + (let ((qualifier (key-qualifier-for-instance instance :database vd))) + (with-transaction (:database vd) + (propogate-deletes instance) + (delete-records :from vt :where qualifier :database vd) + (setf (slot-value instance 'view-database) nil))))) + (values)) + +(defgeneric update-instance-from-records (instance &key database) + (:documentation + "Updates the values in the slots of the View Class instance +INSTANCE using the data in the database DATABASE which defaults to the +database that INSTANCE is associated with, or the value of +*DEFAULT-DATABASE*.")) + +(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))))) + (get-slot-values-from-view instance (mapcar #'car sels) (car res)))) + +(defgeneric update-slot-from-record (instance slot &key database) + (:documentation + "Updates the value in the slot SLOT of the View Class instance +INSTANCE using the data in the database DATABASE which defaults to the +database that INSTANCE is associated with, or the value of +*DEFAULT-DATABASE*.")) + +(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))) + (get-slot-values-from-view instance (list slot-def) (car res)))) + + +(defgeneric database-null-value (type) + (:documentation "Return an expression of type TYPE which SQL NULL values +will be converted into.")) + +(defmethod database-null-value ((type t)) + (cond + ((subtypep type 'string) "") + ((subtypep type 'integer) 0) + ((subtypep type 'float) (float 0.0)) + ((subtypep type 'list) nil) + ((subtypep type 'boolean) nil) + ((subtypep type 'symbol) nil) + ((subtypep type 'keyword) nil) + ((subtypep type 'wall-time) nil) + (t + (error "Unable to handle null for type ~A" type)))) + +(defgeneric update-slot-with-null (instance slotname slotdef) + (:documentation "Called to update a slot when its column has a NULL +value. If nulls are allowed for the column, the slot's value will be +nil, otherwise its value will be set to the result of calling +DATABASE-NULL-VALUE on the type of the slot.")) + +(defmethod update-slot-with-null ((instance standard-db-object) + slotname + slotdef) + (let ((st (slot-type slotdef)) + (allowed (slot-value slotdef 'nulls-ok))) + (if allowed + (setf (slot-value instance slotname) nil) + (setf (slot-value instance slotname) + (database-null-value st))))) + +(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)))) + +(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*)) + (declare (ignore database)) + (let* ((class (find-class classname))) + (unless (view-table class) + (error "No view-table for class ~A" classname)) + (sql-expression :table (view-table class)))) + +(defmethod database-get-type-specifier (type args database) + (declare (ignore type args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)")) + +(defmethod database-get-type-specifier ((type (eql 'integer)) args database) + (declare (ignore database)) + ;;"INT8") + (if args + (format nil "INT(~A)" (car args)) + "INT")) + +(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args + database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'simple-string)) args + database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'string)) args database) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database) + (declare (ignore args)) + (case (database-type database) + (:postgresql + "TIMESTAMP WITHOUT TIME ZONE") + (:postgresql-socket + "TIMESTAMP WITHOUT TIME ZONE") + (:mysql + "DATETIME") + (t "TIMESTAMP"))) + +(defmethod database-get-type-specifier ((type (eql 'duration)) args database) + (declare (ignore database args)) + "INT8") + +(deftype raw-string (&optional len) + "A string which is not trimmed when retrieved from the database" + `(string ,len)) + +(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database) + (declare (ignore database)) + (if args + (format nil "VARCHAR(~A)" (car args)) + "VARCHAR")) + +(defmethod database-get-type-specifier ((type (eql 'float)) args database) + (declare (ignore database)) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + +(defmethod database-get-type-specifier ((type (eql 'long-float)) args database) + (declare (ignore database)) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + +(defmethod database-get-type-specifier ((type (eql 'boolean)) args database) + (declare (ignore args database)) + "BOOL") + +(defmethod database-output-sql-as-type (type val database) + (declare (ignore type database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'list)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) + (declare (ignore database)) + (if (keywordp val) + (symbol-name val) + (if val + (concatenate 'string + (package-name (symbol-package val)) + "::" + (symbol-name val)) + ""))) + +(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database) + (declare (ignore database)) + (if val + (symbol-name val) + "")) + +(defmethod database-output-sql-as-type ((type (eql 'vector)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'array)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database) + (declare (ignore database)) + (if val "t" "f")) + +(defmethod database-output-sql-as-type ((type (eql 'string)) val database) + (declare (ignore database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'simple-string)) + val database) + (declare (ignore database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) + val database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val type database) + (declare (ignore type database)) + (read-from-string val)) + +(defmethod read-sql-value (val (type (eql 'string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'simple-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'simple-base-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'raw-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'keyword)) database) + (declare (ignore database)) + (when (< 0 (length val)) + (intern (string-upcase val) "KEYWORD"))) + +(defmethod read-sql-value (val (type (eql 'symbol)) database) + (declare (ignore database)) + (when (< 0 (length val)) + (if (find #\: val) + (read-from-string val) + (intern (string-upcase val) "KEYWORD")))) + +(defmethod read-sql-value (val (type (eql 'integer)) database) + (declare (ignore database)) + (etypecase val + (string + (read-from-string val)) + (number val))) + +(defmethod read-sql-value (val (type (eql 'float)) database) + (declare (ignore database)) + ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) + (float (read-from-string val))) + +(defmethod read-sql-value (val (type (eql 'boolean)) database) + (declare (ignore database)) + (equal "t" val)) + +(defmethod read-sql-value (val (type (eql 'wall-time)) database) + (declare (ignore database)) + (unless (eq 'NULL val) + (parse-timestring val))) + + +;; ------------------------------------------------------------ +;; Logic for 'faulting in' :join slots + +(defun fault-join-slot-raw (class instance slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (jc (gethash :join-class dbi))) + (let ((jq (join-qualifier class instance slot-def))) + (when jq + (select jc :where jq))))) + +(defun fault-join-slot (class instance slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi)) + (res (fault-join-slot-raw class instance slot-def))) + (when res + (cond + ((and ts (gethash :set dbi)) + (mapcar (lambda (obj) + (cons obj (slot-value obj ts))) res)) + ((and ts (not (gethash :set dbi))) + (mapcar (lambda (obj) (slot-value obj ts)) res)) + ((and (not ts) (not (gethash :set dbi))) + (car res)) + ((and (not ts) (gethash :set dbi)) + res))))) + +(defun join-qualifier (class instance 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 instance slt) + (not (null (slot-value instance 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 instance 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)))))) + + +(defun find-all (view-classes &rest args &key all set-operation distinct from + where group-by having order-by order-by-descending offset limit + (database *default-database*)) + "tweeze me apart someone pleeze" + (declare (ignore all set-operation from group-by having offset limit) + (optimize (debug 3) (speed 1))) + (let* ((*db-deserializing* t) + (*default-database* (or database (error 'clsql-nodb-error)))) + (flet ((table-sql-expr (table) + (sql-expression :table (view-table table))) + (ref-equal (ref1 ref2) + (equal (sql ref1) + (sql ref2))) + (tables-equal (table-a table-b) + (string= (string (slot-value table-a 'name)) + (string (slot-value table-b 'name))))) + + (let* ((sclasses (mapcar #'find-class view-classes)) + (sels (mapcar #'generate-selection-list sclasses)) + (fullsels (apply #'append sels)) + (sel-tables (collect-table-refs where)) + (tables + (remove-duplicates + (append (mapcar #'table-sql-expr sclasses) sel-tables) + :test #'tables-equal)) + (res nil)) + (dolist (ob (listify order-by)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (dolist (ob (listify order-by-descending)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (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)))))) + ;;(format t "~%fullsels is : ~A" fullsels) + (setq res (apply #'select (append (mapcar #'cdr fullsels) + (cons :from (list tables)) args))) + (flet ((build-instance (vals) + (flet ((%build-instance (vclass selects) + (let ((class-name (class-name vclass)) + (db-vals (butlast vals + (- (list-length vals) + (list-length selects)))) + cache-key) + (setf vals (nthcdr (list-length selects) vals)) + (loop for select in selects + for value in db-vals + do + (when (eql (slot-value (car select) 'db-kind) + :key) + (push + (key-value-from-db (car select) value + *default-database*) + cache-key))) + (push class-name cache-key) + (%make-fresh-object class-name + (mapcar #'car selects) + db-vals)))) + (let ((instances (mapcar #'%build-instance sclasses sels))) + (if (= (length sclasses) 1) + (car instances) + instances))))) + (remove-if #'null (mapcar #'build-instance res))))))) + +(defun %make-fresh-object (class-name slots values) + (let* ((*db-initializing* t) + (obj (make-instance class-name + :view-database *default-database*))) + (setf obj (get-slot-values-from-view obj slots values)) + (postinitialize obj) + obj)) + +(defmethod postinitialize ((self t)) + ) + +(defun select (&rest select-all-args) + "Selects data from database given the constraints specified. Returns +a list of lists of record values as specified by select-all-args. By +default, the records are each represented as lists of attribute +values. The selections argument may be either db-identifiers, literal +strings or view classes. If the argument consists solely of view +classes, the return value will be instances of objects rather than raw +tuples." + (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) + (if (select-objects target-args) + (apply #'find-all target-args qualifier-args) + (let ((expr (apply #'make-query select-all-args))) + (destructuring-bind (&key (flatp nil) + (database *default-database*) + &allow-other-keys) + qualifier-args + (let ((res (query expr :database database))) + (if (and flatp + (= (length (slot-value expr 'selections)) 1)) + (mapcar #'car res) + res)))))))) diff --git a/sql/operations.lisp b/sql/operations.lisp new file mode 100644 index 0000000..b07c068 --- /dev/null +++ b/sql/operations.lisp @@ -0,0 +1,201 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: operations.lisp +;;;; Updated: <04/04/2004 12:07:26 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Definition of SQL operations used with the symbolic SQL syntax. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + + +;; Keep a hashtable for mapping symbols to sql generator functions, +;; for use by the bracketed reader syntax. + +(defvar *sql-op-table* (make-hash-table :test #'equal)) + + +;; Define an SQL operation type. + +(defmacro defsql (function definition-keys &body body) + `(progn + (defun ,function ,@body) + (let ((symbol (cadr (member :symbol ',definition-keys)))) + (setf (gethash (if symbol (string-upcase symbol) ',function) + *sql-op-table*) + ',function)))) + + +;; SQL operations + +(defsql sql-query (:symbol "select") (&rest args) + (apply #'make-query args)) + +(defsql sql-any (:symbol "any") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'any :components rest)) + +(defsql sql-all (:symbol "all") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'all :components rest)) + +(defsql sql-not (:symbol "not") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'not :components rest)) + +(defsql sql-union (:symbol "union") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'union :components rest)) + +(defsql sql-intersect (:symbol "intersect") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'intersect :components rest)) + +(defsql sql-minus (:symbol "minus") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'minus :components rest)) + +(defsql sql-group-by (:symbol "group-by") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'group-by :components rest)) + +(defsql sql-limit (:symbol "limit") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'limit :components rest)) + +(defsql sql-having (:symbol "having") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'having :components rest)) + +(defsql sql-null (:symbol "null") (&rest rest) + (if rest + (make-instance 'sql-relational-exp :operator '|IS NULL| + :sub-expressions (list (car rest))) + (make-instance 'sql-value-exp :components 'null))) + +(defsql sql-not-null (:symbol "not-null") () + (make-instance 'sql-value-exp + :components '|NOT NULL|)) + +(defsql sql-exists (:symbol "exists") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'exists :components rest)) + +(defsql sql-* (:symbol "*") (&rest rest) + (if (zerop (length rest)) + (make-instance 'sql-ident :name '*) + ;(error 'clsql-sql-syntax-error :reason "'*' with arguments"))) + (make-instance 'sql-relational-exp :operator '* :sub-expressions rest))) + +(defsql sql-+ (:symbol "+") (&rest rest) + (if (cdr rest) + (make-instance 'sql-relational-exp + :operator '+ :sub-expressions rest) + (make-instance 'sql-value-exp :modifier '+ :components rest))) + +(defsql sql-/ (:symbol "/") (&rest rest) + (make-instance 'sql-relational-exp + :operator '/ :sub-expressions rest)) + +(defsql sql-- (:symbol "-") (&rest rest) + (if (cdr rest) + (make-instance 'sql-relational-exp + :operator '- :sub-expressions rest) + (make-instance 'sql-value-exp :modifier '- :components rest))) + +(defsql sql-like (:symbol "like") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'like :sub-expressions rest)) + +(defsql sql-uplike (:symbol "uplike") (&rest rest) + (make-instance 'sql-upcase-like + :sub-expressions rest)) + +(defsql sql-and (:symbol "and") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'and :sub-expressions rest)) + +(defsql sql-or (:symbol "or") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'or :sub-expressions rest)) + +(defsql sql-in (:symbol "in") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'in :sub-expressions rest)) + +(defsql sql-|| (:symbol "||") (&rest rest) + (make-instance 'sql-relational-exp + :operator '|| :sub-expressions rest)) + +(defsql sql-is (:symbol "is") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'is :sub-expressions rest)) + +(defsql sql-= (:symbol "=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '= :sub-expressions rest)) + +(defsql sql-== (:symbol "==") (&rest rest) + (make-instance 'sql-assignment-exp + :operator '= :sub-expressions rest)) + +(defsql sql-< (:symbol "<") (&rest rest) + (make-instance 'sql-relational-exp + :operator '< :sub-expressions rest)) + + +(defsql sql-> (:symbol ">") (&rest rest) + (make-instance 'sql-relational-exp + :operator '> :sub-expressions rest)) + +(defsql sql-<> (:symbol "<>") (&rest rest) + (make-instance 'sql-relational-exp + :operator '<> :sub-expressions rest)) + +(defsql sql->= (:symbol ">=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '>= :sub-expressions rest)) + +(defsql sql-<= (:symbol "<=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '<= :sub-expressions rest)) + +(defsql sql-count (:symbol "count") (&rest rest) + (make-instance 'sql-function-exp + :name 'count :args rest)) + +(defsql sql-max (:symbol "max") (&rest rest) + (make-instance 'sql-function-exp + :name 'max :args rest)) + +(defsql sql-min (:symbol "min") (&rest rest) + (make-instance 'sql-function-exp + :name 'min :args rest)) + +(defsql sql-avg (:symbol "avg") (&rest rest) + (make-instance 'sql-function-exp + :name 'avg :args rest)) + +(defsql sql-sum (:symbol "sum") (&rest rest) + (make-instance 'sql-function-exp + :name 'sum :args rest)) + +(defsql sql-the (:symbol "the") (&rest rest) + (make-instance 'sql-typecast-exp + :modifier (first rest) :components (second rest))) + +(defsql sql-function (:symbol "function") (&rest args) + (make-instance 'sql-function-exp + :name (make-symbol (car args)) :args (cdr args))) + +;;(defsql sql-distinct (:symbol "distinct") (&rest rest) +;; nil) + +;;(defsql sql-between (:symbol "between") (&rest rest) +;; nil) + diff --git a/sql/package.lisp b/sql/package.lisp new file mode 100644 index 0000000..39f16a9 --- /dev/null +++ b/sql/package.lisp @@ -0,0 +1,433 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: package.lisp +;;;; Author: Marcus Pearce , Kevin Rosenberg +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 12:21:50 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Package definitions for CLSQL-USQL. +;;;; +;;;; ====================================================================== + +(in-package #:cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +#+sbcl + (if (find-package 'sb-mop) + (pushnew :usql-sbcl-mop cl:*features*) + (pushnew :usql-sbcl-pcl cl:*features*)) + + #+cmu + (if (eq (symbol-package 'pcl:find-class) + (find-package 'common-lisp)) + (pushnew :usql-cmucl-mop cl:*features*) + (pushnew :usql-cmucl-pcl cl:*features*))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:clsql-usql-sys + (:nicknames #:usql-sys) + (:use #:common-lisp #:clsql-base-sys + #+usql-sbcl-mop #:sb-mop + #+usql-cmucl-mop #:mop + #+allegro #:mop + #+lispworks #:clos + #+scl #:clos + #+openmcl #:openmcl-mop) + + #+allegro + (:shadowing-import-from + #:excl) + #+lispworks + (:shadowing-import-from + #:clos) + #+usql-sbcl-mop + (:shadowing-import-from + #:sb-pcl + #:generic-function-lambda-list) + #+usql-sbcl-pcl + (:shadowing-import-from + #:sb-pcl + #:name + #:class-direct-slots + #:class-of #:class-name #:class-slots #:find-class + #:slot-boundp + #:standard-class + #:slot-definition-name #:finalize-inheritance + #:standard-direct-slot-definition + #:standard-effective-slot-definition #:validate-superclass + #:direct-slot-definition-class #:compute-effective-slot-definition + #:effective-slot-definition-class + #:slot-value-using-class + #:class-prototype #:generic-function-method-class #:intern-eql-specializer + #:make-method-lambda #:generic-function-lambda-list + #:class-precedence-list #:slot-definition-type + #:class-direct-superclasses) + #+usql-cmucl-mop + (:shadowing-import-from + #:pcl + #:generic-function-lambda-list) + #+usql-cmucl-pcl + (:shadowing-import-from + #:pcl + #:class-direct-slots + #:name + #:class-of #:class-name #:class-slots #:find-class #:standard-class + #:slot-boundp + #:slot-definition-name #:finalize-inheritance + #:standard-direct-slot-definition #:standard-effective-slot-definition + #:validate-superclass #:direct-slot-definition-class + #:effective-slot-definition-class + #:compute-effective-slot-definition + #:slot-value-using-class + #:class-prototype #:generic-function-method-class #:intern-eql-specializer + #:make-method-lambda #:generic-function-lambda-list + #:class-precedence-list #:slot-definition-type + #:class-direct-superclasses) + #+scl + (:shadowing-import-from + #:clos + #:class-prototype ;; note: make-method-lambda is not fbound + ) + + (:import-from + #:clsql-base-sys + . + #1=( + ;; conditions + :clsql-condition + :clsql-error + :clsql-simple-error + :clsql-warning + :clsql-simple-warning + :clsql-invalid-spec-error + :clsql-invalid-spec-error-connection-spec + :clsql-invalid-spec-error-database-type + :clsql-invalid-spec-error-template + :clsql-connect-error + :clsql-connect-error-database-type + :clsql-connect-error-connection-spec + :clsql-connect-error-errno + :clsql-connect-error-error + :clsql-sql-error + :clsql-sql-error-database + :clsql-sql-error-expression + :clsql-sql-error-errno + :clsql-sql-error-error + :clsql-database-warning + :clsql-database-warning-database + :clsql-database-warning-message + :clsql-exists-condition + :clsql-exists-condition-new-db + :clsql-exists-condition-old-db + :clsql-exists-warning + :clsql-exists-error + :clsql-closed-error + :clsql-closed-error-database + :clsql-type-error + :clsql-sql-syntax-error + + ;; db-interface + :check-connection-spec + :database-initialize-database-type + :database-type-load-foreign + :database-name-from-spec + :database-create-sequence + :database-drop-sequence + :database-sequence-next + :database-set-sequence-position + :database-query-result-set + :database-dump-result-set + :database-store-next-row + :database-get-type-specifier + :database-list-tables + :database-list-views + :database-list-indexes + :database-list-sequences + :database-list-attributes + :database-attribute-type + :database-add-attribute + :database-type + ;; initialize + :*loaded-database-types* + :reload-database-types + :*default-database-type* + :*initialized-database-types* + :initialize-database-type + ;; classes + :database + :closed-database + :database-name + :command-recording-stream + :result-recording-stream + :database-view-classes + :database-schema + :conn-pool + :print-object + ;; utils + :sql-escape + + ;; database.lisp -- Connection + #:*default-database-type* ; clsql-base xx + #:*default-database* ; classes xx + #:connect ; database xx + #:*connect-if-exists* ; database xx + #:connected-databases ; database xx + #:database ; database xx + #:database-name ; database xx + #:disconnect ; database xx + #:reconnect ; database + #:find-database ; database xx + #:status ; database xx + #:with-database + #:with-default-database + + ;; basic-sql.lisp + #:query + #:execute-command + #:write-large-object + #:read-large-object + #:delete-large-object + #:do-query + #:map-query + + ;; recording.lisp -- SQL I/O Recording + #:record-sql-comand + #: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 + + ;; 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 + )) + (:export + ;; "Private" exports for use by interface packages + :check-connection-spec + :database-initialize-database-type + :database-type-load-foreign + :database-name-from-spec + :database-connect + :database-query + :database-execute-command + :database-create-sequence + :database-drop-sequence + :database-sequence-next + :database-set-sequence-position + :database-query-result-set + :database-dump-result-set + :database-store-next-row + :database-get-type-specifier + :database-list-tables + :database-table-exists-p + :database-list-views + :database-view-exists-p + :database-list-indexes + :database-index-exists-p + :database-list-sequences + :database-sequence-exists-p + :database-list-attributes + :database-attribute-type + + . + ;; Shared exports for re-export by USQL. + ;; I = Implemented, D = Documented + ;; name file ID + ;;==================================================== + #2=(;;------------------------------------------------ + ;; 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 + :loop ; loop-ext x + ;;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 + :create-view ; table xx + :drop-view ; table xx + :create-index ; table xx + :drop-index ; table xx + ;;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 ; + :update-object-joins ; + :*default-update-objects-max-len* ; + :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 + + ;;------------------------------------------------ + ;; Miscellaneous Extensions + ;;------------------------------------------------ + ;;Initialization + :*loaded-database-types* ; clsql-base xx + :reload-database-types ; clsql-base xx + :closed-database ; database xx + :database-type ; database x + :in-schema ; classes x + ;;FDDL + :list-views ; table xx + :view-exists-p ; table xx + :list-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 + :create-sequence-from-class ; objects x + :drop-sequence-from-class ; objects x + ;;OODML + :add-to-relation ; objects x + :remove-from-relation ; objects x + :read-sql-value ; objects x + :database-output-sql-as-type ; objects x + :database-get-type-specifier ; objects x + :database-output-sql ; sql/class xx + + ;;----------------------------------------------- + ;; Symbolic Sql Syntax + ;;----------------------------------------------- + :sql-and-qualifier + :sql-escape + :sql-query + :sql-any + :sql-all + :sql-not + :sql-union + :sql-intersection + :sql-minus + :sql-group-by + :sql-having + :sql-null + :sql-not-null + :sql-exists + :sql-* + :sql-+ + :sql-/ + :sql-like + :sql-uplike + :sql-and + :sql-or + :sql-in + :sql-|| + :sql-is + :sql-= + :sql-== + :sql-< + :sql-> + :sql->= + :sql-<= + :sql-count + :sql-max + :sql-min + :sql-avg + :sql-sum + :sql-view-class + :sql_slot-value + + . + #1# + )) + (:documentation "This is the INTERNAL SQL-Interface package of USQL.")) + + +;; see http://thread.gmane.org/gmane.lisp.lispworks.general/681 +#+lispworks +(setf *packages-for-warn-on-redefinition* + (delete "SQL" *packages-for-warn-on-redefinition* :test 'string=)) + +(defpackage #:clsql-usql + (:nicknames #:usql #:sql) + (:use :common-lisp) + (:import-from :clsql-usql-sys . #2#) + (:export . #2#) + (:documentation "This is the SQL-Interface package of USQL.")) + + ;; This is from USQL's pcl-patch + #+(or usql-sbcl-pcl usql-cmucl-pcl) + (progn + ;; Note that this will no longer required for cmucl as of version 19a. + (in-package #+cmu :pcl #+sbcl :sb-pcl) + (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) + &body body) + `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) + (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + slot-vars pv-parameters)) + ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars) + ,@body)))) + + + #+sbcl + (if (find-package 'sb-mop) + (setq cl:*features* (delete :usql-sbcl-mop cl:*features*)) + (setq cl:*features* (delete :usql-sbcl-pcl cl:*features*))) + + #+cmu + (if (find-package 'mop) + (setq cl:*features* (delete :usql-cmucl-mop cl:*features*)) + (setq cl:*features* (delete :usql-cmucl-pcl cl:*features*))) + +);eval-when + + diff --git a/sql/sql.lisp b/sql/sql.lisp new file mode 100644 index 0000000..b5c7284 --- /dev/null +++ b/sql/sql.lisp @@ -0,0 +1,242 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: sql.lisp +;;;; Updated: <04/04/2004 12:05:32 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; The CLSQL-USQL Functional Data Manipulation Language (FDML). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + + +;;; Basic operations on databases + + +(defmethod database-query-result-set ((expr %sql-expression) database + &key full-set types) + (database-query-result-set (sql-output expr database) database + :full-set full-set :types types)) + +(defmethod execute-command ((expr %sql-expression) + &key (database *default-database*)) + (execute-command (sql-output expr database) :database database) + (values)) + + + +(defmethod query ((expr %sql-expression) &key (database *default-database*) + (result-types nil) (flatp nil)) + (query (sql-output expr database) :database database :flatp flatp + :result-types result-types)) + +(defun print-query (query-exp &key titles (formats t) (sizes t) (stream t) + (database *default-database*)) + "The PRINT-QUERY function takes a symbolic SQL query expression and +formatting information and prints onto STREAM a table containing the +results of the query. A list of strings to use as column headings is +given by TITLES, which has a default value of NIL. The FORMATS +argument is a list of format strings used to print each attribute, and +has a default value of T, which means that ~A or ~VA are used if sizes +are provided or computed. The field sizes are given by SIZES. It has a +default value of T, which specifies that minimum sizes are +computed. The output stream is given by STREAM, which has a default +value of T. This specifies that *STANDARD-OUTPUT* is used." + (flet ((compute-sizes (data) + (mapcar #'(lambda (x) (apply #'max (mapcar #'length x))) + (apply #'mapcar (cons #'list data)))) + (format-record (record control sizes) + (format stream "~&~?" control + (if (null sizes) record + (mapcan #'(lambda (s f) (list s f)) sizes record))))) + (let* ((query-exp (etypecase query-exp + (string query-exp) + (sql-query (sql-output query-exp)))) + (data (query query-exp :database database)) + (sizes (if (or (null sizes) (listp sizes)) sizes + (compute-sizes (if titles (cons titles data) data)))) + (formats (if (or (null formats) (not (listp formats))) + (make-list (length (car data)) :initial-element + (if (null sizes) "~A " "~VA ")) + formats)) + (control-string (format nil "~{~A~}" formats))) + (when titles (format-record titles control-string sizes)) + (dolist (d data (values)) (format-record d control-string sizes))))) + +(defun insert-records (&key (into nil) + (attributes nil) + (values nil) + (av-pairs nil) + (query nil) + (database *default-database*)) + "Inserts a set of values into a table. The records created contain +values for attributes (or av-pairs). The argument VALUES is a list of +values. If ATTRIBUTES is supplied then VALUES must be a corresponding +list of values for each of the listed attribute names. If AV-PAIRS is +non-nil, then both ATTRIBUTES and VALUES must be nil. If QUERY is +non-nil, then neither VALUES nor AV-PAIRS should be. QUERY should be a +query expression, and the attribute names in it must also exist in the +table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." + (let ((stmt (make-sql-insert :into into :attrs attributes + :vals values :av-pairs av-pairs + :subquery query))) + (execute-command stmt :database database))) + +(defun make-sql-insert (&key (into nil) + (attrs nil) + (vals nil) + (av-pairs nil) + (subquery nil)) + (if (null into) + (error 'clsql-sql-syntax-error :reason ":into keyword not supplied")) + (let ((ins (make-instance 'sql-insert :into into))) + (with-slots (attributes values query) + ins + (cond ((and vals (not attrs) (not query) (not av-pairs)) + (setf values vals)) + ((and vals attrs (not subquery) (not av-pairs)) + (setf attributes attrs) + (setf values vals)) + ((and av-pairs (not vals) (not attrs) (not subquery)) + (setf attributes (mapcar #'car av-pairs)) + (setf values (mapcar #'cadr av-pairs))) + ((and subquery (not vals) (not attrs) (not av-pairs)) + (setf query subquery)) + ((and subquery attrs (not vals) (not av-pairs)) + (setf attributes attrs) + (setf query subquery)) + (t + (error 'clsql-sql-syntax-error + :reason "bad or ambiguous keyword combination."))) + ins))) + +(defun delete-records (&key (from nil) + (where nil) + (database *default-database*)) + "Deletes rows from a database table specified by FROM in which the +WHERE condition is true. The argument DATABASE specifies a database +from which the records are to be removed, and defaults to +*default-database*." + (let ((stmt (make-instance 'sql-delete :from from :where where))) + (execute-command stmt :database database))) + +(defun update-records (table &key + (attributes nil) + (values nil) + (av-pairs nil) + (where nil) + (database *default-database*)) + "Changes the values of existing fields in TABLE with columns +specified by ATTRIBUTES and VALUES (or AV-PAIRS) where the WHERE +condition is true." + (when av-pairs + (setf attributes (mapcar #'car av-pairs) + values (mapcar #'cadr av-pairs))) + (let ((stmt (make-instance 'sql-update :table table + :attributes attributes + :values values + :where where))) + (execute-command stmt :database database))) + + +;; iteration + +;; output-sql + +(defmethod database-output-sql ((str string) database) + (declare (ignore database) + (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3)) + (type (simple-array * (*)) str)) + (let ((len (length str))) + (declare (type fixnum len)) + (cond ((= len 0) + +empty-string+) + ((and (null (position #\' str)) + (null (position #\\ str))) + (concatenate 'string "'" str "'")) + (t + (let ((buf (make-string (+ (* len 2) 2) :initial-element #\'))) + (do* ((i 0 (incf i)) + (j 1 (incf j))) + ((= i len) (subseq buf 0 (1+ j))) + (declare (type integer i j)) + (let ((char (aref str i))) + (cond ((eql char #\') + (setf (aref buf j) #\\) + (incf j) + (setf (aref buf j) #\')) + ((eql char #\\) + (setf (aref buf j) #\\) + (incf j) + (setf (aref buf j) #\\)) + (t + (setf (aref buf j) char)))))))))) + +(let ((keyword-package (symbol-package :foo))) + (defmethod database-output-sql ((sym symbol) database) + (declare (ignore database)) + (if (equal (symbol-package sym) keyword-package) + (concatenate 'string "'" (string sym) "'") + (symbol-name sym)))) + +(defmethod database-output-sql ((tee (eql t)) database) + (declare (ignore database)) + "'Y'") + +(defmethod database-output-sql ((num number) database) + (declare (ignore database)) + (princ-to-string num)) + +(defmethod database-output-sql ((arg list) database) + (if (null arg) + "NULL" + (format nil "(~{~A~^,~})" (mapcar #'(lambda (val) + (sql-output val database)) + arg)))) + +(defmethod database-output-sql ((arg vector) database) + (format nil "~{~A~^,~}" (map 'list #'(lambda (val) + (sql-output val database)) + arg))) + +(defmethod database-output-sql ((self wall-time) database) + (declare (ignore database)) + (db-timestring self)) + +(defmethod database-output-sql (thing database) + (if (or (null thing) + (eq 'null thing)) + "NULL" + (error 'clsql-simple-error + :format-control + "No type conversion to SQL for ~A is defined for DB ~A." + :format-arguments (list (type-of thing) (type-of database))))) + +(defmethod output-sql-hash-key ((arg vector) &optional database) + (list 'vector (map 'list (lambda (arg) + (or (output-sql-hash-key arg database) + (return-from output-sql-hash-key nil))) + arg))) + +(defmethod output-sql (expr &optional (database *default-database*)) + (write-string (database-output-sql expr database) *sql-stream*) + t) + +(defmethod output-sql ((expr list) &optional (database *default-database*)) + (if (null expr) + (write-string +null-string+ *sql-stream*) + (progn + (write-char #\( *sql-stream*) + (do ((item expr (cdr item))) + ((null (cdr item)) + (output-sql (car item) database)) + (output-sql (car item) database) + (write-char #\, *sql-stream*)) + (write-char #\) *sql-stream*))) + t) + + diff --git a/sql/syntax.lisp b/sql/syntax.lisp new file mode 100644 index 0000000..f3f8372 --- /dev/null +++ b/sql/syntax.lisp @@ -0,0 +1,168 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: package.lisp +;;;; Updated: <04/04/2004 12:05:16 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; CLSQL-USQL square bracket symbolic query syntax. Functions for +;;;; enabling and disabling the syntax and for building SQL +;;;; expressions using the syntax. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + +(defvar *original-reader-enter* nil) + +(defvar *original-reader-exit* nil) + +(defvar *sql-macro-open-char* #\[) + +(defvar *sql-macro-close-char* #\]) + +(defvar *restore-sql-reader-syntax* nil) + + +;; Exported functions for disabling SQL syntax. + +(defmacro disable-sql-reader-syntax () + "Turn off SQL square bracket syntax changing syntax state. Set state +such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax +disabled if it is consequently locally enabled." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *restore-sql-reader-syntax* nil) + (%disable-sql-reader-syntax))) + +(defmacro locally-disable-sql-reader-syntax () + "Turn off SQL square bracket syntax and do not change syntax state." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (%disable-sql-reader-syntax))) + +(defun %disable-sql-reader-syntax () + (when *original-reader-enter* + (set-macro-character *sql-macro-open-char* *original-reader-enter*)) + (setf *original-reader-enter* nil) + (values)) + + +;; Exported functions for enabling SQL syntax. + +(defmacro enable-sql-reader-syntax () + "Turn on SQL square bracket syntax changing syntax state. Set state +such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax enabled +if it is consequently locally disabled." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *restore-sql-reader-syntax* t) + (%enable-sql-reader-syntax))) + +(defmacro locally-enable-sql-reader-syntax () + "Turn on SQL square bracket syntax and do not change syntax state." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (%enable-sql-reader-syntax))) + +(defun %enable-sql-reader-syntax () + (unless *original-reader-enter* + (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*))) + (set-macro-character *sql-macro-open-char* #'sql-reader-open) + (enable-sql-close-syntax) + (values)) + +(defmacro restore-sql-reader-syntax-state () + "Sets the enable/disable square bracket syntax state to reflect the +last call to either DISABLE-SQL-READER-SYNTAX or +ENABLE-SQL-READER-SYNTAX. The default state of the square bracket +syntax is disabled." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (if *restore-sql-reader-syntax* + (%enable-sql-reader-syntax) + (%disable-sql-reader-syntax)))) + +(defun sql-reader-open (stream char) + (declare (ignore char)) + (let ((sqllist (read-delimited-list #\] stream t))) + (if (sql-operator (car sqllist)) + (cons (sql-operator (car sqllist)) (cdr sqllist)) + (apply #'generate-sql-reference sqllist)))) + +;; Internal function that disables the close syntax when leaving sql context. +(defun disable-sql-close-syntax () + (set-macro-character *sql-macro-close-char* *original-reader-exit*) + (setf *original-reader-exit* nil)) + +;; Internal function that enables close syntax when entering SQL context. +(defun enable-sql-close-syntax () + (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*)) + (set-macro-character *sql-macro-close-char* (get-macro-character #\)))) + +(defun generate-sql-reference (&rest arglist) + (cond ((= (length arglist) 1) ; string, table or attribute + (if (stringp (car arglist)) + (sql-expression :string (car arglist)) + (sql-expression :attribute (car arglist)))) + ((<= 2 (length arglist)) + (let ((sqltype (if (keywordp (caddr arglist)) + (caddr arglist) nil)) + (sqlparam (if (keywordp (caddr arglist)) + (caddr arglist)))) + (cond + ((stringp (cadr arglist)) + (sql-expression :table (car arglist) + :alias (cadr arglist) + :type sqltype)) + ((keywordp (cadr arglist)) + (sql-expression :attribute (car arglist) + :type (cadr arglist) + :params sqlparam)) + (t + (sql-expression :attribute (cadr arglist) + :table (car arglist) + :params sqlparam + :type sqltype))))) + (t + (error 'clsql-sql-syntax-error :reason "bad expression syntax")))) + + +;; Exported functions for dealing with SQL syntax + +(defun sql (&rest args) + "Generates SQL from a set of expressions given by ARGS. Each +argument is translated into SQL and then the args are concatenated +with a single space between each pair." + (format nil "~{~A~^ ~}" (mapcar #'sql-output args))) + +(defun sql-expression (&key string table alias attribute type params) + "Generates an SQL expression from the given keywords. Valid +combinations of the arguments are: string; table; table and alias; +table and attribute; table, attribute, and type; table or alias, and +attribute; table or alias, and attribute and type; attribute; and +attribute and type." + (cond + (string + (make-instance 'sql :string string)) + (attribute + (make-instance 'sql-ident-attribute :name attribute + :qualifier (or table alias) + :type type + :params params)) + ((and table (not attribute)) + (make-instance 'sql-ident-table :name table + :table-alias alias)))) + +(defun sql-operator (operation) + "Takes an SQL operator as an argument and returns the Lisp symbol +for the operator." + (typecase operation + (string nil) + (symbol (gethash (string-upcase (symbol-name operation)) + *sql-op-table*)))) + +(defun sql-operation (operation &rest rest) + "Generates an SQL statement from an operator and arguments." + (if (sql-operator operation) + (apply (symbol-function (sql-operator operation)) rest) + (error "~A is not a recognized SQL operator." operation))) + + diff --git a/sql/table.lisp b/sql/table.lisp new file mode 100644 index 0000000..715cef0 --- /dev/null +++ b/sql/table.lisp @@ -0,0 +1,320 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: table.lisp +;;;; Updated: <04/04/2004 12:05:03 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; The CLSQL-USQL Functional Data Definition Language (FDDL) +;;;; including functions for schema manipulation. Currently supported +;;;; SQL objects include tables, views, indexes, attributes and +;;;; sequences. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + + +;; Utilities + +(defun database-identifier (name) + (sql-escape (etypecase name + (string + (string-upcase name)) + (sql-ident + (sql-output name)) + (symbol + (sql-output name))))) + + +;; Tables + +(defvar *table-schemas* (make-hash-table :test #'equal) + "Hash of schema name to table lists.") + +(defun create-table (name description &key (database *default-database*) + (constraints nil)) + "Create a table called NAME, in DATABASE which defaults to +*DEFAULT-DATABASE*, containing the attributes in DESCRIPTION which is +a list containing lists of attribute-name and type information pairs." + (let* ((table-name (etypecase name + (symbol (sql-expression :attribute name)) + (string (sql-expression :attribute (make-symbol name))) + (sql-ident name))) + (stmt (make-instance 'sql-create-table + :name table-name + :columns description + :modifiers constraints))) + (pushnew table-name (gethash *default-schema* *table-schemas*) + :test #'equal) + (execute-command stmt :database database))) + +(defun drop-table (name &key (if-does-not-exist :error) + (database *default-database*)) + "Drops table NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the table does not exist and IF-DOES-NOT-EXIST +is :ignore then DROP-TABLE returns nil whereas an error is signalled +if IF-DOES-NOT-EXIST is :error." + (let ((table-name (database-identifier name))) + (ecase if-does-not-exist + (:ignore + (unless (table-exists-p table-name :database database) + (return-from drop-table nil))) + (:error + t)) + (let ((expr (concatenate 'string "DROP TABLE " table-name))) + (execute-command expr :database database)))) + +(defun list-tables (&key (owner nil) (database *default-database*)) + "List all tables in DATABASE which defaults to +*DEFAULT-DATABASE*. If OWNER is nil, only user-owned tables are +considered. This is the default. If OWNER is :all , all tables are +considered. If OWNER is a string, this denotes a username and only +tables owned by OWNER are considered. Table names are returned as a +list of strings." + (database-list-tables database :owner owner)) + +(defun table-exists-p (name &key (owner nil) (database *default-database*)) + "Test for existence of an SQL table called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned +tables are considered. This is the default. If OWNER is :all , all +tables are considered. If OWNER is a string, this denotes a username +and only tables owned by OWNER are considered. Table names are +returned as a list of strings." + (when (member (database-identifier name) + (list-tables :owner owner :database database) + :test #'string-equal) + t)) + + +;; Views + +(defvar *view-schemas* (make-hash-table :test #'equal) + "Hash of schema name to view lists.") + +(defun create-view (name &key as column-list (with-check-option nil) + (database *default-database*)) + "Creates a view called NAME using the AS query and the optional +COLUMN-LIST and WITH-CHECK-OPTION. The COLUMN-LIST argument is a list +of columns to add to the view. The WITH-CHECK-OPTION adds 'WITH CHECK +OPTION' to the resulting SQL. The default value of WITH-CHECK-OPTION +is NIL. The default value of DATABASE is *DEFAULT-DATABASE*." + (let* ((view-name (etypecase name + (symbol (sql-expression :attribute name)) + (string (sql-expression :attribute (make-symbol name))) + (sql-ident name))) + (stmt (make-instance 'sql-create-view + :name view-name + :column-list column-list + :query as + :with-check-option with-check-option))) + (pushnew view-name (gethash *default-schema* *view-schemas*) :test #'equal) + (execute-command stmt :database database))) + +(defun drop-view (name &key (if-does-not-exist :error) + (database *default-database*)) + "Deletes view NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the view does not exist and IF-DOES-NOT-EXIST +is :ignore then DROP-VIEW returns nil whereas an error is signalled if +IF-DOES-NOT-EXIST is :error." + (let ((view-name (database-identifier name))) + (ecase if-does-not-exist + (:ignore + (unless (view-exists-p view-name :database database) + (return-from drop-view))) + (:error + t)) + (let ((expr (concatenate 'string "DROP VIEW " view-name))) + (execute-command expr :database database)))) + +(defun list-views (&key (owner nil) (database *default-database*)) + "List all views in DATABASE which defaults to *DEFAULT-DATABASE*. If +OWNER is nil, only user-owned views are considered. This is the +default. If OWNER is :all , all views are considered. If OWNER is a +string, this denotes a username and only views owned by OWNER are +considered. View names are returned as a list of strings." + (database-list-views database :owner owner)) + +(defun view-exists-p (name &key (owner nil) (database *default-database*)) + "Test for existence of an SQL view called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned views +are considered. This is the default. If OWNER is :all , all views are +considered. If OWNER is a string, this denotes a username and only +views owned by OWNER are considered. View names are returned as a list +of strings." + (when (member (database-identifier name) + (list-views :owner owner :database database) + :test #'string-equal) + t)) + + +;; Indexes + +(defvar *index-schemas* (make-hash-table :test #'equal) + "Hash of schema name to index lists.") + +(defun create-index (name &key on (unique nil) attributes + (database *default-database*)) + "Creates an index called NAME on the table specified by ON. The +attributes of the table to index are given by ATTRIBUTES. Setting +UNIQUE to T includes UNIQUE in the SQL index command, specifying that +the columns indexed must contain unique values. The default value of +UNIQUE is nil. The default value of DATABASE is *DEFAULT-DATABASE*." + (let* ((index-name (database-identifier name)) + (table-name (database-identifier on)) + (attributes (mapcar #'database-identifier (listify attributes))) + (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})" + (if unique "UNIQUE" "") + index-name table-name attributes))) + (pushnew index-name (gethash *default-schema* *index-schemas*)) + (execute-command stmt :database database))) + +(defun drop-index (name &key (if-does-not-exist :error) + (on nil) + (database *default-database*)) + "Deletes index NAME from table FROM in DATABASE which defaults to +*DEFAULT-DATABASE*. If the index does not exist and IF-DOES-NOT-EXIST +is :ignore then DROP-INDEX returns nil whereas an error is signalled +if IF-DOES-NOT-EXIST is :error. The argument ON allows the optional +specification of a table to drop the index from." + (let ((index-name (database-identifier name))) + (ecase if-does-not-exist + (:ignore + (unless (index-exists-p index-name :database database) + (return-from drop-index))) + (:error t)) + (execute-command (format nil "DROP INDEX ~A~A" index-name + (if (null on) "" + (concatenate 'string " ON " + (database-identifier on)))) + :database database))) + +(defun list-indexes (&key (owner nil) (database *default-database*)) + "List all indexes in DATABASE, which defaults to +*default-database*. If OWNER is :all , all indexs are considered. If +OWNER is a string, this denotes a username and only indexs owned by +OWNER are considered. Index names are returned as a list of strings." + (database-list-indexes database :owner owner)) + +(defun index-exists-p (name &key (owner nil) (database *default-database*)) + "Test for existence of an index called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*. If OWNER is :all , all indexs are +considered. If OWNER is a string, this denotes a username and only +indexs owned by OWNER are considered. Index names are returned as a +list of strings." + (when (member (database-identifier name) + (list-indexes :owner owner :database database) + :test #'string-equal) + t)) + +;; Attributes + +(defun list-attributes (name &key (owner nil) (database *default-database*)) + "List the attributes of a attribute called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned +attributes are considered. This is the default. If OWNER is :all , all +attributes are considered. If OWNER is a string, this denotes a +username and only attributes owned by OWNER are considered. Attribute +names are returned as a list of strings. Attributes are returned as a +list of strings." + (database-list-attributes (database-identifier name) database :owner owner)) + +(defun attribute-type (attribute table &key (owner nil) + (database *default-database*)) + "Return the field type of the ATTRIBUTE in TABLE. The optional +keyword argument DATABASE specifies the database to query, defaulting +to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned attributes are +considered. This is the default. If OWNER is :all , all attributes are +considered. If OWNER is a string, this denotes a username and only +attributes owned by OWNER are considered. Attribute names are returned +as a list of strings. Attributes are returned as a list of strings." + (database-attribute-type (database-identifier attribute) + (database-identifier table) + database + :owner owner)) + +(defun list-attribute-types (table &key (owner nil) + (database *default-database*)) + "Returns type information for the attributes in TABLE from DATABASE +which has a default value of *default-database*. If OWNER is nil, only +user-owned attributes are considered. This is the default. If OWNER is +:all, all attributes are considered. If OWNER is a string, this +denotes a username and only attributes owned by OWNER are +considered. Returns a list in which each element is a list (attribute +datatype). Attribute is a string denoting the atribute name. Datatype +is the vendor-specific type returned by ATTRIBUTE-TYPE." + (mapcar #'(lambda (type) + (list type (attribute-type type table :database database + :owner owner))) + (list-attributes table :database database :owner owner))) + +;(defun add-attribute (table attribute &key (database *default-database*)) +; (database-add-attribute table attribute database)) + +;(defun rename-attribute (table oldatt newname +; &key (database *default-database*)) +; (error "(rename-attribute ~a ~a ~a ~a) is not implemented" +; table oldatt newname database)) + + +;; Sequences + +(defvar *sequence-schemas* (make-hash-table :test #'equal) + "Hash of schema name to sequence lists.") + +(defun create-sequence (name &key (database *default-database*)) + "Create a sequence called NAME in DATABASE which defaults to +*DEFAULT-DATABASE*." + (let ((sequence-name (database-identifier name))) + (database-create-sequence sequence-name database) + (pushnew sequence-name (gethash *default-schema* *sequence-schemas*) + :test #'equal)) + (values)) + +(defun drop-sequence (name &key (if-does-not-exist :error) + (database *default-database*)) + "Drops sequence NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the sequence does not exist and +IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil whereas an +error is signalled if IF-DOES-NOT-EXIST is :error." + (let ((sequence-name (database-identifier name))) + (ecase if-does-not-exist + (:ignore + (unless (sequence-exists-p sequence-name :database database) + (return-from drop-sequence))) + (:error t)) + (database-drop-sequence sequence-name database)) + (values)) + +(defun list-sequences (&key (owner nil) (database *default-database*)) + "List all sequences in DATABASE, which defaults to +*default-database*. If OWNER is nil, only user-owned sequences are +considered. This is the default. If OWNER is :all , all sequences are +considered. If OWNER is a string, this denotes a username and only +sequences owned by OWNER are considered. Sequence names are returned +as a list of strings." + (database-list-sequences database :owner owner)) + +(defun sequence-exists-p (name &key (owner nil) + (database *default-database*)) + "Test for existence of a sequence called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*." + (when (member (database-identifier name) + (list-sequences :owner owner :database database) + :test #'string-equal) + t)) + +(defun sequence-next (name &key (database *default-database*)) + "Return the next value in the sequence NAME in DATABASE." + (database-sequence-next (database-identifier name) database)) + +(defun set-sequence-position (name position &key (database *default-database*)) + "Explicitly set the the position of the sequence NAME in DATABASE to +POSITION." + (database-set-sequence-position (database-identifier name) position database)) + +(defun sequence-last (name &key (database *default-database*)) + "Return the last value of the sequence NAME in DATABASE." + (database-sequence-last (database-identifier name) database)) \ No newline at end of file diff --git a/tests/README b/tests/README new file mode 100644 index 0000000..c20387a --- /dev/null +++ b/tests/README @@ -0,0 +1,110 @@ +* REGRESSION TEST SUITE GOALS + +The intent of this test suite is to provide sufficient coverage for +the system to support the following: + +** Refactoring and Redesign of particular subsystems + +Refactoring and redesign efforts are normally restricted to a single +subsystem, or perhaps to interdependent subsystems. In such cases, a +set of regression tests which excercise the existing interface of the +rest of USQL to the changing subsystems should be in place and passing +before the coding starts. + +** Ensuring portability and Supporting new ports. + +The more coverage the test suite provides the easier portability is to +maintain, particularly if we have instances of the test suite running +against the head on the supporting lisp environment/OS/hardware/DBMS +combinations. Since no individual within the project has the ability +to run all of those combinations themselves, we are dependent upon some +informal coordination between the mintainers of the various ports. + +** Adding new RDBMS backends + +The entire USQL DBMS interface needs to be excercised by the test +suite, such that a new RDBMS backend that passes all the tests can be +reasonably assured of working with the USQL layers above that. These +tests should also serve as impromptu documentation for the details of +that interface and what it expects frothe RDBMS driver layers. + +** Bug identification and QA + +As new bugs are identified, they should have a regression test written +which excercises them. This is to ensue that we donot start +backtracking. These tests by theselves are also very valuable for +developers, so even if you cannot fix a bug yourself, providing a +testto excercise it greatly reduces the amount of timea developer must +spend finding the bug prior to fixing it. + + +* TEST DESIGN ISSUES + +** Multiple RDBMS Issues + +USQL supports several RDBMS backends, and it should be possible to run +every test against all of them. However, there are some features +which we want tests for but which are not implemented on several of +the backends. + +** Test Hygiene + +Tests should be able to be run multiple times against the same +database. It is also important that they clean up after themselves +when they create tables, sequences or other pesistent entities in the +RDBMS backends, because often there are limits to the number of those +thatcan exist at one time, and it also makes debuging thru the SQL +monitors difficult when there aretons of unused tables lying around. + +If test need to load large datasets, they should have a mechanism to +ensure the dataset is loaded just once, and not with every test run. + +Lastly, because there are various idiosyncracies with RDBMSs, please +ensure that you run the entire test suite once when you write your +tests, to ensure that your test does not leave some state behind which +causes other tests to fail. + +** Test Run Configuration + +The file test-init.lisp defines several variables which can be used to +control the connection dictionary of the database against which tests +will be run. + + +* DATABASE CONNECTIONS/LIFECYCLE + +** CreateDB + *** Without existing DB + *** With existing DB and use old + *** With existing DB and use new + *** Error if existing DB + +** Data Definition + *** Create Tables/Sequences/Indexes -- Should cover creation of + tables with all supported types of fields. + *** Delete Tables/Sequences/Indexes + *** Inspection of Tables and attributes, including types + +** Data Manipulation + *** Update + *** Insert + *** Delete + *** Query + +** Functional Interface + *** Creation/Modification of SQL expressions + *** Querying + +** Embedded SQL syntax + *** Excercise all sql operators + +** Object Interface + *** View class definition + *** Object creation/manipulation/deletion + *** Inter-object Relations + +** Editing Contexts + *** Object Create/Modification/Deletion in a context -- partly covered already + *** Interaction of multiple contexts + *** Schema manipulation within a context + *** Rollback and error handling within a context \ No newline at end of file diff --git a/tests/package.lisp b/tests/package.lisp new file mode 100644 index 0000000..7d111d6 --- /dev/null +++ b/tests/package.lisp @@ -0,0 +1,23 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: package.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 12:00:14 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Package definition for CLSQL-USQL test suite. +;;;; +;;;; ====================================================================== + + +(in-package #:cl-user) + +(defpackage #:clsql-usql-tests + (:nicknames #:usql-tests) + (:use #:clsql-usql #:common-lisp #:rtest) + (:export #:test-usql #:test-initialise-database #:test-connect-to-database) + (:documentation "Regression tests for CLSQL-USQL.")) diff --git a/tests/test-connection.lisp b/tests/test-connection.lisp new file mode 100644 index 0000000..7680917 --- /dev/null +++ b/tests/test-connection.lisp @@ -0,0 +1,24 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-connection.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:53:49 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for CLSQL-USQL database connections. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + + +(deftest :connection/1 + (let ((database (usql:find-database + (usql:database-name usql:*default-database*) + :db-type (usql:database-type usql:*default-database*)))) + (eql (usql:database-type database) *test-database-type*)) + t) diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp new file mode 100644 index 0000000..848bc84 --- /dev/null +++ b/tests/test-fddl.lisp @@ -0,0 +1,211 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-fddl.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:53:29 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Functional Data Definition Language +;;;; (FDDL). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + +;; list current tables +(deftest :fddl/table/1 + (apply #'values + (sort (mapcar #'string-downcase + (usql:list-tables :owner *test-database-user*)) + #'string>)) + "usql_object_v" "employee" "company") + +;; create a table, test for its existence, drop it and test again +(deftest :fddl/table/2 + (progn (usql:create-table [foo] + '(([id] integer) + ([height] float) + ([name] (string 24)) + ([comments] longchar))) + (values + (usql:table-exists-p [foo] :owner *test-database-user*) + (progn + (usql:drop-table [foo] :if-does-not-exist :ignore) + (usql:table-exists-p [foo] :owner *test-database-user*)))) + t nil) + +;; create a table, list its attributes and drop it +(deftest :fddl/table/3 + (apply #'values + (progn (usql:create-table [foo] + '(([id] integer) + ([height] float) + ([name] (char 255)) + ([comments] longchar))) + (prog1 + (sort (mapcar #'string-downcase + (usql:list-attributes [foo])) + #'string<) + (usql:drop-table [foo] :if-does-not-exist :ignore)))) + "comments" "height" "id" "name") + +(deftest :fddl/attributes/1 + (apply #'values + (sort + (mapcar #'string-downcase + (usql:list-attributes [employee] + :owner *test-database-user*)) + #'string<)) + "birthday" "companyid" "email" "emplid" "first_name" "groupid" "height" + "last_name" "managerid" "married") + +(deftest :fddl/attributes/2 + (apply #'values + (sort + (mapcar #'(lambda (a) (string-downcase (car a))) + (usql:list-attribute-types [employee] + :owner *test-database-user*)) + #'string<)) + "birthday" "companyid" "email" "emplid" "first_name" "groupid" "height" + "last_name" "managerid" "married") + +;; create a view, test for existence, drop it and test again +(deftest :fddl/view/1 + (progn (usql:create-view [lenins-group] + ;;not in sqlite + ;;:column-list '([forename] [surname] [email]) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (values + (usql:view-exists-p [lenins-group] :owner *test-database-user*) + (progn + (usql:drop-view [lenins-group] :if-does-not-exist :ignore) + (usql:view-exists-p [lenins-group] :owner *test-database-user*)))) + t nil) + +;; create a view, list its attributes and drop it +(deftest :fddl/view/2 + (progn (usql:create-view [lenins-group] + ;;not in sqlite + ;;:column-list '([forename] [surname] [email]) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (prog1 + (sort (mapcar #'string-downcase + (usql:list-attributes [lenins-group])) + #'string<) + (usql:drop-view [lenins-group] :if-does-not-exist :ignore))) + ("email" "first_name" "last_name")) + +;; create a view, select stuff from it and drop it +(deftest :fddl/view/3 + (progn (usql:create-view [lenins-group] + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (let ((result + (list + ;; Shouldn't exist + (usql:select [first-name] [last-name] [email] + :from [lenins-group] + :where [= [last-name] "Lenin"]) + ;; Should exist + (car (usql:select [first-name] [last-name] [email] + :from [lenins-group] + :where [= [last-name] "Stalin"]))))) + (usql:drop-view [lenins-group] :if-does-not-exist :ignore) + (apply #'values result))) + nil ("Josef" "Stalin" "stalin@soviet.org")) + +;; not in sqlite +(deftest :fddl/view/4 + (if (eql *test-database-type* :sqlite) + (values nil '(("Josef" "Stalin" "stalin@soviet.org"))) + (progn (usql:create-view [lenins-group] + :column-list '([forename] [surname] [email]) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (let ((result + (list + ;; Shouldn't exist + (usql:select [forename] [surname] [email] + :from [lenins-group] + :where [= [surname] "Lenin"]) + ;; Should exist + (car (usql:select [forename] [surname] [email] + :from [lenins-group] + :where [= [surname] "Stalin"]))))) + (usql:drop-view [lenins-group] :if-does-not-exist :ignore) + (apply #'values result)))) + nil ("Josef" "Stalin" "stalin@soviet.org")) + +;; create an index, test for existence, drop it and test again +(deftest :fddl/index/1 + (progn (usql:create-index [bar] :on [employee] :attributes + '([first-name] [last-name] [email]) :unique t) + (values + (usql:index-exists-p [bar] :owner *test-database-user*) + (progn + (case *test-database-type* + (:mysql + (usql:drop-index [bar] :on [employee] + :if-does-not-exist :ignore)) + (t + (usql:drop-index [bar]:if-does-not-exist :ignore))) + (usql:view-exists-p [bar] :owner *test-database-user*)))) + t nil) + +;; create indexes with names as strings, symbols and in square brackets +(deftest :fddl/index/2 + (let ((names '("foo" foo [foo])) + (result '())) + (dolist (name names) + (usql:create-index name :on [employee] :attributes '([emplid])) + (push (usql:index-exists-p name :owner *test-database-user*) result) + (case *test-database-type* + (:mysql + (usql:drop-index name :on [employee] :if-does-not-exist :ignore)) + (t (usql:drop-index name :if-does-not-exist :ignore)))) + (apply #'values result)) + t t t) + +;; create an sequence, test for existence, drop it and test again +(deftest :fddl/sequence/1 + (progn (usql:create-sequence [foo]) + (values + (usql:sequence-exists-p [foo] :owner *test-database-user*) + (progn + (usql:drop-sequence [foo] :if-does-not-exist :ignore) + (usql:sequence-exists-p [foo] :owner *test-database-user*)))) + t nil) + +;; create and increment a sequence +(deftest :fddl/sequence/2 + (let ((val1 nil)) + (usql:create-sequence [foo]) + (setf val1 (usql:sequence-next [foo])) + (prog1 + (< val1 (usql:sequence-next [foo])) + (usql:drop-sequence [foo] :if-does-not-exist :ignore))) + t) + +;; explicitly set the value of a sequence +(deftest :fddl/sequence/3 + (progn + (usql:create-sequence [foo]) + (usql:set-sequence-position [foo] 5) + (prog1 + (usql:sequence-next [foo]) + (usql:drop-sequence [foo] :if-does-not-exist :ignore))) + 6) + +#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp new file mode 100644 index 0000000..ae986fa --- /dev/null +++ b/tests/test-fdml.lisp @@ -0,0 +1,395 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-fdml.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:52:39 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Functional Data Manipulation Language +;;;; (FDML). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + +;; inserts a record using all values only and then deletes it +(deftest :fdml/insert/1 + (progn + (usql:insert-records :into [employee] + :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" + 1 1 1.85 t ,(clsql-base:get-time))) + (values + (usql:select [first-name] [last-name] [email] + :from [employee] :where [= [emplid] 11]) + (progn (usql:delete-records :from [employee] :where [= [emplid] 11]) + (usql:select [*] :from [employee] :where [= [emplid] 11])))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a record using attributes and values and then deletes it +(deftest :fdml/insert/2 + (progn + (usql:insert-records :into [employee] + :attributes '(emplid groupid first_name last_name + email companyid managerid) + :values '(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" + 1 1)) + (values + (usql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11]) + (progn (usql:delete-records :from [employee] :where [= [emplid] 11]) + (usql:select [*] :from [employee] :where [= [emplid] 11])))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a record using av-pairs and then deletes it +(deftest :fdml/insert/3 + (progn + (usql:insert-records :into [employee] + :av-pairs'((emplid 11) (groupid 1) + (first_name "Yuri") + (last_name "Gagarin") + (email "gagarin@soviet.org") + (companyid 1) (managerid 1))) + (values + (usql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11]) + (progn (usql:delete-records :from [employee] :where [= [emplid] 11]) + (usql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 11])))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) + +;; inserts a records using a query from another table +(deftest :fdml/insert/4 + (progn + (usql:create-table [employee2] '(([forename] string) + ([surname] string) + ([email] string))) + (usql:insert-records :into [employee2] + :query [select [first-name] [last-name] [email] + :from [employee]] + :attributes '(forename surname email)) + (prog1 + (equal (usql:select [*] :from [employee2]) + (usql:select [first-name] [last-name] [email] + :from [employee])) + (usql:drop-table [employee2] :if-does-not-exist :ignore))) + t) + +;; updates a record using attributes and values and then deletes it +(deftest :fdml/update/1 + (progn + (usql:update-records [employee] + :attributes '(first_name last_name email) + :values '("Yuri" "Gagarin" "gagarin@soviet.org") + :where [= [emplid] 1]) + (values + (usql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1]) + (progn + (usql:update-records [employee] + :av-pairs'((first_name "Vladamir") + (last_name "Lenin") + (email "lenin@soviet.org")) + :where [= [emplid] 1]) + (usql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1])))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) + (("Vladamir" "Lenin" "lenin@soviet.org"))) + +;; updates a record using av-pairs and then deletes it +(deftest :fdml/update/2 + (progn + (usql:update-records [employee] + :av-pairs'((first_name "Yuri") + (last_name "Gagarin") + (email "gagarin@soviet.org")) + :where [= [emplid] 1]) + (values + (usql:select [first-name] [last-name] [email] :from [employee] + :where [= [emplid] 1]) + (progn + (usql:update-records [employee] + :av-pairs'((first_name "Vladamir") + (last_name "Lenin") + (email "lenin@soviet.org")) + :where [= [emplid] 1]) + (usql:select [first-name] [last-name] [email] + :from [employee] :where [= [emplid] 1])))) + (("Yuri" "Gagarin" "gagarin@soviet.org")) + (("Vladamir" "Lenin" "lenin@soviet.org"))) + + +(deftest :fdml/query/1 + (usql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')") + (("10"))) + +(deftest :fdml/query/2 + (usql:query + "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME") + (("Leonid" "Brezhnev") ("Nikita" "Kruschev") ("Vladamir" "Lenin") + ("Josef" "Stalin") ("Leon" "Trotsky"))) + + +(deftest :fdml/execute-command/1 + (values + (usql:table-exists-p [foo] :owner *test-database-user*) + (progn + (usql:execute-command "create table foo (bar integer)") + (usql:table-exists-p [foo] :owner *test-database-user*)) + (progn + (usql:execute-command "drop table foo") + (usql:table-exists-p [foo] :owner *test-database-user*))) + nil t nil) + + +;; compare min, max and average hieghts in inches (they're quite short +;; these guys!) -- only works with pgsql +(deftest :fdml/select/1 + (if (member *test-database-type* '(:postgresql-socket :postgresql)) + (let ((max (usql:select [function "floor" + [/ [* [max [height]] 100] 2.54]] + :from [employee] + :flatp t)) + (min (usql:select [function "floor" + [/ [* [min [height]] 100] 2.54]] + :from [employee] + :flatp t)) + (avg (usql:select [function "floor" + [avg [/ [* [height] 100] 2.54]]] + :from [employee] + :flatp t))) + (apply #'< (mapcar #'parse-integer (append min avg max)))) + t) + t) + +(deftest :fdml/select/2 + (usql:select [first-name] :from [employee] :flatp t :distinct t + :order-by [first-name]) + ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladamir" + "Yuri")) + +(deftest :fdml/select/3 + (usql:select [first-name] [count [*]] :from [employee] + :group-by [first-name] + :order-by [first-name]) + (("Boris" "1") ("Josef" "1") ("Konstantin" "1") ("Leon" "1") ("Leonid" "1") + ("Mikhail" "1") ("Nikita" "1") ("Vladamir" "2") ("Yuri" "1"))) + +(deftest :fdml/select/4 + (usql:select [last-name] :from [employee] :where [like [email] "%org"] + :order-by [last-name] + :flatp t) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :fdml/select/5 + (usql:select [email] :from [employee] :flatp t + :where [in [employee emplid] + [select [managerid] :from [employee]]]) + ("lenin@soviet.org")) + +(deftest :fdml/select/6 + (if (member *test-database-type* '(:postgresql-socket :postgresql)) + (mapcar #'parse-integer + (usql:select [function "trunc" [height]] :from [employee] + :flatp t)) + (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) + (usql:select [height] :from [employee] :flatp t))) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :fdml/select/7 + (sql:select [max [emplid]] :from [employee] :flatp t) + ("10")) + +(deftest :fdml/select/8 + (sql:select [min [emplid]] :from [employee] :flatp t) + ("1")) + +(deftest :fdml/select/9 + (subseq (car (sql:select [avg [emplid]] :from [employee] :flatp t)) 0 3) + "5.5") + +(deftest :fdml/select/10 + (sql:select [last-name] :from [employee] + :where [not [in [emplid] + [select [managerid] :from [company]]]] + :flatp t + :order-by [last-name]) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" + "Trotsky" "Yeltsin")) + +(deftest :fdml/select/11 + (usql:select [last-name] :from [employee] :where [married] :flatp t + :order-by [emplid]) + ("Lenin" "Stalin" "Trotsky")) + +(deftest :fdml/select/12 + (let ((v 1)) + (usql:select [last-name] :from [employee] :where [= [emplid] v])) + (("Lenin"))) + +;(deftest :fdml/select/11 +; (sql:select [emplid] :from [employee] +; :where [= [emplid] [any [select [companyid] :from [company]]]] +; :flatp t) +; ("1")) + +(deftest :fdml/do-query/1 + (let ((result '())) + (usql:do-query ((name) [select [last-name] :from [employee] + :order-by [last-name]]) + (push name result)) + result) + ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev" + "Chernenko" "Brezhnev" "Andropov")) + +(deftest :fdml/map-query/1 + (usql:map-query 'list #'identity + [select [last-name] :from [employee] :flatp t + :order-by [last-name]]) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :fdml/map-query/2 + (usql:map-query 'vector #'identity + [select [last-name] :from [employee] :flatp t + :order-by [last-name]]) + #("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :fdml/loop/1 + (loop for (forename surname) + being each tuple in + [select [first-name] [last-name] :from [employee] :order-by [last-name]] + collect (concatenate 'string forename " " surname)) + ("Yuri Andropov" "Leonid Brezhnev" "Konstantin Chernenko" "Mikhail Gorbachev" + "Nikita Kruschev" "Vladamir Lenin" "Vladamir Putin" + "Josef Stalin" "Leon Trotsky" "Boris Yeltsin")) + +;; starts a transaction deletes a record and then rolls back the deletion +(deftest :fdml/transaction/1 + (let ((results '())) + ;; test if we are in a transaction + (push (usql:in-transaction-p) results) + ;;start a transaction + (usql:start-transaction) + ;; test if we are in a transaction + (push (usql:in-transaction-p) results) + ;;Putin has got to go + (unless (eql *test-database-type* :mysql) + (usql:delete-records :from [employee] :where [= [last-name] "Putin"])) + ;;Should be nil + (push + (usql:select [*] :from [employee] :where [= [last-name] "Putin"]) + results) + ;;Oh no, he's still there + (usql:rollback) + ;; test that we are out of the transaction + (push (usql:in-transaction-p) results) + ;; Check that we got him back alright + (push (usql:select [email] :from [employee] :where [= [last-name] "Putin"] + :flatp t) + results) + (apply #'values (nreverse results))) + nil t nil nil ("putin@soviet.org")) + +;; starts a transaction, updates a record and then rolls back the update +(deftest :fdml/transaction/2 + (let ((results '())) + ;; test if we are in a transaction + (push (usql:in-transaction-p) results) + ;;start a transaction + (usql:start-transaction) + ;; test if we are in a transaction + (push (usql:in-transaction-p) results) + ;;Putin has got to go + (unless (eql *test-database-type* :mysql) + (usql:update-records [employee] + :av-pairs '((email "putin-nospam@soviet.org")) + :where [= [last-name] "Putin"])) + ;;Should be new value + (push (usql:select [email] :from [employee] + :where [= [last-name] "Putin"] + :flatp t) + results) + ;;Oh no, he's still there + (usql:rollback) + ;; test that we are out of the transaction + (push (usql:in-transaction-p) results) + ;; Check that we got him back alright + (push (usql:select [email] :from [employee] :where [= [last-name] "Putin"] + :flatp t) + results) + (apply #'values (nreverse results))) + nil t ("putin-nospam@soviet.org") nil ("putin@soviet.org")) + +;; runs an update within a transaction and checks it is committed +(deftest :fdml/transaction/3 + (let ((results '())) + ;; check status + (push (usql:in-transaction-p) results) + ;; update records + (push + (usql:with-transaction () + (usql:update-records [employee] + :av-pairs '((email "lenin-nospam@soviet.org")) + :where [= [emplid] 1])) + results) + ;; check status + (push (usql:in-transaction-p) results) + ;; check that was committed + (push (usql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + ;; undo the changes + (push + (usql:with-transaction () + (usql:update-records [employee] + :av-pairs '((email "lenin@soviet.org")) + :where [= [emplid] 1])) + results) + ;; and check status + (push (usql:in-transaction-p) results) + ;; check that was committed + (push (usql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + (apply #'values (nreverse results))) + nil :COMMITTED nil ("lenin-nospam@soviet.org") :COMMITTED + nil ("lenin@soviet.org")) + +;; runs a valid update and an invalid one within a transaction and checks +;; that the valid update is rolled back when the invalid one fails. +(deftest :fdml/transaction/4 + (let ((results '())) + ;; check status + (push (usql:in-transaction-p) results) + (unless (eql *test-database-type* :mysql) + (handler-case + (usql:with-transaction () + ;; valid update + (usql:update-records [employee] + :av-pairs '((email "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + ;; invalid update which generates an error + (usql:update-records [employee] + :av-pairs + '((emale "lenin-nospam@soviet.org")) + :where [= [emplid] 1])) + (usql:clsql-sql-error () + (progn + ;; check status + (push (usql:in-transaction-p) results) + ;; and check nothing done + (push (usql:select [email] :from [employee] :where [= [emplid] 1] + :flatp t) + results) + (apply #'values (nreverse results))))))) + nil nil ("lenin@soviet.org")) + +#.(usql:restore-sql-reader-syntax-state) diff --git a/tests/test-init.lisp b/tests/test-init.lisp new file mode 100644 index 0000000..3334908 --- /dev/null +++ b/tests/test-init.lisp @@ -0,0 +1,316 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-init.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 12:14:38 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Initialisation utilities for running regression tests on CLSQL-USQL. +;;;; +;;;; ====================================================================== + +(in-package #:clsql-usql-tests) + +(defvar *test-database-type* nil) +(defvar *test-database-server* "") +(defvar *test-database-name* "") +(defvar *test-database-user* "") +(defvar *test-database-password* "") + +(defclass thing () + ((extraterrestrial :initform nil :initarg :extraterrestrial))) + +(def-view-class person (thing) + ((height :db-kind :base :accessor height :type float :nulls-ok t + :initarg :height) + (married :db-kind :base :accessor married :type boolean :nulls-ok t + :initarg :married) + (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday) + (hobby :db-kind :virtual :initarg :hobby :initform nil))) + +(def-view-class employee (person) + ((emplid + :db-kind :key + :db-constraints :not-null + :nulls-ok nil + :type integer + :initarg :emplid) + (groupid + :db-kind :key + :db-constraints :not-null + :nulls-ok nil + :type integer + :initarg :groupid) + (first-name + :accessor first-name + :type (string 30) + :initarg :first-name) + (last-name + :accessor last-name + :type (string 30) + :initarg :last-name) + (email + :accessor employee-email + :type (string 100) + :nulls-ok t + :initarg :email) + (companyid + :type integer) + (company + :accessor employee-company + :db-kind :join + :db-info (:join-class company + :home-key companyid + :foreign-key companyid + :set nil)) + (managerid + :type integer + :nulls-ok t) + (manager + :accessor employee-manager + :db-kind :join + :db-info (:join-class employee + :home-key managerid + :foreign-key emplid + :set nil))) + (:base-table employee)) + +(def-view-class company () + ((companyid + :db-type :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (groupid + :db-type :key + :db-constraints :not-null + :type integer + :initarg :groupid) + (name + :type (string 100) + :initarg :name) + (presidentid + :type integer) + (president + :reader president + :db-kind :join + :db-info (:join-class employee + :home-key presidentid + :foreign-key emplid + :set nil)) + (employees + :reader company-employees + :db-kind :join + :db-info (:join-class employee + :home-key (companyid groupid) + :foreign-key (companyid groupid) + :set t))) + (:base-table company)) + +(defparameter company1 (make-instance 'company + :companyid 1 + :groupid 1 + :name "Widgets Inc.")) + +(defparameter employee1 (make-instance 'employee + :emplid 1 + :groupid 1 + :married t + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Vladamir" + :last-name "Lenin" + :email "lenin@soviet.org")) + +(defparameter employee2 (make-instance 'employee + :emplid 2 + :groupid 1 + :height (1+ (random 1.00)) + :married t + :birthday (clsql-base:get-time) + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org")) + +(defparameter employee3 (make-instance 'employee + :emplid 3 + :groupid 1 + :height (1+ (random 1.00)) + :married t + :birthday (clsql-base:get-time) + :first-name "Leon" + :last-name "Trotsky" + :email "trotsky@soviet.org")) + +(defparameter employee4 (make-instance 'employee + :emplid 4 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :birthday (clsql-base:get-time) + :first-name "Nikita" + :last-name "Kruschev" + :email "kruschev@soviet.org")) + +(defparameter employee5 (make-instance 'employee + :emplid 5 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Leonid" + :last-name "Brezhnev" + :email "brezhnev@soviet.org")) + +(defparameter employee6 (make-instance 'employee + :emplid 6 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Yuri" + :last-name "Andropov" + :email "andropov@soviet.org")) + +(defparameter employee7 (make-instance 'employee + :emplid 7 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :birthday (clsql-base:get-time) + :first-name "Konstantin" + :last-name "Chernenko" + :email "chernenko@soviet.org")) + +(defparameter employee8 (make-instance 'employee + :emplid 8 + :groupid 1 + :height (1+ (random 1.00)) + :married nil + :birthday (clsql-base:get-time) + :first-name "Mikhail" + :last-name "Gorbachev" + :email "gorbachev@soviet.org")) + +(defparameter employee9 (make-instance 'employee + :emplid 9 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Boris" + :last-name "Yeltsin" + :email "yeltsin@soviet.org")) + +(defparameter employee10 (make-instance 'employee + :emplid 10 + :groupid 1 + :married nil + :height (1+ (random 1.00)) + :birthday (clsql-base:get-time) + :first-name "Vladamir" + :last-name "Putin" + :email "putin@soviet.org")) + +(defun test-database-connection-spec () + (let ((dbserver *test-database-server*) + (dbname *test-database-name*) + (dbpassword *test-database-password*) + (dbtype *test-database-type*) + (username *test-database-user*)) + (case dbtype + (:postgresql + `("" ,dbname ,username ,dbpassword)) + (:postgresql-socket + `(,dbserver ,dbname ,username ,dbpassword)) + (:mysql + `("" ,dbname ,username ,dbpassword)) + (:sqlite + `(,dbname)) + (:oracle + `(,username ,dbpassword ,dbname)) + (t + (error "Unrecognized database type: ~A" dbtype))))) + +(defun test-connect-to-database (database-type) + (setf *test-database-type* database-type) + ;; Connect to the database + (usql:connect (test-database-connection-spec) + :database-type database-type + :make-default t + :if-exists :old)) + +(defmacro with-ignore-errors (&rest forms) + `(progn + ,@(mapcar + (lambda (x) (list 'ignore-errors x)) + forms))) + +(defun test-initialise-database () + ;; Delete the instance records + (with-ignore-errors + (usql:delete-instance-records company1) + (usql:delete-instance-records employee1) + (usql:delete-instance-records employee2) + (usql:delete-instance-records employee3) + (usql:delete-instance-records employee4) + (usql:delete-instance-records employee5) + (usql:delete-instance-records employee6) + (usql:delete-instance-records employee7) + (usql:delete-instance-records employee8) + (usql:delete-instance-records employee9) + (usql:delete-instance-records employee10) + ;; Drop the required tables if they exist + (usql:drop-view-from-class 'employee) + (usql:drop-view-from-class 'company)) + ;; Create the tables for our view classes + (usql:create-view-from-class 'employee) + (usql:create-view-from-class 'company) + ;; Lenin manages everyone + (usql:add-to-relation employee2 'manager employee1) + (usql:add-to-relation employee3 'manager employee1) + (usql:add-to-relation employee4 'manager employee1) + (usql:add-to-relation employee5 'manager employee1) + (usql:add-to-relation employee6 'manager employee1) + (usql:add-to-relation employee7 'manager employee1) + (usql:add-to-relation employee8 'manager employee1) + (usql:add-to-relation employee9 'manager employee1) + (usql:add-to-relation employee10 'manager employee1) + ;; Everyone works for Widgets Inc. + (usql:add-to-relation company1 'employees employee1) + (usql:add-to-relation company1 'employees employee2) + (usql:add-to-relation company1 'employees employee3) + (usql:add-to-relation company1 'employees employee4) + (usql:add-to-relation company1 'employees employee5) + (usql:add-to-relation company1 'employees employee6) + (usql:add-to-relation company1 'employees employee7) + (usql:add-to-relation company1 'employees employee8) + (usql:add-to-relation company1 'employees employee9) + (usql:add-to-relation company1 'employees employee10) + ;; Lenin is president of Widgets Inc. + (usql:add-to-relation company1 'president employee1) + ;; store these instances + (usql:update-records-from-instance employee1) + (usql:update-records-from-instance employee2) + (usql:update-records-from-instance employee3) + (usql:update-records-from-instance employee4) + (usql:update-records-from-instance employee5) + (usql:update-records-from-instance employee6) + (usql:update-records-from-instance employee7) + (usql:update-records-from-instance employee8) + (usql:update-records-from-instance employee9) + (usql:update-records-from-instance employee10) + (usql:update-records-from-instance company1)) + +(defun test-usql (backend) + (format t "~&Running CLSQL-USQL tests with ~A backend.~%" backend) + (test-connect-to-database backend) + (test-initialise-database) + (rtest:do-tests)) + + + diff --git a/tests/test-ooddl.lisp b/tests/test-ooddl.lisp new file mode 100644 index 0000000..aed7700 --- /dev/null +++ b/tests/test-ooddl.lisp @@ -0,0 +1,87 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-ooddl.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:52:11 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Object Oriented Data Definition Language +;;;; (OODDL). +;;;; +;;;; ====================================================================== + + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + +;; Ensure slots inherited from standard-classes are :virtual +(deftest :ooddl/metaclass/1 + (values + (usql-sys::view-class-slot-db-kind + (usql-sys::slotdef-for-slot-with-class 'extraterrestrial + (find-class 'person))) + (usql-sys::view-class-slot-db-kind + (usql-sys::slotdef-for-slot-with-class 'hobby (find-class 'person)))) + :virtual :virtual) + +;; Ensure all slots in view-class are view-class-effective-slot-definition +(deftest :ooddl/metaclass/2 + (values + (every #'(lambda (slotd) + (typep slotd 'usql-sys::view-class-effective-slot-definition)) + (usql-sys::class-slots (find-class 'person))) + (every #'(lambda (slotd) + (typep slotd 'usql-sys::view-class-effective-slot-definition)) + (usql-sys::class-slots (find-class 'employee))) + (every #'(lambda (slotd) + (typep slotd 'usql-sys::view-class-effective-slot-definition)) + (usql-sys::class-slots (find-class 'company)))) + t t t) + +(deftest :ooddl/join/1 + (mapcar #'(lambda (e) + (slot-value e 'companyid)) + (company-employees company1)) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :ooddl/join/2 + (slot-value (president company1) 'last-name) + "Lenin") + +(deftest :ooddl/join/3 + (slot-value (employee-manager employee2) 'last-name) + "Lenin") + +(deftest :ooddl/time/1 + (let* ((now (clsql-base:get-time))) + (when (member *test-database-type* '(:postgresql :postgresql-socket)) + (usql:execute-command "set datestyle to 'iso'")) + (usql:update-records [employee] :av-pairs `((birthday ,now)) + :where [= [emplid] 1]) + (let ((dbobj (car (usql:select 'employee :where [= [birthday] now])))) + (values + (slot-value dbobj 'last-name) + (clsql-base:time= (slot-value dbobj 'birthday) now)))) + "Lenin" t) + +(deftest :ooddl/time/2 + (let* ((now (clsql-base:get-time)) + (fail-index -1)) + (when (member *test-database-type* '(:postgresql :postgresql-socket)) + (usql:execute-command "set datestyle to 'iso'")) + (dotimes (x 40) + (usql:update-records [employee] :av-pairs `((birthday ,now)) + :where [= [emplid] 1]) + (let ((dbobj (car (usql:select 'employee :where [= [birthday] now])))) + (unless (clsql-base:time= (slot-value dbobj 'birthday) now) + (setf fail-index x)) + (setf now (clsql-base:roll now :day (* 10 x))))) + fail-index) + -1) + +#.(usql:restore-sql-reader-syntax-state) diff --git a/tests/test-oodml.lisp b/tests/test-oodml.lisp new file mode 100644 index 0000000..f0cd3b0 --- /dev/null +++ b/tests/test-oodml.lisp @@ -0,0 +1,241 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-oodml.lisp +;;;; Author: Marcus Pearce +;;;; Created: 01/04/2004 +;;;; Updated: <04/04/2004 11:51:23 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Object Oriented Data Definition Language +;;;; (OODML). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + +(deftest :oodml/select/1 + (mapcar #'(lambda (e) (slot-value e 'last-name)) + (usql:select 'employee :order-by [last-name])) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :oodml/select/2 + (mapcar #'(lambda (e) (slot-value e 'name)) + (usql:select 'company)) + ("Widgets Inc.")) + +(deftest :oodml/select/3 + (mapcar #'(lambda (e) (slot-value e 'companyid)) + (usql:select 'employee + :where [and [= [slot-value 'employee 'companyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]])) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :oodml/select/4 + (mapcar #'(lambda (e) + (concatenate 'string (slot-value e 'first-name) + " " + (slot-value e 'last-name))) + (usql:select 'employee :where [= [slot-value 'employee 'first-name] + "Vladamir"] + :order-by [last-name])) + ("Vladamir Lenin" "Vladamir Putin")) + +;; sqlite fails this because it is typeless +(deftest :oodml/select/5 + (length (sql:select 'employee :where [married])) + 3) + +;; tests update-records-from-instance +(deftest :oodml/update-records/1 + (values + (progn + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (usql:update-records-from-instance employee1) + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Vladamir" + (slot-value employee1 'last-name) "Lenin" + (slot-value employee1 'email) "lenin@soviet.org") + (usql:update-records-from-instance employee1) + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))))) + "Vladamir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org" + "Vladamir Lenin: lenin@soviet.org") + +;; tests update-record-from-slot +(deftest :oodml/update-records/2 + (values + (employee-email + (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] 1]))) + (progn + (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") + (usql:update-record-from-slot employee1 'email) + (employee-email + (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] 1])))) + (progn + (setf (slot-value employee1 'email) "lenin@soviet.org") + (usql:update-record-from-slot employee1 'email) + (employee-email + (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] 1]))))) + "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") + +;; tests update-record-from-slots +(deftest :oodml/update-records/3 + (values + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (usql:update-record-from-slots employee1 '(first-name last-name email)) + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Vladamir" + (slot-value employee1 'last-name) "Lenin" + (slot-value employee1 'email) "lenin@soviet.org") + (usql:update-record-from-slots employee1 '(first-name last-name email)) + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))))) + "Vladamir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org" + "Vladamir Lenin: lenin@soviet.org") + +;; tests update-instance-from-records +(deftest :oodml/update-instance/1 + (values + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email)) + (progn + (usql:update-records [employee] + :av-pairs '(([first-name] "Ivan") + ([last-name] "Petrov") + ([email] "petrov@soviet.org")) + :where [= [emplid] 1]) + (usql:update-instance-from-records employee1) + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email))) + (progn + (usql:update-records [employee] + :av-pairs '(([first-name] "Vladamir") + ([last-name] "Lenin") + ([email] "lenin@soviet.org")) + :where [= [emplid] 1]) + (usql:update-instance-from-records employee1) + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email)))) + "Vladamir Lenin: lenin@soviet.org" + "Ivan Petrov: petrov@soviet.org" + "Vladamir Lenin: lenin@soviet.org") + +;; tests update-slot-from-record +(deftest :oodml/update-instance/2 + (values + (slot-value employee1 'email) + (progn + (usql:update-records [employee] + :av-pairs '(([email] "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + (usql:update-slot-from-record employee1 'email) + (slot-value employee1 'email)) + (progn + (usql:update-records [employee] + :av-pairs '(([email] "lenin@soviet.org")) + :where [= [emplid] 1]) + (usql:update-slot-from-record employee1 'email) + (slot-value employee1 'email))) + "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") + + +;(deftest :oodml/iteration/1 +; (usql:do-query ((e) [select 'usql-tests::employee :where [married] +; :order-by [emplid]]) +; (slot-value e last-name)) +; ("Lenin" "Stalin" "Trotsky")) + +;(deftest :oodml/iteration/2 +; (usql:map-query 'list #'last-name [select 'employee :where [married] +; :order-by [emplid]]) +; ("Lenin" "Stalin" "Trotsky")) + +;(deftest :oodml/iteration/3 +; (loop for (e) being the tuples in +; [select 'employee :where [married] :order-by [emplid]] +; collect (slot-value e 'last-name)) +; ("Lenin" "Stalin" "Trotsky")) + + +#.(usql:restore-sql-reader-syntax-state) diff --git a/tests/test-syntax.lisp b/tests/test-syntax.lisp new file mode 100644 index 0000000..e71d863 --- /dev/null +++ b/tests/test-syntax.lisp @@ -0,0 +1,162 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-syntax.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:51:40 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Symbolic SQL syntax. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + + +(deftest :syntax/generic/1 + (usql:sql "foo") + "'foo'") + +(deftest :syntax/generic/2 + (usql:sql 23) + "23") + +(deftest :syntax/generic/3 + (usql:sql 'bar) + "BAR") + +(deftest :syntax/generic/4 + (usql:sql '("ten" 10 ten)) + "('ten',10,TEN)") + +(deftest :syntax/generic/5 + (usql:sql ["SELECT FOO,BAR FROM BAZ"]) + "SELECT FOO,BAR FROM BAZ") + + +(deftest :syntax/ident/1 + (usql:sql [foo]) + "FOO") + +(deftest :syntax/ident/2 + (usql:sql [foo bar]) + "FOO.BAR") + +;; not sure about this one +(deftest :syntax/ident/3 + (usql:sql ["foo" bar]) + "foo.BAR") + +;(deftest :syntax/ident/4 +; (usql:sql [foo "bar"]) +; "FOO \"bar\"") + +(deftest :syntax/ident/5 + (usql:sql [foo :integer]) + "FOO INTEGER") + +(deftest :syntax/ident/6 + (usql:sql [foo bar :integer]) + "FOO.BAR INTEGER") + +;; not sure about this one +(deftest :syntax/ident/7 + (usql:sql ["foo" bar :integer]) + "foo.BAR INTEGER") + + +(deftest :syntax/value/1 + (usql:sql [any '(3 4)]) + "(ANY ((3,4)))") + +(deftest :syntax/value/2 + (usql:sql [* 2 3]) + "(2 * 3)") + + +(deftest :syntax/relational/1 + (usql:sql [> [baz] [beep]]) + "(BAZ > BEEP)") + +(deftest :syntax/relational/2 + (let ((x 10)) + (usql:sql [> [foo] x])) + "(FOO > 10)") + + +(deftest :syntax/function/1 + (usql:sql [function "COS" [age]]) + "COS(AGE)") + +(deftest :syntax/function/2 + (usql:sql [function "TO_DATE" "02/06/99" "mm/DD/RR"]) + "TO_DATE('02/06/99','mm/DD/RR')") + +(deftest :syntax/query/1 + (usql:sql [select [person_id] [surname] :from [person]]) + "SELECT PERSON_ID,SURNAME FROM PERSON") + +(deftest :syntax/query/2 + (usql:sql [select [foo] [bar *] + :from '([baz] [bar]) + :where [or [= [foo] 3] + [> [baz.quux] 10]]]) + "SELECT FOO,BAR.* FROM BAZ,BAR WHERE ((FOO = 3) OR (BAZ.QUUX > 10))") + +(deftest :syntax/query/3 + (usql:sql [select [foo bar] [baz] + :from '([foo] [quux]) + :where [or [> [baz] 3] + [like [foo bar] "SU%"]]]) + "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))") + +(deftest :syntax/query/4 + (usql:sql [select [count [*]] :from [emp]]) + "SELECT COUNT(*) FROM EMP") + + +(deftest :syntax/expression1 + (usql:sql + (usql:sql-operation + 'select + (usql:sql-expression :table 'foo :attribute 'bar) + (usql:sql-expression :attribute 'baz) + :from (list + (usql:sql-expression :table 'foo) + (usql:sql-expression :table 'quux)) + :where + (usql:sql-operation 'or + (usql:sql-operation + '> + (usql:sql-expression :attribute 'baz) + 3) + (usql:sql-operation + 'like + (usql:sql-expression :table 'foo + :attribute 'bar) + "SU%")))) + "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))") + +(deftest :syntax/expression/2 + (usql:sql + (apply (usql:sql-operator 'and) + (loop for table in '(thistime nexttime sometime never) + for count from 42 + collect + [function "BETWEEN" + (usql:sql-expression :table table + :attribute 'bar) + (usql:sql-operation '* [hip] [hop]) + count] + collect + [like (usql:sql-expression :table table + :attribute 'baz) + (usql:sql table)]))) + "(BETWEEN(THISTIME.BAR,(HIP * HOP),42) AND (THISTIME.BAZ LIKE 'THISTIME') AND BETWEEN(NEXTTIME.BAR,(HIP * HOP),43) AND (NEXTTIME.BAZ LIKE 'NEXTTIME') AND BETWEEN(SOMETIME.BAR,(HIP * HOP),44) AND (SOMETIME.BAZ LIKE 'SOMETIME') AND BETWEEN(NEVER.BAR,(HIP * HOP),45) AND (NEVER.BAZ LIKE 'NEVER'))") + +#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file diff --git a/usql-tests/README b/usql-tests/README deleted file mode 100644 index c20387a..0000000 --- a/usql-tests/README +++ /dev/null @@ -1,110 +0,0 @@ -* REGRESSION TEST SUITE GOALS - -The intent of this test suite is to provide sufficient coverage for -the system to support the following: - -** Refactoring and Redesign of particular subsystems - -Refactoring and redesign efforts are normally restricted to a single -subsystem, or perhaps to interdependent subsystems. In such cases, a -set of regression tests which excercise the existing interface of the -rest of USQL to the changing subsystems should be in place and passing -before the coding starts. - -** Ensuring portability and Supporting new ports. - -The more coverage the test suite provides the easier portability is to -maintain, particularly if we have instances of the test suite running -against the head on the supporting lisp environment/OS/hardware/DBMS -combinations. Since no individual within the project has the ability -to run all of those combinations themselves, we are dependent upon some -informal coordination between the mintainers of the various ports. - -** Adding new RDBMS backends - -The entire USQL DBMS interface needs to be excercised by the test -suite, such that a new RDBMS backend that passes all the tests can be -reasonably assured of working with the USQL layers above that. These -tests should also serve as impromptu documentation for the details of -that interface and what it expects frothe RDBMS driver layers. - -** Bug identification and QA - -As new bugs are identified, they should have a regression test written -which excercises them. This is to ensue that we donot start -backtracking. These tests by theselves are also very valuable for -developers, so even if you cannot fix a bug yourself, providing a -testto excercise it greatly reduces the amount of timea developer must -spend finding the bug prior to fixing it. - - -* TEST DESIGN ISSUES - -** Multiple RDBMS Issues - -USQL supports several RDBMS backends, and it should be possible to run -every test against all of them. However, there are some features -which we want tests for but which are not implemented on several of -the backends. - -** Test Hygiene - -Tests should be able to be run multiple times against the same -database. It is also important that they clean up after themselves -when they create tables, sequences or other pesistent entities in the -RDBMS backends, because often there are limits to the number of those -thatcan exist at one time, and it also makes debuging thru the SQL -monitors difficult when there aretons of unused tables lying around. - -If test need to load large datasets, they should have a mechanism to -ensure the dataset is loaded just once, and not with every test run. - -Lastly, because there are various idiosyncracies with RDBMSs, please -ensure that you run the entire test suite once when you write your -tests, to ensure that your test does not leave some state behind which -causes other tests to fail. - -** Test Run Configuration - -The file test-init.lisp defines several variables which can be used to -control the connection dictionary of the database against which tests -will be run. - - -* DATABASE CONNECTIONS/LIFECYCLE - -** CreateDB - *** Without existing DB - *** With existing DB and use old - *** With existing DB and use new - *** Error if existing DB - -** Data Definition - *** Create Tables/Sequences/Indexes -- Should cover creation of - tables with all supported types of fields. - *** Delete Tables/Sequences/Indexes - *** Inspection of Tables and attributes, including types - -** Data Manipulation - *** Update - *** Insert - *** Delete - *** Query - -** Functional Interface - *** Creation/Modification of SQL expressions - *** Querying - -** Embedded SQL syntax - *** Excercise all sql operators - -** Object Interface - *** View class definition - *** Object creation/manipulation/deletion - *** Inter-object Relations - -** Editing Contexts - *** Object Create/Modification/Deletion in a context -- partly covered already - *** Interaction of multiple contexts - *** Schema manipulation within a context - *** Rollback and error handling within a context \ No newline at end of file diff --git a/usql-tests/package.lisp b/usql-tests/package.lisp deleted file mode 100644 index 7d111d6..0000000 --- a/usql-tests/package.lisp +++ /dev/null @@ -1,23 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: package.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 12:00:14 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Package definition for CLSQL-USQL test suite. -;;;; -;;;; ====================================================================== - - -(in-package #:cl-user) - -(defpackage #:clsql-usql-tests - (:nicknames #:usql-tests) - (:use #:clsql-usql #:common-lisp #:rtest) - (:export #:test-usql #:test-initialise-database #:test-connect-to-database) - (:documentation "Regression tests for CLSQL-USQL.")) diff --git a/usql-tests/test-connection.lisp b/usql-tests/test-connection.lisp deleted file mode 100644 index 7680917..0000000 --- a/usql-tests/test-connection.lisp +++ /dev/null @@ -1,24 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: test-connection.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 11:53:49 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Tests for CLSQL-USQL database connections. -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-tests) - - -(deftest :connection/1 - (let ((database (usql:find-database - (usql:database-name usql:*default-database*) - :db-type (usql:database-type usql:*default-database*)))) - (eql (usql:database-type database) *test-database-type*)) - t) diff --git a/usql-tests/test-fddl.lisp b/usql-tests/test-fddl.lisp deleted file mode 100644 index 848bc84..0000000 --- a/usql-tests/test-fddl.lisp +++ /dev/null @@ -1,211 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: test-fddl.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 11:53:29 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Tests for the CLSQL-USQL Functional Data Definition Language -;;;; (FDDL). -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-tests) - -#.(usql:locally-enable-sql-reader-syntax) - -;; list current tables -(deftest :fddl/table/1 - (apply #'values - (sort (mapcar #'string-downcase - (usql:list-tables :owner *test-database-user*)) - #'string>)) - "usql_object_v" "employee" "company") - -;; create a table, test for its existence, drop it and test again -(deftest :fddl/table/2 - (progn (usql:create-table [foo] - '(([id] integer) - ([height] float) - ([name] (string 24)) - ([comments] longchar))) - (values - (usql:table-exists-p [foo] :owner *test-database-user*) - (progn - (usql:drop-table [foo] :if-does-not-exist :ignore) - (usql:table-exists-p [foo] :owner *test-database-user*)))) - t nil) - -;; create a table, list its attributes and drop it -(deftest :fddl/table/3 - (apply #'values - (progn (usql:create-table [foo] - '(([id] integer) - ([height] float) - ([name] (char 255)) - ([comments] longchar))) - (prog1 - (sort (mapcar #'string-downcase - (usql:list-attributes [foo])) - #'string<) - (usql:drop-table [foo] :if-does-not-exist :ignore)))) - "comments" "height" "id" "name") - -(deftest :fddl/attributes/1 - (apply #'values - (sort - (mapcar #'string-downcase - (usql:list-attributes [employee] - :owner *test-database-user*)) - #'string<)) - "birthday" "companyid" "email" "emplid" "first_name" "groupid" "height" - "last_name" "managerid" "married") - -(deftest :fddl/attributes/2 - (apply #'values - (sort - (mapcar #'(lambda (a) (string-downcase (car a))) - (usql:list-attribute-types [employee] - :owner *test-database-user*)) - #'string<)) - "birthday" "companyid" "email" "emplid" "first_name" "groupid" "height" - "last_name" "managerid" "married") - -;; create a view, test for existence, drop it and test again -(deftest :fddl/view/1 - (progn (usql:create-view [lenins-group] - ;;not in sqlite - ;;:column-list '([forename] [surname] [email]) - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (values - (usql:view-exists-p [lenins-group] :owner *test-database-user*) - (progn - (usql:drop-view [lenins-group] :if-does-not-exist :ignore) - (usql:view-exists-p [lenins-group] :owner *test-database-user*)))) - t nil) - -;; create a view, list its attributes and drop it -(deftest :fddl/view/2 - (progn (usql:create-view [lenins-group] - ;;not in sqlite - ;;:column-list '([forename] [surname] [email]) - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (prog1 - (sort (mapcar #'string-downcase - (usql:list-attributes [lenins-group])) - #'string<) - (usql:drop-view [lenins-group] :if-does-not-exist :ignore))) - ("email" "first_name" "last_name")) - -;; create a view, select stuff from it and drop it -(deftest :fddl/view/3 - (progn (usql:create-view [lenins-group] - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (let ((result - (list - ;; Shouldn't exist - (usql:select [first-name] [last-name] [email] - :from [lenins-group] - :where [= [last-name] "Lenin"]) - ;; Should exist - (car (usql:select [first-name] [last-name] [email] - :from [lenins-group] - :where [= [last-name] "Stalin"]))))) - (usql:drop-view [lenins-group] :if-does-not-exist :ignore) - (apply #'values result))) - nil ("Josef" "Stalin" "stalin@soviet.org")) - -;; not in sqlite -(deftest :fddl/view/4 - (if (eql *test-database-type* :sqlite) - (values nil '(("Josef" "Stalin" "stalin@soviet.org"))) - (progn (usql:create-view [lenins-group] - :column-list '([forename] [surname] [email]) - :as [select [first-name] [last-name] [email] - :from [employee] - :where [= [managerid] 1]]) - (let ((result - (list - ;; Shouldn't exist - (usql:select [forename] [surname] [email] - :from [lenins-group] - :where [= [surname] "Lenin"]) - ;; Should exist - (car (usql:select [forename] [surname] [email] - :from [lenins-group] - :where [= [surname] "Stalin"]))))) - (usql:drop-view [lenins-group] :if-does-not-exist :ignore) - (apply #'values result)))) - nil ("Josef" "Stalin" "stalin@soviet.org")) - -;; create an index, test for existence, drop it and test again -(deftest :fddl/index/1 - (progn (usql:create-index [bar] :on [employee] :attributes - '([first-name] [last-name] [email]) :unique t) - (values - (usql:index-exists-p [bar] :owner *test-database-user*) - (progn - (case *test-database-type* - (:mysql - (usql:drop-index [bar] :on [employee] - :if-does-not-exist :ignore)) - (t - (usql:drop-index [bar]:if-does-not-exist :ignore))) - (usql:view-exists-p [bar] :owner *test-database-user*)))) - t nil) - -;; create indexes with names as strings, symbols and in square brackets -(deftest :fddl/index/2 - (let ((names '("foo" foo [foo])) - (result '())) - (dolist (name names) - (usql:create-index name :on [employee] :attributes '([emplid])) - (push (usql:index-exists-p name :owner *test-database-user*) result) - (case *test-database-type* - (:mysql - (usql:drop-index name :on [employee] :if-does-not-exist :ignore)) - (t (usql:drop-index name :if-does-not-exist :ignore)))) - (apply #'values result)) - t t t) - -;; create an sequence, test for existence, drop it and test again -(deftest :fddl/sequence/1 - (progn (usql:create-sequence [foo]) - (values - (usql:sequence-exists-p [foo] :owner *test-database-user*) - (progn - (usql:drop-sequence [foo] :if-does-not-exist :ignore) - (usql:sequence-exists-p [foo] :owner *test-database-user*)))) - t nil) - -;; create and increment a sequence -(deftest :fddl/sequence/2 - (let ((val1 nil)) - (usql:create-sequence [foo]) - (setf val1 (usql:sequence-next [foo])) - (prog1 - (< val1 (usql:sequence-next [foo])) - (usql:drop-sequence [foo] :if-does-not-exist :ignore))) - t) - -;; explicitly set the value of a sequence -(deftest :fddl/sequence/3 - (progn - (usql:create-sequence [foo]) - (usql:set-sequence-position [foo] 5) - (prog1 - (usql:sequence-next [foo]) - (usql:drop-sequence [foo] :if-does-not-exist :ignore))) - 6) - -#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file diff --git a/usql-tests/test-fdml.lisp b/usql-tests/test-fdml.lisp deleted file mode 100644 index ae986fa..0000000 --- a/usql-tests/test-fdml.lisp +++ /dev/null @@ -1,395 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: test-fdml.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 11:52:39 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Tests for the CLSQL-USQL Functional Data Manipulation Language -;;;; (FDML). -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-tests) - -#.(usql:locally-enable-sql-reader-syntax) - -;; inserts a record using all values only and then deletes it -(deftest :fdml/insert/1 - (progn - (usql:insert-records :into [employee] - :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" - 1 1 1.85 t ,(clsql-base:get-time))) - (values - (usql:select [first-name] [last-name] [email] - :from [employee] :where [= [emplid] 11]) - (progn (usql:delete-records :from [employee] :where [= [emplid] 11]) - (usql:select [*] :from [employee] :where [= [emplid] 11])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) - -;; inserts a record using attributes and values and then deletes it -(deftest :fdml/insert/2 - (progn - (usql:insert-records :into [employee] - :attributes '(emplid groupid first_name last_name - email companyid managerid) - :values '(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" - 1 1)) - (values - (usql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 11]) - (progn (usql:delete-records :from [employee] :where [= [emplid] 11]) - (usql:select [*] :from [employee] :where [= [emplid] 11])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) - -;; inserts a record using av-pairs and then deletes it -(deftest :fdml/insert/3 - (progn - (usql:insert-records :into [employee] - :av-pairs'((emplid 11) (groupid 1) - (first_name "Yuri") - (last_name "Gagarin") - (email "gagarin@soviet.org") - (companyid 1) (managerid 1))) - (values - (usql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 11]) - (progn (usql:delete-records :from [employee] :where [= [emplid] 11]) - (usql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 11])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) nil) - -;; inserts a records using a query from another table -(deftest :fdml/insert/4 - (progn - (usql:create-table [employee2] '(([forename] string) - ([surname] string) - ([email] string))) - (usql:insert-records :into [employee2] - :query [select [first-name] [last-name] [email] - :from [employee]] - :attributes '(forename surname email)) - (prog1 - (equal (usql:select [*] :from [employee2]) - (usql:select [first-name] [last-name] [email] - :from [employee])) - (usql:drop-table [employee2] :if-does-not-exist :ignore))) - t) - -;; updates a record using attributes and values and then deletes it -(deftest :fdml/update/1 - (progn - (usql:update-records [employee] - :attributes '(first_name last_name email) - :values '("Yuri" "Gagarin" "gagarin@soviet.org") - :where [= [emplid] 1]) - (values - (usql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 1]) - (progn - (usql:update-records [employee] - :av-pairs'((first_name "Vladamir") - (last_name "Lenin") - (email "lenin@soviet.org")) - :where [= [emplid] 1]) - (usql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 1])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) - (("Vladamir" "Lenin" "lenin@soviet.org"))) - -;; updates a record using av-pairs and then deletes it -(deftest :fdml/update/2 - (progn - (usql:update-records [employee] - :av-pairs'((first_name "Yuri") - (last_name "Gagarin") - (email "gagarin@soviet.org")) - :where [= [emplid] 1]) - (values - (usql:select [first-name] [last-name] [email] :from [employee] - :where [= [emplid] 1]) - (progn - (usql:update-records [employee] - :av-pairs'((first_name "Vladamir") - (last_name "Lenin") - (email "lenin@soviet.org")) - :where [= [emplid] 1]) - (usql:select [first-name] [last-name] [email] - :from [employee] :where [= [emplid] 1])))) - (("Yuri" "Gagarin" "gagarin@soviet.org")) - (("Vladamir" "Lenin" "lenin@soviet.org"))) - - -(deftest :fdml/query/1 - (usql:query "SELECT COUNT(*) FROM EMPLOYEE WHERE (EMAIL LIKE '%org')") - (("10"))) - -(deftest :fdml/query/2 - (usql:query - "SELECT FIRST_NAME,LAST_NAME FROM EMPLOYEE WHERE (EMPLID <= 5) ORDER BY LAST_NAME") - (("Leonid" "Brezhnev") ("Nikita" "Kruschev") ("Vladamir" "Lenin") - ("Josef" "Stalin") ("Leon" "Trotsky"))) - - -(deftest :fdml/execute-command/1 - (values - (usql:table-exists-p [foo] :owner *test-database-user*) - (progn - (usql:execute-command "create table foo (bar integer)") - (usql:table-exists-p [foo] :owner *test-database-user*)) - (progn - (usql:execute-command "drop table foo") - (usql:table-exists-p [foo] :owner *test-database-user*))) - nil t nil) - - -;; compare min, max and average hieghts in inches (they're quite short -;; these guys!) -- only works with pgsql -(deftest :fdml/select/1 - (if (member *test-database-type* '(:postgresql-socket :postgresql)) - (let ((max (usql:select [function "floor" - [/ [* [max [height]] 100] 2.54]] - :from [employee] - :flatp t)) - (min (usql:select [function "floor" - [/ [* [min [height]] 100] 2.54]] - :from [employee] - :flatp t)) - (avg (usql:select [function "floor" - [avg [/ [* [height] 100] 2.54]]] - :from [employee] - :flatp t))) - (apply #'< (mapcar #'parse-integer (append min avg max)))) - t) - t) - -(deftest :fdml/select/2 - (usql:select [first-name] :from [employee] :flatp t :distinct t - :order-by [first-name]) - ("Boris" "Josef" "Konstantin" "Leon" "Leonid" "Mikhail" "Nikita" "Vladamir" - "Yuri")) - -(deftest :fdml/select/3 - (usql:select [first-name] [count [*]] :from [employee] - :group-by [first-name] - :order-by [first-name]) - (("Boris" "1") ("Josef" "1") ("Konstantin" "1") ("Leon" "1") ("Leonid" "1") - ("Mikhail" "1") ("Nikita" "1") ("Vladamir" "2") ("Yuri" "1"))) - -(deftest :fdml/select/4 - (usql:select [last-name] :from [employee] :where [like [email] "%org"] - :order-by [last-name] - :flatp t) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) - -(deftest :fdml/select/5 - (usql:select [email] :from [employee] :flatp t - :where [in [employee emplid] - [select [managerid] :from [employee]]]) - ("lenin@soviet.org")) - -(deftest :fdml/select/6 - (if (member *test-database-type* '(:postgresql-socket :postgresql)) - (mapcar #'parse-integer - (usql:select [function "trunc" [height]] :from [employee] - :flatp t)) - (mapcar #'(lambda (s) (truncate (parse-integer s :junk-allowed t))) - (usql:select [height] :from [employee] :flatp t))) - (1 1 1 1 1 1 1 1 1 1)) - -(deftest :fdml/select/7 - (sql:select [max [emplid]] :from [employee] :flatp t) - ("10")) - -(deftest :fdml/select/8 - (sql:select [min [emplid]] :from [employee] :flatp t) - ("1")) - -(deftest :fdml/select/9 - (subseq (car (sql:select [avg [emplid]] :from [employee] :flatp t)) 0 3) - "5.5") - -(deftest :fdml/select/10 - (sql:select [last-name] :from [employee] - :where [not [in [emplid] - [select [managerid] :from [company]]]] - :flatp t - :order-by [last-name]) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Putin" "Stalin" - "Trotsky" "Yeltsin")) - -(deftest :fdml/select/11 - (usql:select [last-name] :from [employee] :where [married] :flatp t - :order-by [emplid]) - ("Lenin" "Stalin" "Trotsky")) - -(deftest :fdml/select/12 - (let ((v 1)) - (usql:select [last-name] :from [employee] :where [= [emplid] v])) - (("Lenin"))) - -;(deftest :fdml/select/11 -; (sql:select [emplid] :from [employee] -; :where [= [emplid] [any [select [companyid] :from [company]]]] -; :flatp t) -; ("1")) - -(deftest :fdml/do-query/1 - (let ((result '())) - (usql:do-query ((name) [select [last-name] :from [employee] - :order-by [last-name]]) - (push name result)) - result) - ("Yeltsin" "Trotsky" "Stalin" "Putin" "Lenin" "Kruschev" "Gorbachev" - "Chernenko" "Brezhnev" "Andropov")) - -(deftest :fdml/map-query/1 - (usql:map-query 'list #'identity - [select [last-name] :from [employee] :flatp t - :order-by [last-name]]) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) - -(deftest :fdml/map-query/2 - (usql:map-query 'vector #'identity - [select [last-name] :from [employee] :flatp t - :order-by [last-name]]) - #("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) - -(deftest :fdml/loop/1 - (loop for (forename surname) - being each tuple in - [select [first-name] [last-name] :from [employee] :order-by [last-name]] - collect (concatenate 'string forename " " surname)) - ("Yuri Andropov" "Leonid Brezhnev" "Konstantin Chernenko" "Mikhail Gorbachev" - "Nikita Kruschev" "Vladamir Lenin" "Vladamir Putin" - "Josef Stalin" "Leon Trotsky" "Boris Yeltsin")) - -;; starts a transaction deletes a record and then rolls back the deletion -(deftest :fdml/transaction/1 - (let ((results '())) - ;; test if we are in a transaction - (push (usql:in-transaction-p) results) - ;;start a transaction - (usql:start-transaction) - ;; test if we are in a transaction - (push (usql:in-transaction-p) results) - ;;Putin has got to go - (unless (eql *test-database-type* :mysql) - (usql:delete-records :from [employee] :where [= [last-name] "Putin"])) - ;;Should be nil - (push - (usql:select [*] :from [employee] :where [= [last-name] "Putin"]) - results) - ;;Oh no, he's still there - (usql:rollback) - ;; test that we are out of the transaction - (push (usql:in-transaction-p) results) - ;; Check that we got him back alright - (push (usql:select [email] :from [employee] :where [= [last-name] "Putin"] - :flatp t) - results) - (apply #'values (nreverse results))) - nil t nil nil ("putin@soviet.org")) - -;; starts a transaction, updates a record and then rolls back the update -(deftest :fdml/transaction/2 - (let ((results '())) - ;; test if we are in a transaction - (push (usql:in-transaction-p) results) - ;;start a transaction - (usql:start-transaction) - ;; test if we are in a transaction - (push (usql:in-transaction-p) results) - ;;Putin has got to go - (unless (eql *test-database-type* :mysql) - (usql:update-records [employee] - :av-pairs '((email "putin-nospam@soviet.org")) - :where [= [last-name] "Putin"])) - ;;Should be new value - (push (usql:select [email] :from [employee] - :where [= [last-name] "Putin"] - :flatp t) - results) - ;;Oh no, he's still there - (usql:rollback) - ;; test that we are out of the transaction - (push (usql:in-transaction-p) results) - ;; Check that we got him back alright - (push (usql:select [email] :from [employee] :where [= [last-name] "Putin"] - :flatp t) - results) - (apply #'values (nreverse results))) - nil t ("putin-nospam@soviet.org") nil ("putin@soviet.org")) - -;; runs an update within a transaction and checks it is committed -(deftest :fdml/transaction/3 - (let ((results '())) - ;; check status - (push (usql:in-transaction-p) results) - ;; update records - (push - (usql:with-transaction () - (usql:update-records [employee] - :av-pairs '((email "lenin-nospam@soviet.org")) - :where [= [emplid] 1])) - results) - ;; check status - (push (usql:in-transaction-p) results) - ;; check that was committed - (push (usql:select [email] :from [employee] :where [= [emplid] 1] - :flatp t) - results) - ;; undo the changes - (push - (usql:with-transaction () - (usql:update-records [employee] - :av-pairs '((email "lenin@soviet.org")) - :where [= [emplid] 1])) - results) - ;; and check status - (push (usql:in-transaction-p) results) - ;; check that was committed - (push (usql:select [email] :from [employee] :where [= [emplid] 1] - :flatp t) - results) - (apply #'values (nreverse results))) - nil :COMMITTED nil ("lenin-nospam@soviet.org") :COMMITTED - nil ("lenin@soviet.org")) - -;; runs a valid update and an invalid one within a transaction and checks -;; that the valid update is rolled back when the invalid one fails. -(deftest :fdml/transaction/4 - (let ((results '())) - ;; check status - (push (usql:in-transaction-p) results) - (unless (eql *test-database-type* :mysql) - (handler-case - (usql:with-transaction () - ;; valid update - (usql:update-records [employee] - :av-pairs '((email "lenin-nospam@soviet.org")) - :where [= [emplid] 1]) - ;; invalid update which generates an error - (usql:update-records [employee] - :av-pairs - '((emale "lenin-nospam@soviet.org")) - :where [= [emplid] 1])) - (usql:clsql-sql-error () - (progn - ;; check status - (push (usql:in-transaction-p) results) - ;; and check nothing done - (push (usql:select [email] :from [employee] :where [= [emplid] 1] - :flatp t) - results) - (apply #'values (nreverse results))))))) - nil nil ("lenin@soviet.org")) - -#.(usql:restore-sql-reader-syntax-state) diff --git a/usql-tests/test-init.lisp b/usql-tests/test-init.lisp deleted file mode 100644 index 3334908..0000000 --- a/usql-tests/test-init.lisp +++ /dev/null @@ -1,316 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: test-init.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 12:14:38 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Initialisation utilities for running regression tests on CLSQL-USQL. -;;;; -;;;; ====================================================================== - -(in-package #:clsql-usql-tests) - -(defvar *test-database-type* nil) -(defvar *test-database-server* "") -(defvar *test-database-name* "") -(defvar *test-database-user* "") -(defvar *test-database-password* "") - -(defclass thing () - ((extraterrestrial :initform nil :initarg :extraterrestrial))) - -(def-view-class person (thing) - ((height :db-kind :base :accessor height :type float :nulls-ok t - :initarg :height) - (married :db-kind :base :accessor married :type boolean :nulls-ok t - :initarg :married) - (birthday :nulls-ok t :type clsql-base:wall-time :initarg :birthday) - (hobby :db-kind :virtual :initarg :hobby :initform nil))) - -(def-view-class employee (person) - ((emplid - :db-kind :key - :db-constraints :not-null - :nulls-ok nil - :type integer - :initarg :emplid) - (groupid - :db-kind :key - :db-constraints :not-null - :nulls-ok nil - :type integer - :initarg :groupid) - (first-name - :accessor first-name - :type (string 30) - :initarg :first-name) - (last-name - :accessor last-name - :type (string 30) - :initarg :last-name) - (email - :accessor employee-email - :type (string 100) - :nulls-ok t - :initarg :email) - (companyid - :type integer) - (company - :accessor employee-company - :db-kind :join - :db-info (:join-class company - :home-key companyid - :foreign-key companyid - :set nil)) - (managerid - :type integer - :nulls-ok t) - (manager - :accessor employee-manager - :db-kind :join - :db-info (:join-class employee - :home-key managerid - :foreign-key emplid - :set nil))) - (:base-table employee)) - -(def-view-class company () - ((companyid - :db-type :key - :db-constraints :not-null - :type integer - :initarg :companyid) - (groupid - :db-type :key - :db-constraints :not-null - :type integer - :initarg :groupid) - (name - :type (string 100) - :initarg :name) - (presidentid - :type integer) - (president - :reader president - :db-kind :join - :db-info (:join-class employee - :home-key presidentid - :foreign-key emplid - :set nil)) - (employees - :reader company-employees - :db-kind :join - :db-info (:join-class employee - :home-key (companyid groupid) - :foreign-key (companyid groupid) - :set t))) - (:base-table company)) - -(defparameter company1 (make-instance 'company - :companyid 1 - :groupid 1 - :name "Widgets Inc.")) - -(defparameter employee1 (make-instance 'employee - :emplid 1 - :groupid 1 - :married t - :height (1+ (random 1.00)) - :birthday (clsql-base:get-time) - :first-name "Vladamir" - :last-name "Lenin" - :email "lenin@soviet.org")) - -(defparameter employee2 (make-instance 'employee - :emplid 2 - :groupid 1 - :height (1+ (random 1.00)) - :married t - :birthday (clsql-base:get-time) - :first-name "Josef" - :last-name "Stalin" - :email "stalin@soviet.org")) - -(defparameter employee3 (make-instance 'employee - :emplid 3 - :groupid 1 - :height (1+ (random 1.00)) - :married t - :birthday (clsql-base:get-time) - :first-name "Leon" - :last-name "Trotsky" - :email "trotsky@soviet.org")) - -(defparameter employee4 (make-instance 'employee - :emplid 4 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :birthday (clsql-base:get-time) - :first-name "Nikita" - :last-name "Kruschev" - :email "kruschev@soviet.org")) - -(defparameter employee5 (make-instance 'employee - :emplid 5 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :birthday (clsql-base:get-time) - :first-name "Leonid" - :last-name "Brezhnev" - :email "brezhnev@soviet.org")) - -(defparameter employee6 (make-instance 'employee - :emplid 6 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :birthday (clsql-base:get-time) - :first-name "Yuri" - :last-name "Andropov" - :email "andropov@soviet.org")) - -(defparameter employee7 (make-instance 'employee - :emplid 7 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :birthday (clsql-base:get-time) - :first-name "Konstantin" - :last-name "Chernenko" - :email "chernenko@soviet.org")) - -(defparameter employee8 (make-instance 'employee - :emplid 8 - :groupid 1 - :height (1+ (random 1.00)) - :married nil - :birthday (clsql-base:get-time) - :first-name "Mikhail" - :last-name "Gorbachev" - :email "gorbachev@soviet.org")) - -(defparameter employee9 (make-instance 'employee - :emplid 9 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :birthday (clsql-base:get-time) - :first-name "Boris" - :last-name "Yeltsin" - :email "yeltsin@soviet.org")) - -(defparameter employee10 (make-instance 'employee - :emplid 10 - :groupid 1 - :married nil - :height (1+ (random 1.00)) - :birthday (clsql-base:get-time) - :first-name "Vladamir" - :last-name "Putin" - :email "putin@soviet.org")) - -(defun test-database-connection-spec () - (let ((dbserver *test-database-server*) - (dbname *test-database-name*) - (dbpassword *test-database-password*) - (dbtype *test-database-type*) - (username *test-database-user*)) - (case dbtype - (:postgresql - `("" ,dbname ,username ,dbpassword)) - (:postgresql-socket - `(,dbserver ,dbname ,username ,dbpassword)) - (:mysql - `("" ,dbname ,username ,dbpassword)) - (:sqlite - `(,dbname)) - (:oracle - `(,username ,dbpassword ,dbname)) - (t - (error "Unrecognized database type: ~A" dbtype))))) - -(defun test-connect-to-database (database-type) - (setf *test-database-type* database-type) - ;; Connect to the database - (usql:connect (test-database-connection-spec) - :database-type database-type - :make-default t - :if-exists :old)) - -(defmacro with-ignore-errors (&rest forms) - `(progn - ,@(mapcar - (lambda (x) (list 'ignore-errors x)) - forms))) - -(defun test-initialise-database () - ;; Delete the instance records - (with-ignore-errors - (usql:delete-instance-records company1) - (usql:delete-instance-records employee1) - (usql:delete-instance-records employee2) - (usql:delete-instance-records employee3) - (usql:delete-instance-records employee4) - (usql:delete-instance-records employee5) - (usql:delete-instance-records employee6) - (usql:delete-instance-records employee7) - (usql:delete-instance-records employee8) - (usql:delete-instance-records employee9) - (usql:delete-instance-records employee10) - ;; Drop the required tables if they exist - (usql:drop-view-from-class 'employee) - (usql:drop-view-from-class 'company)) - ;; Create the tables for our view classes - (usql:create-view-from-class 'employee) - (usql:create-view-from-class 'company) - ;; Lenin manages everyone - (usql:add-to-relation employee2 'manager employee1) - (usql:add-to-relation employee3 'manager employee1) - (usql:add-to-relation employee4 'manager employee1) - (usql:add-to-relation employee5 'manager employee1) - (usql:add-to-relation employee6 'manager employee1) - (usql:add-to-relation employee7 'manager employee1) - (usql:add-to-relation employee8 'manager employee1) - (usql:add-to-relation employee9 'manager employee1) - (usql:add-to-relation employee10 'manager employee1) - ;; Everyone works for Widgets Inc. - (usql:add-to-relation company1 'employees employee1) - (usql:add-to-relation company1 'employees employee2) - (usql:add-to-relation company1 'employees employee3) - (usql:add-to-relation company1 'employees employee4) - (usql:add-to-relation company1 'employees employee5) - (usql:add-to-relation company1 'employees employee6) - (usql:add-to-relation company1 'employees employee7) - (usql:add-to-relation company1 'employees employee8) - (usql:add-to-relation company1 'employees employee9) - (usql:add-to-relation company1 'employees employee10) - ;; Lenin is president of Widgets Inc. - (usql:add-to-relation company1 'president employee1) - ;; store these instances - (usql:update-records-from-instance employee1) - (usql:update-records-from-instance employee2) - (usql:update-records-from-instance employee3) - (usql:update-records-from-instance employee4) - (usql:update-records-from-instance employee5) - (usql:update-records-from-instance employee6) - (usql:update-records-from-instance employee7) - (usql:update-records-from-instance employee8) - (usql:update-records-from-instance employee9) - (usql:update-records-from-instance employee10) - (usql:update-records-from-instance company1)) - -(defun test-usql (backend) - (format t "~&Running CLSQL-USQL tests with ~A backend.~%" backend) - (test-connect-to-database backend) - (test-initialise-database) - (rtest:do-tests)) - - - diff --git a/usql-tests/test-ooddl.lisp b/usql-tests/test-ooddl.lisp deleted file mode 100644 index aed7700..0000000 --- a/usql-tests/test-ooddl.lisp +++ /dev/null @@ -1,87 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: test-ooddl.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 11:52:11 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Tests for the CLSQL-USQL Object Oriented Data Definition Language -;;;; (OODDL). -;;;; -;;;; ====================================================================== - - -(in-package :clsql-usql-tests) - -#.(usql:locally-enable-sql-reader-syntax) - -;; Ensure slots inherited from standard-classes are :virtual -(deftest :ooddl/metaclass/1 - (values - (usql-sys::view-class-slot-db-kind - (usql-sys::slotdef-for-slot-with-class 'extraterrestrial - (find-class 'person))) - (usql-sys::view-class-slot-db-kind - (usql-sys::slotdef-for-slot-with-class 'hobby (find-class 'person)))) - :virtual :virtual) - -;; Ensure all slots in view-class are view-class-effective-slot-definition -(deftest :ooddl/metaclass/2 - (values - (every #'(lambda (slotd) - (typep slotd 'usql-sys::view-class-effective-slot-definition)) - (usql-sys::class-slots (find-class 'person))) - (every #'(lambda (slotd) - (typep slotd 'usql-sys::view-class-effective-slot-definition)) - (usql-sys::class-slots (find-class 'employee))) - (every #'(lambda (slotd) - (typep slotd 'usql-sys::view-class-effective-slot-definition)) - (usql-sys::class-slots (find-class 'company)))) - t t t) - -(deftest :ooddl/join/1 - (mapcar #'(lambda (e) - (slot-value e 'companyid)) - (company-employees company1)) - (1 1 1 1 1 1 1 1 1 1)) - -(deftest :ooddl/join/2 - (slot-value (president company1) 'last-name) - "Lenin") - -(deftest :ooddl/join/3 - (slot-value (employee-manager employee2) 'last-name) - "Lenin") - -(deftest :ooddl/time/1 - (let* ((now (clsql-base:get-time))) - (when (member *test-database-type* '(:postgresql :postgresql-socket)) - (usql:execute-command "set datestyle to 'iso'")) - (usql:update-records [employee] :av-pairs `((birthday ,now)) - :where [= [emplid] 1]) - (let ((dbobj (car (usql:select 'employee :where [= [birthday] now])))) - (values - (slot-value dbobj 'last-name) - (clsql-base:time= (slot-value dbobj 'birthday) now)))) - "Lenin" t) - -(deftest :ooddl/time/2 - (let* ((now (clsql-base:get-time)) - (fail-index -1)) - (when (member *test-database-type* '(:postgresql :postgresql-socket)) - (usql:execute-command "set datestyle to 'iso'")) - (dotimes (x 40) - (usql:update-records [employee] :av-pairs `((birthday ,now)) - :where [= [emplid] 1]) - (let ((dbobj (car (usql:select 'employee :where [= [birthday] now])))) - (unless (clsql-base:time= (slot-value dbobj 'birthday) now) - (setf fail-index x)) - (setf now (clsql-base:roll now :day (* 10 x))))) - fail-index) - -1) - -#.(usql:restore-sql-reader-syntax-state) diff --git a/usql-tests/test-oodml.lisp b/usql-tests/test-oodml.lisp deleted file mode 100644 index f0cd3b0..0000000 --- a/usql-tests/test-oodml.lisp +++ /dev/null @@ -1,241 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: test-oodml.lisp -;;;; Author: Marcus Pearce -;;;; Created: 01/04/2004 -;;;; Updated: <04/04/2004 11:51:23 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Tests for the CLSQL-USQL Object Oriented Data Definition Language -;;;; (OODML). -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-tests) - -#.(usql:locally-enable-sql-reader-syntax) - -(deftest :oodml/select/1 - (mapcar #'(lambda (e) (slot-value e 'last-name)) - (usql:select 'employee :order-by [last-name])) - ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" - "Stalin" "Trotsky" "Yeltsin")) - -(deftest :oodml/select/2 - (mapcar #'(lambda (e) (slot-value e 'name)) - (usql:select 'company)) - ("Widgets Inc.")) - -(deftest :oodml/select/3 - (mapcar #'(lambda (e) (slot-value e 'companyid)) - (usql:select 'employee - :where [and [= [slot-value 'employee 'companyid] - [slot-value 'company 'companyid]] - [= [slot-value 'company 'name] - "Widgets Inc."]])) - (1 1 1 1 1 1 1 1 1 1)) - -(deftest :oodml/select/4 - (mapcar #'(lambda (e) - (concatenate 'string (slot-value e 'first-name) - " " - (slot-value e 'last-name))) - (usql:select 'employee :where [= [slot-value 'employee 'first-name] - "Vladamir"] - :order-by [last-name])) - ("Vladamir Lenin" "Vladamir Putin")) - -;; sqlite fails this because it is typeless -(deftest :oodml/select/5 - (length (sql:select 'employee :where [married])) - 3) - -;; tests update-records-from-instance -(deftest :oodml/update-records/1 - (values - (progn - (let ((lenin (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1])))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Dimitriy" - (slot-value employee1 'last-name) "Ivanovich" - (slot-value employee1 'email) "ivanovich@soviet.org") - (usql:update-records-from-instance employee1) - (let ((lenin (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1])))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Vladamir" - (slot-value employee1 'last-name) "Lenin" - (slot-value employee1 'email) "lenin@soviet.org") - (usql:update-records-from-instance employee1) - (let ((lenin (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1])))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))))) - "Vladamir Lenin: lenin@soviet.org" - "Dimitriy Ivanovich: ivanovich@soviet.org" - "Vladamir Lenin: lenin@soviet.org") - -;; tests update-record-from-slot -(deftest :oodml/update-records/2 - (values - (employee-email - (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] 1]))) - (progn - (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") - (usql:update-record-from-slot employee1 'email) - (employee-email - (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] 1])))) - (progn - (setf (slot-value employee1 'email) "lenin@soviet.org") - (usql:update-record-from-slot employee1 'email) - (employee-email - (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] 1]))))) - "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") - -;; tests update-record-from-slots -(deftest :oodml/update-records/3 - (values - (let ((lenin (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1])))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))) - (progn - (setf (slot-value employee1 'first-name) "Dimitriy" - (slot-value employee1 'last-name) "Ivanovich" - (slot-value employee1 'email) "ivanovich@soviet.org") - (usql:update-record-from-slots employee1 '(first-name last-name email)) - (let ((lenin (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1])))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin)))) - (progn - (setf (slot-value employee1 'first-name) "Vladamir" - (slot-value employee1 'last-name) "Lenin" - (slot-value employee1 'email) "lenin@soviet.org") - (usql:update-record-from-slots employee1 '(first-name last-name email)) - (let ((lenin (car (usql:select 'employee - :where [= [slot-value 'employee 'emplid] - 1])))) - (concatenate 'string - (first-name lenin) - " " - (last-name lenin) - ": " - (employee-email lenin))))) - "Vladamir Lenin: lenin@soviet.org" - "Dimitriy Ivanovich: ivanovich@soviet.org" - "Vladamir Lenin: lenin@soviet.org") - -;; tests update-instance-from-records -(deftest :oodml/update-instance/1 - (values - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email)) - (progn - (usql:update-records [employee] - :av-pairs '(([first-name] "Ivan") - ([last-name] "Petrov") - ([email] "petrov@soviet.org")) - :where [= [emplid] 1]) - (usql:update-instance-from-records employee1) - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email))) - (progn - (usql:update-records [employee] - :av-pairs '(([first-name] "Vladamir") - ([last-name] "Lenin") - ([email] "lenin@soviet.org")) - :where [= [emplid] 1]) - (usql:update-instance-from-records employee1) - (concatenate 'string - (slot-value employee1 'first-name) - " " - (slot-value employee1 'last-name) - ": " - (slot-value employee1 'email)))) - "Vladamir Lenin: lenin@soviet.org" - "Ivan Petrov: petrov@soviet.org" - "Vladamir Lenin: lenin@soviet.org") - -;; tests update-slot-from-record -(deftest :oodml/update-instance/2 - (values - (slot-value employee1 'email) - (progn - (usql:update-records [employee] - :av-pairs '(([email] "lenin-nospam@soviet.org")) - :where [= [emplid] 1]) - (usql:update-slot-from-record employee1 'email) - (slot-value employee1 'email)) - (progn - (usql:update-records [employee] - :av-pairs '(([email] "lenin@soviet.org")) - :where [= [emplid] 1]) - (usql:update-slot-from-record employee1 'email) - (slot-value employee1 'email))) - "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") - - -;(deftest :oodml/iteration/1 -; (usql:do-query ((e) [select 'usql-tests::employee :where [married] -; :order-by [emplid]]) -; (slot-value e last-name)) -; ("Lenin" "Stalin" "Trotsky")) - -;(deftest :oodml/iteration/2 -; (usql:map-query 'list #'last-name [select 'employee :where [married] -; :order-by [emplid]]) -; ("Lenin" "Stalin" "Trotsky")) - -;(deftest :oodml/iteration/3 -; (loop for (e) being the tuples in -; [select 'employee :where [married] :order-by [emplid]] -; collect (slot-value e 'last-name)) -; ("Lenin" "Stalin" "Trotsky")) - - -#.(usql:restore-sql-reader-syntax-state) diff --git a/usql-tests/test-syntax.lisp b/usql-tests/test-syntax.lisp deleted file mode 100644 index e71d863..0000000 --- a/usql-tests/test-syntax.lisp +++ /dev/null @@ -1,162 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: test-syntax.lisp -;;;; Author: Marcus Pearce -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 11:51:40 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Tests for the CLSQL-USQL Symbolic SQL syntax. -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-tests) - -#.(usql:locally-enable-sql-reader-syntax) - - -(deftest :syntax/generic/1 - (usql:sql "foo") - "'foo'") - -(deftest :syntax/generic/2 - (usql:sql 23) - "23") - -(deftest :syntax/generic/3 - (usql:sql 'bar) - "BAR") - -(deftest :syntax/generic/4 - (usql:sql '("ten" 10 ten)) - "('ten',10,TEN)") - -(deftest :syntax/generic/5 - (usql:sql ["SELECT FOO,BAR FROM BAZ"]) - "SELECT FOO,BAR FROM BAZ") - - -(deftest :syntax/ident/1 - (usql:sql [foo]) - "FOO") - -(deftest :syntax/ident/2 - (usql:sql [foo bar]) - "FOO.BAR") - -;; not sure about this one -(deftest :syntax/ident/3 - (usql:sql ["foo" bar]) - "foo.BAR") - -;(deftest :syntax/ident/4 -; (usql:sql [foo "bar"]) -; "FOO \"bar\"") - -(deftest :syntax/ident/5 - (usql:sql [foo :integer]) - "FOO INTEGER") - -(deftest :syntax/ident/6 - (usql:sql [foo bar :integer]) - "FOO.BAR INTEGER") - -;; not sure about this one -(deftest :syntax/ident/7 - (usql:sql ["foo" bar :integer]) - "foo.BAR INTEGER") - - -(deftest :syntax/value/1 - (usql:sql [any '(3 4)]) - "(ANY ((3,4)))") - -(deftest :syntax/value/2 - (usql:sql [* 2 3]) - "(2 * 3)") - - -(deftest :syntax/relational/1 - (usql:sql [> [baz] [beep]]) - "(BAZ > BEEP)") - -(deftest :syntax/relational/2 - (let ((x 10)) - (usql:sql [> [foo] x])) - "(FOO > 10)") - - -(deftest :syntax/function/1 - (usql:sql [function "COS" [age]]) - "COS(AGE)") - -(deftest :syntax/function/2 - (usql:sql [function "TO_DATE" "02/06/99" "mm/DD/RR"]) - "TO_DATE('02/06/99','mm/DD/RR')") - -(deftest :syntax/query/1 - (usql:sql [select [person_id] [surname] :from [person]]) - "SELECT PERSON_ID,SURNAME FROM PERSON") - -(deftest :syntax/query/2 - (usql:sql [select [foo] [bar *] - :from '([baz] [bar]) - :where [or [= [foo] 3] - [> [baz.quux] 10]]]) - "SELECT FOO,BAR.* FROM BAZ,BAR WHERE ((FOO = 3) OR (BAZ.QUUX > 10))") - -(deftest :syntax/query/3 - (usql:sql [select [foo bar] [baz] - :from '([foo] [quux]) - :where [or [> [baz] 3] - [like [foo bar] "SU%"]]]) - "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))") - -(deftest :syntax/query/4 - (usql:sql [select [count [*]] :from [emp]]) - "SELECT COUNT(*) FROM EMP") - - -(deftest :syntax/expression1 - (usql:sql - (usql:sql-operation - 'select - (usql:sql-expression :table 'foo :attribute 'bar) - (usql:sql-expression :attribute 'baz) - :from (list - (usql:sql-expression :table 'foo) - (usql:sql-expression :table 'quux)) - :where - (usql:sql-operation 'or - (usql:sql-operation - '> - (usql:sql-expression :attribute 'baz) - 3) - (usql:sql-operation - 'like - (usql:sql-expression :table 'foo - :attribute 'bar) - "SU%")))) - "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))") - -(deftest :syntax/expression/2 - (usql:sql - (apply (usql:sql-operator 'and) - (loop for table in '(thistime nexttime sometime never) - for count from 42 - collect - [function "BETWEEN" - (usql:sql-expression :table table - :attribute 'bar) - (usql:sql-operation '* [hip] [hop]) - count] - collect - [like (usql:sql-expression :table table - :attribute 'baz) - (usql:sql table)]))) - "(BETWEEN(THISTIME.BAR,(HIP * HOP),42) AND (THISTIME.BAZ LIKE 'THISTIME') AND BETWEEN(NEXTTIME.BAR,(HIP * HOP),43) AND (NEXTTIME.BAZ LIKE 'NEXTTIME') AND BETWEEN(SOMETIME.BAR,(HIP * HOP),44) AND (SOMETIME.BAZ LIKE 'SOMETIME') AND BETWEEN(NEVER.BAR,(HIP * HOP),45) AND (NEVER.BAZ LIKE 'NEVER'))") - -#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file diff --git a/usql/README b/usql/README deleted file mode 100644 index c0ea747..0000000 --- a/usql/README +++ /dev/null @@ -1,64 +0,0 @@ -INTRODUCTIION - -CLSQL-USQL is a high level SQL interface for Common Lisp which is -based on the CommonSQL package from Xanalys. It was originally -developed at Onshore Development, Inc. based on Pierre Mai's MaiSQL -package. It now incorporates some of the code developed for CLSQL. See -the files CONTRIBUTORS and COPYING for more details. - -CLSQL-USQL depends on the low-level database interfaces provided by -CLSQL and includes both a functional and an object oriented -interface to SQL RDBMS. - -DOCUMENTATION - -A CLSQL-USQL tutorial can be found in the directory doc/ - -Also see the CommonSQL documentation avaialble on the Lispworks website: - -Xanalys LispWorks User Guide - The CommonSQL Package -http://www.lispworks.com/reference/lw43/LWUG/html/lwuser-167.htm - -Xanalys LispWorks Reference Manual -- The SQL Package -http://www.lispworks.com/reference/lw43/LWRM/html/lwref-383.htm - -CommonSQL Tutorial by Nick Levine -http://www.ravenbrook.com/doc/2002/09/13/common-sql/ - - -PREREQUISITES - - o COMMON LISP: currently CMUCL, SBCL, Lispworks - o RDBMS: currently Postgresql, Mysql, Sqlite - o ASDF (from http://cvs.sourceforge.net/viewcvs.py/cclan/asdf/) - o CLSQL-2.0.0 or later (from http://clsql.b9.com) - o RT for running the test suite (from http://files.b9.com/rt/rt.tar.gz) - - -INSTALLATION - -Just load clsql-usql.asd or put it somewhere where ASDF can find it -and call: - -(asdf:oos 'asdf:load-op :clsql-usql) - -You'll then need to load a CLSQL backend before you can do anything. - -To run the regression tests load clsql-usql-tests.asd or put it -somewhere where ASDF can find it, edit the file tests/test-init.lisp -and set the following variables to appropriate values: - - *test-database-server* - *test-database-name* - *test-database-user* - *test-database-password* - -And then call: - -(asdf:oos 'asdf:load-op :clsql-usql-tests) -(usql-tests:test-usql BACKEND) - -where BACKEND is the CLSQL database interface to use (currently one of -:postgresql, :postgresql-socket, :sqlite or :mysql). - - diff --git a/usql/classes.lisp b/usql/classes.lisp deleted file mode 100644 index c390c5f..0000000 --- a/usql/classes.lisp +++ /dev/null @@ -1,737 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: classes.lisp -;;;; Updated: <04/04/2004 12:08:49 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Classes defining SQL expressions and methods for formatting the -;;;; appropriate SQL commands. -;;;; -;;;; ====================================================================== - -(in-package #:clsql-usql-sys) - - -(defvar +empty-string+ "''") - -(defvar +null-string+ "NULL") - -(defvar *sql-stream* nil - "stream which accumulates SQL output") - -(defvar *default-schema* "UNCOMMONSQL") - -(defvar *object-schemas* (make-hash-table :test #'equal) - "Hash of schema name to class constituent lists.") - -(defun in-schema (schemaname) - (setf *default-schema* schemaname)) - -(defun sql-output (sql-expr &optional database) - (progv '(*sql-stream*) - `(,(make-string-output-stream)) - (output-sql sql-expr database) - (get-output-stream-string *sql-stream*))) - - -(defclass %sql-expression () - ()) - -(defmethod output-sql ((expr %sql-expression) &optional - (database *default-database*)) - (declare (ignore database)) - (write-string +null-string+ *sql-stream*)) - -(defmethod print-object ((self %sql-expression) stream) - (print-unreadable-object - (self stream :type t) - (write-string (sql-output self) stream))) - -;; For straight up strings - -(defclass sql (%sql-expression) - ((text - :initarg :string - :initform "")) - (:documentation "A literal SQL expression.")) - -(defmethod make-load-form ((sql sql) &optional environment) - (declare (ignore environment)) - (with-slots (text) - sql - `(make-instance 'sql :string ',text))) - -(defmethod output-sql ((expr sql) &optional (database *default-database*)) - (declare (ignore database)) - (write-string (slot-value expr 'text) *sql-stream*) - t) - -(defmethod print-object ((ident sql) stream) - (format stream "#<~S \"~A\">" - (type-of ident) - (sql-output ident))) - -;; For SQL Identifiers of generic type -(defclass sql-ident (%sql-expression) - ((name - :initarg :name - :initform "NULL")) - (:documentation "An SQL identifer.")) - -(defmethod make-load-form ((sql sql-ident) &optional environment) - (declare (ignore environment)) - (with-slots (name) - sql - `(make-instance 'sql-ident :name ',name))) - -(defvar *output-hash* (make-hash-table :test #'equal)) - -(defmethod output-sql-hash-key (expr &optional (database *default-database*)) - (declare (ignore expr database)) - nil) - -(defmethod output-sql :around ((sql t) &optional (database *default-database*)) - (declare (ignore database)) - (let* ((hash-key (output-sql-hash-key sql)) - (hash-value (when hash-key (gethash hash-key *output-hash*)))) - (cond ((and hash-key hash-value) - (write-string hash-value *sql-stream*)) - (hash-key - (let ((*sql-stream* (make-string-output-stream))) - (call-next-method) - (setf hash-value (get-output-stream-string *sql-stream*)) - (setf (gethash hash-key *output-hash*) hash-value)) - (write-string hash-value *sql-stream*)) - (t - (call-next-method))))) - -(defmethod output-sql ((expr sql-ident) &optional - (database *default-database*)) - (declare (ignore database)) - (with-slots (name) - expr - (etypecase name - (string - (write-string name *sql-stream*)) - (symbol - (write-string (symbol-name name) *sql-stream*))) - t)) - -;; For SQL Identifiers for attributes - -(defclass sql-ident-attribute (sql-ident) - ((qualifier - :initarg :qualifier - :initform "NULL") - (type - :initarg :type - :initform "NULL") - (params - :initarg :params - :initform nil)) - (:documentation "An SQL Attribute identifier.")) - -(defmethod collect-table-refs (sql) - (declare (ignore sql)) - nil) - -(defmethod collect-table-refs ((sql sql-ident-attribute)) - (let ((qual (slot-value sql 'qualifier))) - (if (and qual (symbolp (slot-value sql 'qualifier))) - (list (make-instance 'sql-ident-table :name - (slot-value sql 'qualifier)))))) - -(defmethod make-load-form ((sql sql-ident-attribute) &optional environment) - (declare (ignore environment)) - (with-slots (qualifier type name) - sql - `(make-instance 'sql-ident-attribute :name ',name - :qualifier ',qualifier - :type ',type))) - -(defmethod output-sql ((expr sql-ident-attribute) &optional - (database *default-database*)) - (declare (ignore database)) - (with-slots (qualifier name type params) - expr - (if (and name (not qualifier) (not type)) - (write-string (sql-escape (symbol-name name)) *sql-stream*) - (format *sql-stream* "~@[~A.~]~A~@[ ~A~]" - (if qualifier (sql-escape qualifier) qualifier) - (sql-escape name) - type)) - t)) - -(defmethod output-sql-hash-key ((expr sql-ident-attribute) &optional - (database *default-database*)) - (declare (ignore database)) - (with-slots (qualifier name type params) - expr - (list 'sql-ident-attribute qualifier name type params))) - -;; For SQL Identifiers for tables -(defclass sql-ident-table (sql-ident) - ((alias - :initarg :table-alias :initform nil)) - (:documentation "An SQL table identifier.")) - -(defmethod make-load-form ((sql sql-ident-table) &optional environment) - (declare (ignore environment)) - (with-slots (alias name) - sql - `(make-instance 'sql-ident-table :name name :alias ',alias))) - -(defun generate-sql (expr) - (let ((*sql-stream* (make-string-output-stream))) - (output-sql expr) - (get-output-stream-string *sql-stream*))) - -(defmethod output-sql ((expr sql-ident-table) &optional - (database *default-database*)) - (declare (ignore database)) - (with-slots (name alias) - expr - (if (null alias) - (write-string (sql-escape (symbol-name name)) *sql-stream*) - (progn - (write-string (sql-escape (symbol-name name)) *sql-stream*) - (write-char #\Space *sql-stream*) - (format *sql-stream* "~s" alias)))) - t) - -(defmethod output-sql-hash-key ((expr sql-ident-table) &optional - (database *default-database*)) - (declare (ignore database)) - (with-slots (name alias) - expr - (list 'sql-ident-table name alias))) - -(defclass sql-relational-exp (%sql-expression) - ((operator - :initarg :operator - :initform nil) - (sub-expressions - :initarg :sub-expressions - :initform nil)) - (:documentation "An SQL relational expression.")) - -(defmethod collect-table-refs ((sql sql-relational-exp)) - (let ((tabs nil)) - (dolist (exp (slot-value sql 'sub-expressions)) - (let ((refs (collect-table-refs exp))) - (if refs (setf tabs (append refs tabs))))) - (remove-duplicates tabs - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name)))))) - - - - -;; Write SQL for relational operators (like 'AND' and 'OR'). -;; should do arity checking of subexpressions - -(defmethod output-sql ((expr sql-relational-exp) &optional - (database *default-database*)) - (with-slots (operator sub-expressions) - expr - (let ((subs (if (consp (car sub-expressions)) - (car sub-expressions) - sub-expressions))) - (write-char #\( *sql-stream*) - (do ((sub subs (cdr sub))) - ((null (cdr sub)) (output-sql (car sub) database)) - (output-sql (car sub) database) - (write-char #\Space *sql-stream*) - (output-sql operator database) - (write-char #\Space *sql-stream*)) - (write-char #\) *sql-stream*))) - t) - -(defclass sql-upcase-like (sql-relational-exp) - () - (:documentation "An SQL 'like' that upcases its arguments.")) - -;; Write SQL for relational operators (like 'AND' and 'OR'). -;; should do arity checking of subexpressions - -(defmethod output-sql ((expr sql-upcase-like) &optional - (database *default-database*)) - (flet ((write-term (term) - (write-string "upper(" *sql-stream*) - (output-sql term database) - (write-char #\) *sql-stream*))) - (with-slots (sub-expressions) - expr - (let ((subs (if (consp (car sub-expressions)) - (car sub-expressions) - sub-expressions))) - (write-char #\( *sql-stream*) - (do ((sub subs (cdr sub))) - ((null (cdr sub)) (write-term (car sub))) - (write-term (car sub)) - (write-string " LIKE " *sql-stream*)) - (write-char #\) *sql-stream*)))) - t) - -(defclass sql-assignment-exp (sql-relational-exp) - () - (:documentation "An SQL Assignment expression.")) - - -(defmethod output-sql ((expr sql-assignment-exp) &optional - (database *default-database*)) - (with-slots (operator sub-expressions) - expr - (do ((sub sub-expressions (cdr sub))) - ((null (cdr sub)) (output-sql (car sub) database)) - (output-sql (car sub) database) - (write-char #\Space *sql-stream*) - (output-sql operator database) - (write-char #\Space *sql-stream*))) - t) - -(defclass sql-value-exp (%sql-expression) - ((modifier - :initarg :modifier - :initform nil) - (components - :initarg :components - :initform nil)) - (:documentation - "An SQL value expression.") - ) - -(defmethod collect-table-refs ((sql sql-value-exp)) - (let ((tabs nil)) - (if (listp (slot-value sql 'components)) - (progn - (dolist (exp (slot-value sql 'components)) - (let ((refs (collect-table-refs exp))) - (if refs (setf tabs (append refs tabs))))) - (remove-duplicates tabs - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name))))) - nil))) - - - -(defmethod output-sql ((expr sql-value-exp) &optional - (database *default-database*)) - (with-slots (modifier components) - expr - (if modifier - (progn - (write-char #\( *sql-stream*) - (output-sql modifier database) - (write-char #\Space *sql-stream*) - (output-sql components database) - (write-char #\) *sql-stream*)) - (output-sql components database)))) - -(defclass sql-typecast-exp (sql-value-exp) - () - (:documentation "An SQL typecast expression.")) - -(defmethod output-sql ((expr sql-typecast-exp) &optional - (database *default-database*)) - (database-output-sql expr database)) - -(defmethod database-output-sql ((expr sql-typecast-exp) database) - (with-slots (components) - expr - (output-sql components database))) - - -(defmethod collect-table-refs ((sql sql-typecast-exp)) - (when (slot-value sql 'components) - (collect-table-refs (slot-value sql 'components)))) - -(defclass sql-function-exp (%sql-expression) - ((name - :initarg :name - :initform nil) - (args - :initarg :args - :initform nil)) - (:documentation - "An SQL function expression.")) - -(defmethod collect-table-refs ((sql sql-function-exp)) - (let ((tabs nil)) - (dolist (exp (slot-value sql 'components)) - (let ((refs (collect-table-refs exp))) - (if refs (setf tabs (append refs tabs))))) - (remove-duplicates tabs - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name)))))) - -(defmethod output-sql ((expr sql-function-exp) &optional - (database *default-database*)) - (with-slots (name args) - expr - (output-sql name database) - (when args (output-sql args database))) - t) - -(defclass sql-query (%sql-expression) - ((selections - :initarg :selections - :initform nil) - (all - :initarg :all - :initform nil) - (flatp - :initarg :flatp - :initform nil) - (set-operation - :initarg :set-operation - :initform nil) - (distinct - :initarg :distinct - :initform nil) - (from - :initarg :from - :initform nil) - (where - :initarg :where - :initform nil) - (group-by - :initarg :group-by - :initform nil) - (having - :initarg :having - :initform nil) - (limit - :initarg :limit - :initform nil) - (offset - :initarg :offset - :initform nil) - (order-by - :initarg :order-by - :initform nil) - (order-by-descending - :initarg :order-by-descending - :initform nil)) - (:documentation "An SQL SELECT query.")) - -(defmethod collect-table-refs ((sql sql-query)) - (remove-duplicates (collect-table-refs (slot-value sql 'where)) - :test (lambda (tab1 tab2) - (equal (slot-value tab1 'name) - (slot-value tab2 'name))))) - -(defvar *select-arguments* - '(:all :database :distinct :flatp :from :group-by :having :order-by - :order-by-descending :set-operation :where :offset :limit)) - -(defun query-arg-p (sym) - (member sym *select-arguments*)) - -(defun query-get-selections (select-args) - "Return two values: the list of select-args up to the first keyword, -uninclusive, and the args from that keyword to the end." - (let ((first-key-arg (position-if #'query-arg-p select-args))) - (if first-key-arg - (values (subseq select-args 0 first-key-arg) - (subseq select-args first-key-arg)) - select-args))) - -(defmethod make-query (&rest args) - (multiple-value-bind (selections arglist) - (query-get-selections args) - (destructuring-bind (&key all flatp set-operation distinct from where - group-by having order-by order-by-descending - offset limit &allow-other-keys) - arglist - (if (null selections) - (error "No target columns supplied to select statement.")) - (if (null from) - (error "No source tables supplied to select statement.")) - (make-instance 'sql-query :selections selections - :all all :flatp flatp :set-operation set-operation - :distinct distinct :from from :where where - :limit limit :offset offset - :group-by group-by :having having :order-by order-by - :order-by-descending order-by-descending)))) - -(defvar *in-subselect* nil) - -(defmethod output-sql ((query sql-query) &optional - (database *default-database*)) - (with-slots (distinct selections from where group-by having order-by - order-by-descending limit offset) - query - (when *in-subselect* - (write-string "(" *sql-stream*)) - (write-string "SELECT " *sql-stream*) - (when distinct - (write-string "DISTINCT " *sql-stream*) - (unless (eql t distinct) - (write-string "ON " *sql-stream*) - (output-sql distinct database) - (write-char #\Space *sql-stream*))) - (output-sql (apply #'vector selections) database) - (write-string " FROM " *sql-stream*) - (if (listp from) - (output-sql (apply #'vector from) database) - (output-sql from database)) - (when where - (write-string " WHERE " *sql-stream*) - (let ((*in-subselect* t)) - (output-sql where database))) - (when group-by - (write-string " GROUP BY " *sql-stream*) - (output-sql group-by database)) - (when having - (write-string " HAVING " *sql-stream*) - (output-sql having database)) - (when order-by - (write-string " ORDER BY " *sql-stream*) - (if (listp order-by) - (do ((order order-by (cdr order))) - ((null order)) - (output-sql (car order) database) - (when (cdr order) - (write-char #\, *sql-stream*))) - (output-sql order-by database))) - (when order-by-descending - (write-string " ORDER BY " *sql-stream*) - (if (listp order-by-descending) - (do ((order order-by-descending (cdr order))) - ((null order)) - (output-sql (car order) database) - (when (cdr order) - (write-char #\, *sql-stream*))) - (output-sql order-by-descending database)) - (write-string " DESC " *sql-stream*)) - (when limit - (write-string " LIMIT " *sql-stream*) - (output-sql limit database)) - (when offset - (write-string " OFFSET " *sql-stream*) - (output-sql offset database)) - (when *in-subselect* - (write-string ")" *sql-stream*))) - t) - -;; INSERT - -(defclass sql-insert (%sql-expression) - ((into - :initarg :into - :initform nil) - (attributes - :initarg :attributes - :initform nil) - (values - :initarg :values - :initform nil) - (query - :initarg :query - :initform nil)) - (:documentation - "An SQL INSERT statement.")) - -(defmethod output-sql ((ins sql-insert) &optional - (database *default-database*)) - (with-slots (into attributes values query) - ins - (write-string "INSERT INTO " *sql-stream*) - (output-sql into database) - (when attributes - (write-char #\Space *sql-stream*) - (output-sql attributes database)) - (when values - (write-string " VALUES " *sql-stream*) - (output-sql values database)) - (when query - (write-char #\Space *sql-stream*) - (output-sql query database))) - t) - -;; DELETE - -(defclass sql-delete (%sql-expression) - ((from - :initarg :from - :initform nil) - (where - :initarg :where - :initform nil)) - (:documentation - "An SQL DELETE statement.")) - -(defmethod output-sql ((stmt sql-delete) &optional - (database *default-database*)) - (with-slots (from where) - stmt - (write-string "DELETE FROM " *sql-stream*) - (typecase from - (symbol (write-string (sql-escape from) *sql-stream*)) - (t (output-sql from database))) - (when where - (write-string " WHERE " *sql-stream*) - (output-sql where database))) - t) - -;; UPDATE - -(defclass sql-update (%sql-expression) - ((table - :initarg :table - :initform nil) - (attributes - :initarg :attributes - :initform nil) - (values - :initarg :values - :initform nil) - (where - :initarg :where - :initform nil)) - (:documentation "An SQL UPDATE statement.")) - -(defmethod output-sql ((expr sql-update) &optional - (database *default-database*)) - (with-slots (table where attributes values) - expr - (flet ((update-assignments () - (mapcar #'(lambda (a b) - (make-instance 'sql-assignment-exp - :operator '= - :sub-expressions (list a b))) - attributes values))) - (write-string "UPDATE " *sql-stream*) - (output-sql table database) - (write-string " SET " *sql-stream*) - (output-sql (apply #'vector (update-assignments)) database) - (when where - (write-string " WHERE " *sql-stream*) - (output-sql where database)))) - t) - -;; CREATE TABLE - -(defclass sql-create-table (%sql-expression) - ((name - :initarg :name - :initform nil) - (columns - :initarg :columns - :initform nil) - (modifiers - :initarg :modifiers - :initform nil)) - (:documentation - "An SQL CREATE TABLE statement.")) - -;; Here's a real warhorse of a function! - -(defun listify (x) - (if (atom x) - (list x) - x)) - -(defmethod output-sql ((stmt sql-create-table) &optional - (database *default-database*)) - (flet ((output-column (column-spec) - (destructuring-bind (name type &rest constraints) - column-spec - (let ((type (listify type))) - (output-sql name database) - (write-char #\Space *sql-stream*) - (write-string - (database-get-type-specifier (car type) (cdr type) database) - *sql-stream*) - (let ((constraints - (database-constraint-statement constraints database))) - (when constraints - (write-string " " *sql-stream*) - (write-string constraints *sql-stream*))))))) - (with-slots (name columns modifiers) - stmt - (write-string "CREATE TABLE " *sql-stream*) - (output-sql name database) - (write-string " (" *sql-stream*) - (do ((column columns (cdr column))) - ((null (cdr column)) - (output-column (car column))) - (output-column (car column)) - (write-string ", " *sql-stream*)) - (when modifiers - (do ((modifier (listify modifiers) (cdr modifier))) - ((null modifier)) - (write-string ", " *sql-stream*) - (write-string (car modifier) *sql-stream*))) - (write-char #\) *sql-stream*))) - t) - - -;; CREATE VIEW - -(defclass sql-create-view (%sql-expression) - ((name :initarg :name :initform nil) - (column-list :initarg :column-list :initform nil) - (query :initarg :query :initform nil) - (with-check-option :initarg :with-check-option :initform nil)) - (:documentation "An SQL CREATE VIEW statement.")) - -(defmethod output-sql ((stmt sql-create-view) &optional database) - (with-slots (name column-list query with-check-option) stmt - (write-string "CREATE VIEW " *sql-stream*) - (output-sql name database) - (when column-list (write-string " " *sql-stream*) - (output-sql (listify column-list) database)) - (write-string " AS " *sql-stream*) - (output-sql query database) - (when with-check-option (write-string " WITH CHECK OPTION" *sql-stream*)))) - - -;; -;; Column constraint types -;; -(defparameter *constraint-types* - '(("NOT-NULL" . "NOT NULL") - ("PRIMARY-KEY" . "PRIMARY KEY"))) - -;; -;; Convert type spec to sql syntax -;; - -(defmethod database-constraint-description (constraint database) - (declare (ignore database)) - (let ((output (assoc (symbol-name constraint) *constraint-types* - :test #'equal))) - (if (null output) - (error 'clsql-sql-syntax-error - :reason (format nil "unsupported column constraint '~a'" - constraint)) - (cdr output)))) - -(defmethod database-constraint-statement (constraint-list database) - (declare (ignore database)) - (make-constraints-description constraint-list)) - -(defun make-constraints-description (constraint-list) - (if constraint-list - (let ((string "")) - (do ((constraint constraint-list (cdr constraint))) - ((null constraint) string) - (let ((output (assoc (symbol-name (car constraint)) - *constraint-types* - :test #'equal))) - (if (null output) - (error 'clsql-sql-syntax-error - :reason (format nil "unsupported column constraint '~a'" - constraint)) - (setq string (concatenate 'string string (cdr output)))) - (if (< 1 (length constraint)) - (setq string (concatenate 'string string " ")))))))) - diff --git a/usql/kmr-mop.lisp b/usql/kmr-mop.lisp deleted file mode 100644 index 32cc35d..0000000 --- a/usql/kmr-mop.lisp +++ /dev/null @@ -1,48 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: kmr-mop.lisp -;;;; Purpose: MOP support for multiple-implementions -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Apr 2003 -;;;; -;;;; $Id: mop.lisp 8573 2004-01-29 23:30:50Z kevin $ -;;;; -;;;; This file was extracted from the KMRCL utilities -;;;; ************************************************************************* - -;;; This file imports MOP symbols into the USQL-MOP package and then -;;; re-exports into CLSQL-USQL-SYS them to hide differences in -;;; MOP implementations. - -(in-package #:clsql-usql-sys) - -#+lispworks -(defun intern-eql-specializer (slot) - `(eql ,slot)) - -(defmacro process-class-option (metaclass slot-name &optional required) - #+lispworks - `(defmethod clos:process-a-class-option ((class ,metaclass) - (name (eql ,slot-name)) - value) - (when (and ,required (null value)) - (error "metaclass ~A class slot ~A must have a value" (quote ,metaclass) name)) - (list name `',value)) - #-lispworks - (declare (ignore metaclass slot-name required)) - ) - -(defmacro process-slot-option (metaclass slot-name) - #+lispworks - `(defmethod clos:process-a-slot-option ((class ,metaclass) - (option (eql ,slot-name)) - value - already-processed-options - slot) - (list* option `',value already-processed-options)) - #-lispworks - (declare (ignore metaclass slot-name)) - ) - diff --git a/usql/metaclasses.lisp b/usql/metaclasses.lisp deleted file mode 100644 index 60679fb..0000000 --- a/usql/metaclasses.lisp +++ /dev/null @@ -1,528 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: metaclasses.lisp -;;;; Updated: <04/04/2004 12:08:11 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; CLSQL-USQL metaclass for standard-db-objects created in the OODDL. -;;;; -;;;; ====================================================================== - - -(in-package #:clsql-usql-sys) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (>= (length (generic-function-lambda-list - (ensure-generic-function - 'compute-effective-slot-definition))) - 3) - (pushnew :kmr-normal-cesd cl:*features*)) - - (when (>= (length (generic-function-lambda-list - (ensure-generic-function - 'direct-slot-definition-class))) - 3) - (pushnew :kmr-normal-dsdc cl:*features*)) - - (when (>= (length (generic-function-lambda-list - (ensure-generic-function - 'effective-slot-definition-class))) - 3) - (pushnew :kmr-normal-esdc cl:*features*))) - - -;; ------------------------------------------------------------ -;; metaclass: view-class - -(defclass standard-db-class (standard-class) - ((view-table - :accessor view-table - :initarg :view-table) - (definition - :accessor object-definition - :initarg :definition - :initform nil) - (version - :accessor object-version - :initarg :version - :initform 0) - (key-slots - :accessor key-slots - :initform nil) - (class-qualifier - :accessor view-class-qualifier - :initarg :qualifier - :initform nil)) - (:documentation "VIEW-CLASS metaclass.")) - -#+lispworks -(defmacro push-on-end (value location) - `(setf ,location (nconc ,location (list ,value)))) - -;; As Heiko Kirscke (author of PLOB!) would say: !@##^@%! Lispworks! -#+lispworks -(defconstant +extra-slot-options+ '(:column :db-kind :db-reader :nulls-ok - :db-writer :db-type :db-info)) - -#+lispworks -(define-setf-expander assoc (key alist &environment env) - (multiple-value-bind (temps vals stores store-form access-form) - (get-setf-expansion alist env) - (let ((new-value (gensym "NEW-VALUE-")) - (keyed (gensym "KEYED-")) - (accessed (gensym "ACCESSED-")) - (store-new-value (car stores))) - (values (cons keyed temps) - (cons key vals) - `(,new-value) - `(let* ((,accessed ,access-form) - (,store-new-value (assoc ,keyed ,accessed))) - (if ,store-new-value - (rplacd ,store-new-value ,new-value) - (progn - (setq ,store-new-value - (acons ,keyed ,new-value ,accessed)) - ,store-form)) - ,new-value) - `(assoc ,new-value ,access-form))))) - -#+lispworks -(defmethod clos::canonicalize-defclass-slot :around - ((prototype standard-db-class) slot) - "\\lw\\ signals an error on unknown slot options; so this method -removes any extra allowed options before calling the default method -and returns the canonicalized extra options concatenated to the result -of the default method. The extra allowed options are the value of the -\\fcite{+extra-slot-options+}." - (let ((extra-slot-options ()) - (rest-options ()) - (result ())) - (do ((olist (cdr slot) (cddr olist))) - ((null olist)) - (let ((option (car olist))) - (cond - ((find option +extra-slot-options+) - ;;(push (cons option (cadr olist)) extra-slot-options)) - (setf (assoc option extra-slot-options) (cadr olist))) - (t - (push (cadr olist) rest-options) - (push (car olist) rest-options))))) - (setf result (call-next-method prototype (cons (car slot) rest-options))) - (dolist (option extra-slot-options) - (push-on-end (car option) result) - (push-on-end `(quote ,(cdr option)) result)) - result)) - -#+lispworks -(defconstant +extra-class-options+ '(:base-table :version :schemas)) - -#+lispworks -(defmethod clos::canonicalize-class-options :around - ((prototype standard-db-class) class-options) - "\\lw\\ signals an error on unknown class options; so this method -removes any extra allowed options before calling the default method -and returns the canonicalized extra options concatenated to the result -of the default method. The extra allowed options are the value of the -\\fcite{+extra-class-options+}." - (let ((extra-class-options nil) - (rest-options ()) - (result ())) - (dolist (o class-options) - (let ((option (car o))) - (cond - ((find option +extra-class-options+) - ;;(push (cons option (cadr o)) extra-class-options)) - (setf (assoc option extra-class-options) (cadr o))) - (t - (push o rest-options))))) - (setf result (call-next-method prototype rest-options)) - (dolist (option extra-class-options) - (push-on-end (car option) result) - (push-on-end `(quote ,(cdr option)) result)) - result)) - - -(defmethod validate-superclass ((class standard-db-class) - (superclass standard-class)) - t) - -(defun table-name-from-arg (arg) - (cond ((symbolp arg) - arg) - ((typep arg 'sql-ident) - (slot-value arg 'name)) - ((stringp arg) - (intern (string-upcase arg))))) - -(defun column-name-from-arg (arg) - (cond ((symbolp arg) - arg) - ((typep arg 'sql-ident) - (slot-value arg 'name)) - ((stringp arg) - (intern (string-upcase arg))))) - - -(defun remove-keyword-arg (arglist akey) - (let ((mylist arglist) - (newlist ())) - (labels ((pop-arg (alist) - (let ((arg (pop alist)) - (val (pop alist))) - (unless (equal arg akey) - (setf newlist (append (list arg val) newlist))) - (when alist (pop-arg alist))))) - (pop-arg mylist)) - newlist)) - -(defmethod initialize-instance :around ((class standard-db-class) - &rest all-keys - &key direct-superclasses base-table - schemas version qualifier - &allow-other-keys) - (let ((root-class (find-class 'standard-db-object nil)) - (vmc (find-class 'standard-db-class))) - (setf (view-class-qualifier class) - (car qualifier)) - (if root-class - (if (member-if #'(lambda (super) - (eq (class-of super) vmc)) direct-superclasses) - (call-next-method) - (apply #'call-next-method - class - :direct-superclasses (append (list root-class) - direct-superclasses) - (remove-keyword-arg all-keys :direct-superclasses))) - (call-next-method)) - (setf (view-table class) - (table-name-from-arg (sql-escape (or (and base-table - (if (listp base-table) - (car base-table) - base-table)) - (class-name class))))) - (setf (object-version class) version) - (mapc (lambda (schema) - (pushnew (class-name class) (gethash schema *object-schemas*))) - (if (listp schemas) schemas (list schemas))) - (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 schemas version - direct-superclasses qualifier - &allow-other-keys) - (let ((root-class (find-class 'standard-db-object nil)) - (vmc (find-class 'standard-db-class))) - (setf (view-table class) - (table-name-from-arg (sql-escape (or (and base-table - (if (listp base-table) - (car base-table) - base-table)) - (class-name class))))) - (setf (view-class-qualifier class) - (car qualifier)) - (if (and root-class (not (equal class root-class))) - (if (member-if #'(lambda (super) - (eq (class-of super) vmc)) direct-superclasses) - (call-next-method) - (apply #'call-next-method - class - :direct-superclasses (append (list root-class) - direct-superclasses) - (remove-keyword-arg all-keys :direct-superclasses))) - (call-next-method))) - (setf (object-version class) version) - (mapc (lambda (schema) - (pushnew (class-name class) (gethash schema *object-schemas*))) - (if (listp schemas) schemas (list schemas))) - (register-metaclass class (nth (1+ (position :direct-slots all-keys)) - all-keys))) - - -(defun get-keywords (keys list) - (flet ((extract (key) - (let ((pos (position key list))) - (when pos - (nth (1+ pos) list))))) - (mapcar #'extract keys))) - -(defun describe-db-layout (class) - (flet ((not-db-col (col) - (not (member (nth 2 col) '(nil :base :key)))) - (frob-slot (slot) - (let ((type (slot-value slot 'type))) - (if (eq type t) - (setq type nil)) - (list (slot-value slot 'name) - type - (slot-value slot 'db-kind) - (and (slot-boundp slot 'column) - (slot-value slot 'column)))))) - (let ((all-slots (mapcar #'frob-slot (class-slots class)))) - (setq all-slots (remove-if #'not-db-col all-slots)) - (setq all-slots (stable-sort all-slots #'string< :key #'car)) - ;;(mapcar #'dink-type all-slots) - all-slots))) - -(defun register-metaclass (class slots) - (labels ((not-db-col (col) - (not (member (nth 2 col) '(nil :base :key)))) - (frob-slot (slot) - (get-keywords '(:name :type :db-kind :column) slot))) - (let ((all-slots (mapcar #'frob-slot slots))) - (setq all-slots (remove-if #'not-db-col all-slots)) - (setq all-slots (stable-sort all-slots #'string< :key #'car)) - (setf (object-definition class) all-slots)) - #-(or allegro openmcl) - (setf (key-slots class) (remove-if-not (lambda (slot) - (eql (slot-value slot 'db-kind) - :key)) - (class-slots class))))) - -#+(or allegro openmcl) -(defmethod finalize-inheritance :after ((class standard-db-class)) - (setf (key-slots class) (remove-if-not (lambda (slot) - (eql (slot-value slot 'db-kind) - :key)) - (class-slots class)))) - -;; return the deepest view-class ancestor for a given view class - -(defun base-db-class (classname) - (let* ((class (find-class classname)) - (db-class (find-class 'standard-db-object))) - (loop - (let ((cds (class-direct-superclasses class))) - (cond ((null cds) - (error "not a db class")) - ((member db-class cds) - (return (class-name class)))) - (setq class (car cds)))))) - -(defun db-ancestors (classname) - (let ((class (find-class classname)) - (db-class (find-class 'standard-db-object))) - (labels ((ancestors (class) - (let ((scs (class-direct-superclasses class))) - (if (member db-class scs) - (list class) - (append (list class) (mapcar #'ancestors scs)))))) - (ancestors class)))) - -(defclass view-class-slot-definition-mixin () - ((column - :accessor view-class-slot-column - :initarg :column - :documentation - "The name of the SQL column this slot is stored in. Defaults to -the slot name.") - (db-kind - :accessor view-class-slot-db-kind - :initarg :db-kind - :initform :base - :type keyword - :documentation - "The kind of DB mapping which is performed for this slot. :base -indicates the slot maps to an ordinary column of the DB view. :key -indicates that this slot corresponds to part of the unique keys for -this view, :join indicates ... and :virtual indicates that this slot -is an ordinary CLOS slot. Defaults to :base.") - (db-reader - :accessor view-class-slot-db-reader - :initarg :db-reader - :initform nil - :documentation - "If a string, then when reading values from the DB, the string -will be used for a format string, with the only value being the value -from the database. The resulting string will be used as the slot -value. If a function then it will take one argument, the value from -the database, and return the value that should be put into the slot.") - (db-writer - :accessor view-class-slot-db-writer - :initarg :db-writer - :initform nil - :documentation - "If a string, then when reading values from the slot for the DB, -the string will be used for a format string, with the only value being -the value of the slot. The resulting string will be used as the -column value in the DB. If a function then it will take one argument, -the value of the slot, and return the value that should be put into -the database.") - (db-type - :accessor view-class-slot-db-type - :initarg :db-type - :initform nil - :documentation - "A string which will be used as the type specifier for this slots -column definition in the database.") - (db-constraints - :accessor view-class-slot-db-constraints - :initarg :db-constraints - :initform nil - :documentation - "A single constraint or list of constraints for this column") - (nulls-ok - :accessor view-class-slot-nulls-ok - :initarg :nulls-ok - :initform nil - :documentation - "If t, all sql NULL values retrieved from the database become nil; if nil, -all NULL values retrieved are converted by DATABASE-NULL-VALUE") - (db-info - :accessor view-class-slot-db-info - :initarg :db-info - :documentation "Description of the join."))) - -(defparameter *db-info-lambda-list* - '(&key join-class - home-key - foreign-key - (key-join nil) - (target-slot nil) - (retrieval :immmediate) - (set nil))) - -(defun parse-db-info (db-info-list) - (destructuring-bind - (&key join-class home-key key-join foreign-key (delete-rule nil) - (target-slot nil) (retrieval :deferred) (set nil)) - db-info-list - (let ((ih (make-hash-table :size 6))) - (if join-class - (setf (gethash :join-class ih) join-class) - (error "Must specify :join-class in :db-info")) - (if home-key - (setf (gethash :home-key ih) home-key) - (error "Must specify :home-key in :db-info")) - (when delete-rule - (setf (gethash :delete-rule ih) delete-rule)) - (if foreign-key - (setf (gethash :foreign-key ih) foreign-key) - (error "Must specify :foreign-key in :db-info")) - (when key-join - (setf (gethash :key-join ih) t)) - (when target-slot - (setf (gethash :target-slot ih) target-slot)) - (when set - (setf (gethash :set ih) set)) - (when retrieval - (progn - (setf (gethash :retrieval ih) retrieval) - (if (eql retrieval :immediate) - (setf (gethash :set ih) nil)))) - ih))) - -(defclass view-class-direct-slot-definition (view-class-slot-definition-mixin - standard-direct-slot-definition) - ()) - -(defclass view-class-effective-slot-definition (view-class-slot-definition-mixin - standard-effective-slot-definition) - ()) - -(defmethod direct-slot-definition-class ((class standard-db-class) - #+kmr-normal-dsdc &rest - initargs) - (declare (ignore initargs)) - (find-class 'view-class-direct-slot-definition)) - -(defmethod effective-slot-definition-class ((class standard-db-class) - #+kmr-normal-esdc &rest - initargs) - (declare (ignore initargs)) - (find-class 'view-class-effective-slot-definition)) - -;; Compute the slot definition for slots in a view-class. Figures out -;; what kind of database value (if any) is stored there, generates and -;; verifies the column name. - -(defmethod compute-effective-slot-definition ((class standard-db-class) - #+kmr-normal-cesd slot-name - direct-slots) - #+kmr-normal-cesd (declare (ignore slot-name)) - (let ((slotd (call-next-method)) - (sd (car direct-slots))) - - (typecase sd - (view-class-slot-definition-mixin - ;; Use the specified :column argument if it is supplied, otherwise - ;; the column slot is filled in with the slot-name, but transformed - ;; to be sql safe, - to _ and such. - (setf (slot-value slotd 'column) - (column-name-from-arg - (if (slot-boundp sd 'column) - (view-class-slot-column sd) - (column-name-from-arg - (sql-escape (slot-definition-name sd)))))) - - (setf (slot-value slotd 'db-type) - (when (slot-boundp sd 'db-type) - (view-class-slot-db-type sd))) - - - (setf (slot-value slotd 'nulls-ok) - (view-class-slot-nulls-ok sd)) - - ;; :db-kind slot value defaults to :base (store slot value in - ;; database) - - (setf (slot-value slotd 'db-kind) - (if (slot-boundp sd 'db-kind) - (view-class-slot-db-kind sd) - :base)) - - (setf (slot-value slotd 'db-writer) - (when (slot-boundp sd 'db-writer) - (view-class-slot-db-writer sd))) - (setf (slot-value slotd 'db-constraints) - (when (slot-boundp sd 'db-constraints) - (view-class-slot-db-constraints sd))) - - - ;; I wonder if this slot option and the previous could be merged, - ;; so that :base and :key remain keyword options, but :db-kind - ;; :join becomes :db-kind (:join )? - - (setf (slot-value slotd 'db-info) - (when (slot-boundp sd 'db-info) - (if (listp (view-class-slot-db-info sd)) - (parse-db-info (view-class-slot-db-info sd)) - (view-class-slot-db-info sd))))) - ;; all other slots - (t - (change-class slotd 'view-class-effective-slot-definition - #+allegro :name - #+allegro (slot-definition-name sd)) - (setf (slot-value slotd 'column) - (column-name-from-arg - (sql-escape (slot-definition-name sd)))) - - (setf (slot-value slotd 'db-info) nil) - (setf (slot-value slotd 'db-kind) - :virtual))) - slotd)) - -(defun slotdefs-for-slots-with-class (slots class) - (let ((result nil)) - (dolist (s slots) - (let ((c (slotdef-for-slot-with-class s class))) - (if c (setf result (cons c result))))) - result)) - -(defun slotdef-for-slot-with-class (slot class) - (find-if #'(lambda (d) (eql slot (slot-definition-name d))) - (class-slots class))) - -#+ignore -(eval-when (:compile-toplevel :load-toplevel :execute) - #+kmr-normal-cesd - (setq cl:*features* (delete :kmr-normal-cesd cl:*features*)) - #+kmr-normal-dsdc - (setq cl:*features* (delete :kmr-normal-dsdc cl:*features*)) - #+kmr-normal-esdc - (setq cl:*features* (delete :kmr-normal-esdc cl:*features*)) - ) diff --git a/usql/objects.lisp b/usql/objects.lisp deleted file mode 100644 index 14bb76f..0000000 --- a/usql/objects.lisp +++ /dev/null @@ -1,1110 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: objects.lisp -;;;; Updated: <04/04/2004 12:07:55 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; The CLSQL-USQL Object Oriented Data Definitional Language (OODDL) -;;;; and Object Oriented Data Manipulation Language (OODML). -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-sys) - -(defclass standard-db-object () - ((view-database - :initform nil - :initarg :view-database - :db-kind :virtual)) - (:metaclass standard-db-class) - (:documentation "Superclass for all CLSQL-USQL View Classes.")) - -(defmethod view-database ((self standard-db-object)) - (slot-value self 'view-database)) - -(defvar *db-deserializing* nil) -(defvar *db-initializing* nil) - -(defmethod slot-value-using-class ((class standard-db-class) instance slot) - (declare (optimize (speed 3))) - (unless *db-deserializing* - (let ((slot-name (%slot-name slot)) - (slot-object (%slot-object slot class))) - (when (and (eql (view-class-slot-db-kind slot-object) :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) - (declare (ignore new-value instance slot)) - (call-next-method)) - -;; JMM - Can't go around trying to slot-access a symbol! Guess in -;; CMUCL slot-name is the actual slot _object_, while in lispworks it -;; is a lowly symbol (the variable is called slot-name after all) so -;; the object (or in MOP terminology- the "slot definition") has to be -;; retrieved using find-slot-definition - -(defun %slot-name (slot) - #+lispworks slot - #-lispworks (slot-definition-name slot)) - -(defun %slot-object (slot class) - (declare (ignorable class)) - #+lispworks (clos:find-slot-definition slot class) - #-lispworks slot) - -(defmethod initialize-instance :around ((class standard-db-object) - &rest all-keys - &key &allow-other-keys) - (declare (ignore all-keys)) - (let ((*db-deserializing* t)) - (call-next-method))) - -(defun sequence-from-class (view-class-name) - (sql-escape - (concatenate - 'string - (symbol-name (view-table (find-class view-class-name))) - "-SEQ"))) - -(defun create-sequence-from-class (view-class-name - &key (database *default-database*)) - (create-sequence (sequence-from-class view-class-name) :database database)) - -(defun drop-sequence-from-class (view-class-name - &key (if-does-not-exist :error) - (database *default-database*)) - (drop-sequence (sequence-from-class view-class-name) - :if-does-not-exist if-does-not-exist - :database database)) - -;; -;; Build the database tables required to store the given view class -;; - -(defmethod database-pkey-constraint ((class standard-db-class) database) - (let ((keylist (mapcar #'view-class-slot-column (keyslots-for-class class)))) - (when keylist - (format nil "CONSTRAINT ~APK PRIMARY KEY~A" - (database-output-sql (view-table class) database) - (database-output-sql keylist database))))) - - -#.(locally-enable-sql-reader-syntax) - -(defun ensure-schema-version-table (database) - (unless (table-exists-p "usql_object_v" :database database) - (create-table [usql_object_v] '(([name] (string 32)) - ([vers] integer) - ([def] (string 32))) - :database database))) - -(defun update-schema-version-records (view-class-name - &key (database *default-database*)) - (let ((schemadef nil) - (tclass (find-class view-class-name))) - (dolist (slotdef (class-slots tclass)) - (let ((res (database-generate-column-definition view-class-name - slotdef database))) - (when res (setf schemadef (cons res schemadef))))) - (when schemadef - (delete-records :from [usql_object_v] - :where [= [name] (sql-escape (class-name tclass))] - :database database) - (insert-records :into [usql_object_v] - :av-pairs `(([name] ,(sql-escape (class-name tclass))) - ([vers] ,(car (object-version tclass))) - ([def] ,(prin1-to-string - (object-definition tclass)))) - :database database)))) - -#.(restore-sql-reader-syntax-state) - -(defun create-view-from-class (view-class-name - &key (database *default-database*)) - "Creates a view in DATABASE based on VIEW-CLASS-NAME which defines -the view. The argument DATABASE has a default value of -*DEFAULT-DATABASE*." - (let ((tclass (find-class view-class-name))) - (if tclass - (let ((*default-database* database)) - (%install-class tclass database) - (ensure-schema-version-table database) - (update-schema-version-records view-class-name :database database)) - (error "Class ~s not found." view-class-name))) - (values)) - -(defmethod %install-class ((self standard-db-class) database &aux schemadef) - (dolist (slotdef (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)) schemadef - :database database - :constraints (database-pkey-constraint self database)) - (push self (database-view-classes database)) - t) - -;; -;; Drop the tables which store the given view class -;; - -#.(locally-enable-sql-reader-syntax) - -(defun drop-view-from-class (view-class-name &key (database *default-database*)) - "Deletes a view or base table from DATABASE based on VIEW-CLASS-NAME -which defines that view. The argument DATABASE has a default value of -*DEFAULT-DATABASE*." - (let ((tclass (find-class view-class-name))) - (if tclass - (let ((*default-database* database)) - (%uninstall-class tclass) - (delete-records :from [usql_object_v] - :where [= [name] (sql-escape view-class-name)])) - (error "Class ~s not found." view-class-name))) - (values)) - -#.(restore-sql-reader-syntax-state) - -(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 'standard-db-object) - (database *default-database*)) - "Returns a list of View Classes connected to a given DATABASE which -defaults to *DEFAULT-DATABASE*." - (declare (ignore root-class)) - (remove-if #'(lambda (c) (not (funcall test c))) - (database-view-classes database))) - -;; -;; Define a new view class -;; - -(defmacro def-view-class (class supers slots &rest options) - "Extends the syntax of defclass to allow special slots to be mapped -onto the attributes of database views. The macro DEF-VIEW-CLASS -creates a class called CLASS which maps onto a database view. Such a -class is called a View Class. The macro DEF-VIEW-CLASS extends the -syntax of DEFCLASS to allow special base slots to be mapped onto the -attributes of database views (presently single tables). When a select -query that names a View Class is submitted, then the corresponding -database view is queried, and the slots in the resulting View Class -instances are filled with attribute values from the database. If -SUPERS is nil then STANDARD-DB-OBJECT automatically becomes the -superclass of the newly-defined View Class." - `(progn - (defclass ,class ,supers ,slots ,@options - (:metaclass standard-db-class)) - (finalize-inheritance (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)))) - (flet ((qfk (k) - (sql-operation '== - (sql-expression :attribute - (view-class-slot-column k) - :table tb) - (db-value-from-slot - k - (slot-value obj (slot-definition-name k)) - database)))) - (let* ((keys (keyslots-for-class (class-of obj))) - (keyxprs (mapcar #'qfk (reverse keys)))) - (cond - ((= (length keyxprs) 0) nil) - ((= (length keyxprs) 1) (car keyxprs)) - ((> (length keyxprs) 1) (apply #'sql-operation 'and keyxprs))))))) - -;; -;; Function used by 'generate-selection-list' -;; - -(defun generate-attribute-reference (vclass slotdef) - (cond - ((eq (view-class-slot-db-kind slotdef) :base) - (sql-expression :attribute (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 (class-slots vclass)) - (let ((res (generate-attribute-reference vclass slotdef))) - (when res - (push (cons slotdef res) sels)))) - (if sels - sels - (error "No slots of type :base in view-class ~A" (class-name vclass))))) - -;; -;; Used by 'create-view-from-class' -;; - - -(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)) - (slot-type slotdef)))) - (let ((const (view-class-slot-db-constraints slotdef))) - (when const - (setq cdef (append cdef (list const))))) - cdef))) - -;; -;; Called by 'get-slot-values-from-view' -;; - -(declaim (inline delistify)) -(defun delistify (list) - (if (listp list) - (car list) - list)) - -(defun slot-type (slotdef) - (let ((slot-type (slot-definition-type slotdef))) - (if (listp slot-type) - (cons (find-symbol (symbol-name (car slot-type)) :usql-sys) - (cdr slot-type)) - (find-symbol (symbol-name slot-type) :usql-sys)))) - -(defmethod update-slot-from-db ((instance standard-db-object) slotdef value) - (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) - (let ((slot-reader (view-class-slot-db-reader slotdef)) - (slot-name (slot-definition-name slotdef)) - (slot-type (slot-type slotdef))) - (cond ((and value (null slot-reader)) - (setf (slot-value instance slot-name) - (read-sql-value value (delistify slot-type) - (view-database instance)))) - ((null value) - (update-slot-with-null instance slot-name slotdef)) - ((typep slot-reader 'string) - (setf (slot-value instance slot-name) - (format nil slot-reader value))) - ((typep slot-reader 'function) - (setf (slot-value instance slot-name) - (apply slot-reader (list value)))) - (t - (error "Slot reader is of an unusual type."))))) - -(defmethod key-value-from-db (slotdef value database) - (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3))) - (let ((slot-reader (view-class-slot-db-reader slotdef)) - (slot-type (slot-type slotdef))) - (cond ((and value (null slot-reader)) - (read-sql-value value (delistify slot-type) database)) - ((null value) - nil) - ((typep slot-reader 'string) - (format nil slot-reader value)) - ((typep slot-reader 'function) - (apply slot-reader (list value))) - (t - (error "Slot reader is of an unusual type."))))) - -(defun db-value-from-slot (slotdef val database) - (let ((dbwriter (view-class-slot-db-writer slotdef)) - (dbtype (slot-type slotdef))) - (typecase dbwriter - (string (format nil dbwriter val)) - (function (apply dbwriter (list val))) - (t - (typecase dbtype - (cons - (database-output-sql-as-type (car dbtype) val database)) - (t - (database-output-sql-as-type dbtype val database))))))) - -(defun check-slot-type (slotdef val) - (let* ((slot-type (slot-type slotdef)) - (basetype (if (listp slot-type) (car slot-type) slot-type))) - (when (and slot-type val) - (unless (typep val basetype) - (error 'clsql-type-error - :slotname (slot-definition-name slotdef) - :typespec slot-type - :value val))))) - -;; -;; Called by find-all -;; - -(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)) - - -(defun synchronize-keys (src srckey dest destkey) - (let ((skeys (if (listp srckey) srckey (list srckey))) - (dkeys (if (listp destkey) destkey (list destkey)))) - (mapcar #'(lambda (sk dk) - (setf (slot-value dest dk) - (typecase sk - (symbol - (slot-value src sk)) - (t sk)))) - skeys dkeys))) - -(defun desynchronize-keys (dest destkey) - (let ((dkeys (if (listp destkey) destkey (list destkey)))) - (mapcar #'(lambda (dk) - (setf (slot-value dest dk) nil)) - dkeys))) - -(defmethod add-to-relation ((target standard-db-object) - slot-name - (value standard-db-object)) - (let* ((objclass (class-of target)) - (sdef (or (slotdef-for-slot-with-class slot-name objclass) - (error "~s is not an known slot on ~s" slot-name target))) - (dbinfo (view-class-slot-db-info sdef)) - (join-class (gethash :join-class dbinfo)) - (homekey (gethash :home-key dbinfo)) - (foreignkey (gethash :foreign-key dbinfo)) - (to-many (gethash :set dbinfo))) - (unless (equal (type-of value) join-class) - (error 'clsql-type-error :slotname slot-name :typespec join-class - :value value)) - (when (gethash :target-slot dbinfo) - (error "add-to-relation does not work with many-to-many relations yet.")) - (if to-many - (progn - (synchronize-keys target homekey value foreignkey) - (if (slot-boundp target slot-name) - (unless (member value (slot-value target slot-name)) - (setf (slot-value target slot-name) - (append (slot-value target slot-name) (list value)))) - (setf (slot-value target slot-name) (list value)))) - (progn - (synchronize-keys value foreignkey target homekey) - (setf (slot-value target slot-name) value))))) - -(defmethod remove-from-relation ((target standard-db-object) - slot-name (value standard-db-object)) - (let* ((objclass (class-of target)) - (sdef (slotdef-for-slot-with-class slot-name objclass)) - (dbinfo (view-class-slot-db-info sdef)) - (homekey (gethash :home-key dbinfo)) - (foreignkey (gethash :foreign-key dbinfo)) - (to-many (gethash :set dbinfo))) - (when (gethash :target-slot dbinfo) - (error "remove-relation does not work with many-to-many relations yet.")) - (if to-many - (progn - (desynchronize-keys value foreignkey) - (if (slot-boundp target slot-name) - (setf (slot-value target slot-name) - (remove value - (slot-value target slot-name) - :test #'equal)))) - (progn - (desynchronize-keys target homekey) - (setf (slot-value target slot-name) - nil))))) - -(defgeneric update-record-from-slot (object slot &key database) - (:documentation - "The generic function UPDATE-RECORD-FROM-SLOT updates an individual -data item in the column represented by SLOT. The DATABASE is only used -if OBJECT is not yet associated with any database, in which case a -record is created in DATABASE. Only SLOT is initialized in this case; -other columns in the underlying database receive default values. The -argument SLOT is the CLOS slot name; the corresponding column names -are derived from the View Class definition.")) - -(defmethod update-record-from-slot ((obj standard-db-object) slot &key - (database *default-database*)) - (let* ((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 (view-database obj))) - ((and vct sd (not (view-database obj))) - (install-instance obj :database database)) - (t - (error "Unable to update record."))))) - (values)) - -(defgeneric update-record-from-slots (object slots &key database) - (:documentation - "The generic function UPDATE-RECORD-FROM-SLOTS updates data in the -columns represented by SLOTS. The DATABASE is only used if OBJECT is -not yet associated with any database, in which case a record is -created in DATABASE. Only slots are initialized in this case; other -columns in the underlying database receive default values. The -argument SLOTS contains the CLOS slot names; the corresponding column -names are derived from the view class definition.")) - -(defmethod update-record-from-slots ((obj standard-db-object) slots &key - (database *default-database*)) - (let* ((vct (view-table (class-of obj))) - (sds (slotdefs-for-slots-with-class slots (class-of obj))) - (avps (mapcar #'(lambda (s) - (let ((val (slot-value - obj (slot-definition-name s)))) - (check-slot-type s val) - (list (sql-expression - :attribute (view-class-slot-column s)) - (db-value-from-slot s val database)))) - sds))) - (cond ((and avps (view-database obj)) - (update-records (sql-expression :table vct) - :av-pairs avps - :where (key-qualifier-for-instance - obj :database database) - :database (view-database obj))) - ((and avps (not (view-database obj))) - (insert-records :into (sql-expression :table vct) - :av-pairs avps - :database database) - (setf (slot-value obj 'view-database) database)) - (t - (error "Unable to update records")))) - (values)) - -(defgeneric update-records-from-instance (object &key database) - (:documentation - "Using an instance of a view class, update the database table that -stores its instance data. If the instance is already associated with a -database, that database is used, and database is ignored. If instance -is not yet associated with a database, a record is created for -instance in the appropriate table of database and the instance becomes -associated with that database.")) - -(defmethod update-records-from-instance ((obj standard-db-object) - &key (database *default-database*)) - (labels ((slot-storedp (slot) - (and (member (view-class-slot-db-kind slot) '(:base :key)) - (slot-boundp obj (slot-definition-name slot)))) - (slot-value-list (slot) - (let ((value (slot-value 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)) - (view-class-table (view-table view-class)) - (slots (remove-if-not #'slot-storedp (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 (view-database obj)) - (progn - (insert-records :into (sql-expression :table view-class-table) - :av-pairs record-values - :database database) - (setf (slot-value obj 'view-database) database))) - (values)))) - -(defmethod install-instance ((obj standard-db-object) - &key (database *default-database*)) - (labels ((slot-storedp (slot) - (and (member (view-class-slot-db-kind slot) '(:base :key)) - (slot-boundp obj (slot-definition-name slot)))) - (slot-value-list (slot) - (let ((value (slot-value 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)) - (view-class-table (view-table view-class)) - (slots (remove-if-not #'slot-storedp (class-slots view-class))) - (record-values (mapcar #'slot-value-list slots))) - (unless record-values - (error "No settable slots.")) - (unless - (let ((obj-db (slot-value obj 'view-database))) - (when obj-db - (equal obj-db database)))) - (insert-records :into (sql-expression :table view-class-table) - :av-pairs record-values - :database database) - (setf (slot-value obj 'view-database) database)) - (values))) - -;; Perhaps the slot class is not correct in all CLOS implementations, -;; tho I have not run across a problem yet. - -(defmethod handle-cascade-delete-rule ((instance standard-db-object) - (slot - view-class-effective-slot-definition)) - (let ((val (slot-value instance (slot-definition-name slot)))) - (typecase val - (list - (if (gethash :target-slot (view-class-slot-db-info slot)) - ;; For relations with target-slot, we delete just the join instance - (mapcar #'(lambda (obj) - (delete-instance-records obj)) - (fault-join-slot-raw (class-of instance) instance slot)) - (dolist (obj val) - (delete-instance-records obj)))) - (standard-db-object - (delete-instance-records val))))) - -(defmethod nullify-join-foreign-keys ((instance standard-db-object) slot) - (let* ((dbi (view-class-slot-db-info slot)) - (fkeys (gethash :foreign-keys dbi))) - (mapcar #'(lambda (fk) - (if (view-class-slot-nulls-ok slot) - (setf (slot-value instance fk) nil) - (warn "Nullify delete rule cannot set slot not allowing nulls to nil"))) - (if (listp fkeys) fkeys (list fkeys))))) - -(defmethod handle-nullify-delete-rule ((instance standard-db-object) - (slot - view-class-effective-slot-definition)) - (let ((dbi (view-class-slot-db-info slot))) - (if (gethash :set dbi) - (if (gethash :target-slot (view-class-slot-db-info slot)) - ;;For relations with target-slot, we delete just the join instance - (mapcar #'(lambda (obj) - (nullify-join-foreign-keys obj slot)) - (fault-join-slot-raw (class-of instance) instance slot)) - (dolist (obj (slot-value instance (slot-definition-name slot))) - (nullify-join-foreign-keys obj slot))) - (nullify-join-foreign-keys - (slot-value instance (slot-definition-name slot)) slot)))) - -(defmethod propogate-deletes ((instance standard-db-object)) - (let* ((view-class (class-of instance)) - (joins (remove-if #'(lambda (sd) - (not (equal (view-class-slot-db-kind sd) :join))) - (class-slots view-class)))) - (dolist (slot joins) - (let ((delete-rule (gethash :delete-rule (view-class-slot-db-info slot)))) - (cond - ((eql delete-rule :cascade) - (handle-cascade-delete-rule instance slot)) - ((eql delete-rule :deny) - (when (slot-value instance (slot-definition-name slot)) - (error - "Unable to delete slot ~A, because it has a deny delete rule." - slot))) - ((eql delete-rule :nullify) - (handle-nullify-delete-rule instance slot)) - (t t)))))) - -(defgeneric delete-instance-records (instance) - (:documentation - "Deletes the records represented by INSTANCE from the database -associated with it. If instance has no associated database, an error -is signalled.")) - -(defmethod delete-instance-records ((instance standard-db-object)) - (let ((vt (sql-expression :table (view-table (class-of instance)))) - (vd (or (view-database instance) *default-database*))) - (when vd - (let ((qualifier (key-qualifier-for-instance instance :database vd))) - (with-transaction (:database vd) - (propogate-deletes instance) - (delete-records :from vt :where qualifier :database vd) - (setf (slot-value instance 'view-database) nil))))) - (values)) - -(defgeneric update-instance-from-records (instance &key database) - (:documentation - "Updates the values in the slots of the View Class instance -INSTANCE using the data in the database DATABASE which defaults to the -database that INSTANCE is associated with, or the value of -*DEFAULT-DATABASE*.")) - -(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))))) - (get-slot-values-from-view instance (mapcar #'car sels) (car res)))) - -(defgeneric update-slot-from-record (instance slot &key database) - (:documentation - "Updates the value in the slot SLOT of the View Class instance -INSTANCE using the data in the database DATABASE which defaults to the -database that INSTANCE is associated with, or the value of -*DEFAULT-DATABASE*.")) - -(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))) - (get-slot-values-from-view instance (list slot-def) (car res)))) - - -(defgeneric database-null-value (type) - (:documentation "Return an expression of type TYPE which SQL NULL values -will be converted into.")) - -(defmethod database-null-value ((type t)) - (cond - ((subtypep type 'string) "") - ((subtypep type 'integer) 0) - ((subtypep type 'float) (float 0.0)) - ((subtypep type 'list) nil) - ((subtypep type 'boolean) nil) - ((subtypep type 'symbol) nil) - ((subtypep type 'keyword) nil) - ((subtypep type 'wall-time) nil) - (t - (error "Unable to handle null for type ~A" type)))) - -(defgeneric update-slot-with-null (instance slotname slotdef) - (:documentation "Called to update a slot when its column has a NULL -value. If nulls are allowed for the column, the slot's value will be -nil, otherwise its value will be set to the result of calling -DATABASE-NULL-VALUE on the type of the slot.")) - -(defmethod update-slot-with-null ((instance standard-db-object) - slotname - slotdef) - (let ((st (slot-type slotdef)) - (allowed (slot-value slotdef 'nulls-ok))) - (if allowed - (setf (slot-value instance slotname) nil) - (setf (slot-value instance slotname) - (database-null-value st))))) - -(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)))) - -(defsql sql-view-class (:symbol "view-class") (classname &optional (database *default-database*)) - (declare (ignore database)) - (let* ((class (find-class classname))) - (unless (view-table class) - (error "No view-table for class ~A" classname)) - (sql-expression :table (view-table class)))) - -(defmethod database-get-type-specifier (type args database) - (declare (ignore type args)) - (if (member (database-type database) '(:postgresql :postgresql-socket)) - "VARCHAR" - "VARCHAR(255)")) - -(defmethod database-get-type-specifier ((type (eql 'integer)) args database) - (declare (ignore database)) - ;;"INT8") - (if args - (format nil "INT(~A)" (car args)) - "INT")) - -(defmethod database-get-type-specifier ((type (eql 'simple-base-string)) args - database) - (if args - (format nil "VARCHAR(~A)" (car args)) - (if (member (database-type database) '(:postgresql :postgresql-socket)) - "VARCHAR" - "VARCHAR(255)"))) - -(defmethod database-get-type-specifier ((type (eql 'simple-string)) args - database) - (if args - (format nil "VARCHAR(~A)" (car args)) - (if (member (database-type database) '(:postgresql :postgresql-socket)) - "VARCHAR" - "VARCHAR(255)"))) - -(defmethod database-get-type-specifier ((type (eql 'string)) args database) - (if args - (format nil "VARCHAR(~A)" (car args)) - (if (member (database-type database) '(:postgresql :postgresql-socket)) - "VARCHAR" - "VARCHAR(255)"))) - -(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database) - (declare (ignore args)) - (case (database-type database) - (:postgresql - "TIMESTAMP WITHOUT TIME ZONE") - (:postgresql-socket - "TIMESTAMP WITHOUT TIME ZONE") - (:mysql - "DATETIME") - (t "TIMESTAMP"))) - -(defmethod database-get-type-specifier ((type (eql 'duration)) args database) - (declare (ignore database args)) - "INT8") - -(deftype raw-string (&optional len) - "A string which is not trimmed when retrieved from the database" - `(string ,len)) - -(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database) - (declare (ignore database)) - (if args - (format nil "VARCHAR(~A)" (car args)) - "VARCHAR")) - -(defmethod database-get-type-specifier ((type (eql 'float)) args database) - (declare (ignore database)) - (if args - (format nil "FLOAT(~A)" (car args)) - "FLOAT")) - -(defmethod database-get-type-specifier ((type (eql 'long-float)) args database) - (declare (ignore database)) - (if args - (format nil "FLOAT(~A)" (car args)) - "FLOAT")) - -(defmethod database-get-type-specifier ((type (eql 'boolean)) args database) - (declare (ignore args database)) - "BOOL") - -(defmethod database-output-sql-as-type (type val database) - (declare (ignore type database)) - val) - -(defmethod database-output-sql-as-type ((type (eql 'list)) val database) - (declare (ignore database)) - (progv '(*print-circle* *print-array*) '(t t) - (prin1-to-string val))) - -(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) - (declare (ignore database)) - (if (keywordp val) - (symbol-name val) - (if val - (concatenate 'string - (package-name (symbol-package val)) - "::" - (symbol-name val)) - ""))) - -(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database) - (declare (ignore database)) - (if val - (symbol-name val) - "")) - -(defmethod database-output-sql-as-type ((type (eql 'vector)) val database) - (declare (ignore database)) - (progv '(*print-circle* *print-array*) '(t t) - (prin1-to-string val))) - -(defmethod database-output-sql-as-type ((type (eql 'array)) val database) - (declare (ignore database)) - (progv '(*print-circle* *print-array*) '(t t) - (prin1-to-string val))) - -(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database) - (declare (ignore database)) - (if val "t" "f")) - -(defmethod database-output-sql-as-type ((type (eql 'string)) val database) - (declare (ignore database)) - val) - -(defmethod database-output-sql-as-type ((type (eql 'simple-string)) - val database) - (declare (ignore database)) - val) - -(defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) - val database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val type database) - (declare (ignore type database)) - (read-from-string val)) - -(defmethod read-sql-value (val (type (eql 'string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'simple-string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'simple-base-string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'raw-string)) database) - (declare (ignore database)) - val) - -(defmethod read-sql-value (val (type (eql 'keyword)) database) - (declare (ignore database)) - (when (< 0 (length val)) - (intern (string-upcase val) "KEYWORD"))) - -(defmethod read-sql-value (val (type (eql 'symbol)) database) - (declare (ignore database)) - (when (< 0 (length val)) - (if (find #\: val) - (read-from-string val) - (intern (string-upcase val) "KEYWORD")))) - -(defmethod read-sql-value (val (type (eql 'integer)) database) - (declare (ignore database)) - (etypecase val - (string - (read-from-string val)) - (number val))) - -(defmethod read-sql-value (val (type (eql 'float)) database) - (declare (ignore database)) - ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) - (float (read-from-string val))) - -(defmethod read-sql-value (val (type (eql 'boolean)) database) - (declare (ignore database)) - (equal "t" val)) - -(defmethod read-sql-value (val (type (eql 'wall-time)) database) - (declare (ignore database)) - (unless (eq 'NULL val) - (parse-timestring val))) - - -;; ------------------------------------------------------------ -;; Logic for 'faulting in' :join slots - -(defun fault-join-slot-raw (class instance slot-def) - (let* ((dbi (view-class-slot-db-info slot-def)) - (jc (gethash :join-class dbi))) - (let ((jq (join-qualifier class instance slot-def))) - (when jq - (select jc :where jq))))) - -(defun fault-join-slot (class instance slot-def) - (let* ((dbi (view-class-slot-db-info slot-def)) - (ts (gethash :target-slot dbi)) - (res (fault-join-slot-raw class instance slot-def))) - (when res - (cond - ((and ts (gethash :set dbi)) - (mapcar (lambda (obj) - (cons obj (slot-value obj ts))) res)) - ((and ts (not (gethash :set dbi))) - (mapcar (lambda (obj) (slot-value obj ts)) res)) - ((and (not ts) (not (gethash :set dbi))) - (car res)) - ((and (not ts) (gethash :set dbi)) - res))))) - -(defun join-qualifier (class instance 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 instance slt) - (not (null (slot-value instance 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 instance 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)))))) - - -(defun find-all (view-classes &rest args &key all set-operation distinct from - where group-by having order-by order-by-descending offset limit - (database *default-database*)) - "tweeze me apart someone pleeze" - (declare (ignore all set-operation from group-by having offset limit) - (optimize (debug 3) (speed 1))) - (let* ((*db-deserializing* t) - (*default-database* (or database (error 'clsql-nodb-error)))) - (flet ((table-sql-expr (table) - (sql-expression :table (view-table table))) - (ref-equal (ref1 ref2) - (equal (sql ref1) - (sql ref2))) - (tables-equal (table-a table-b) - (string= (string (slot-value table-a 'name)) - (string (slot-value table-b 'name))))) - - (let* ((sclasses (mapcar #'find-class view-classes)) - (sels (mapcar #'generate-selection-list sclasses)) - (fullsels (apply #'append sels)) - (sel-tables (collect-table-refs where)) - (tables - (remove-duplicates - (append (mapcar #'table-sql-expr sclasses) sel-tables) - :test #'tables-equal)) - (res nil)) - (dolist (ob (listify order-by)) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - (dolist (ob (listify order-by-descending)) - (when (and ob (not (member ob (mapcar #'cdr fullsels) - :test #'ref-equal))) - (setq fullsels - (append fullsels (mapcar #'(lambda (att) (cons nil att)) - (listify ob)))))) - (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)))))) - ;;(format t "~%fullsels is : ~A" fullsels) - (setq res (apply #'select (append (mapcar #'cdr fullsels) - (cons :from (list tables)) args))) - (flet ((build-instance (vals) - (flet ((%build-instance (vclass selects) - (let ((class-name (class-name vclass)) - (db-vals (butlast vals - (- (list-length vals) - (list-length selects)))) - cache-key) - (setf vals (nthcdr (list-length selects) vals)) - (loop for select in selects - for value in db-vals - do - (when (eql (slot-value (car select) 'db-kind) - :key) - (push - (key-value-from-db (car select) value - *default-database*) - cache-key))) - (push class-name cache-key) - (%make-fresh-object class-name - (mapcar #'car selects) - db-vals)))) - (let ((instances (mapcar #'%build-instance sclasses sels))) - (if (= (length sclasses) 1) - (car instances) - instances))))) - (remove-if #'null (mapcar #'build-instance res))))))) - -(defun %make-fresh-object (class-name slots values) - (let* ((*db-initializing* t) - (obj (make-instance class-name - :view-database *default-database*))) - (setf obj (get-slot-values-from-view obj slots values)) - (postinitialize obj) - obj)) - -(defmethod postinitialize ((self t)) - ) - -(defun select (&rest select-all-args) - "Selects data from database given the constraints specified. Returns -a list of lists of record values as specified by select-all-args. By -default, the records are each represented as lists of attribute -values. The selections argument may be either db-identifiers, literal -strings or view classes. If the argument consists solely of view -classes, the return value will be instances of objects rather than raw -tuples." - (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) - (if (select-objects target-args) - (apply #'find-all target-args qualifier-args) - (let ((expr (apply #'make-query select-all-args))) - (destructuring-bind (&key (flatp nil) - (database *default-database*) - &allow-other-keys) - qualifier-args - (let ((res (query expr :database database))) - (if (and flatp - (= (length (slot-value expr 'selections)) 1)) - (mapcar #'car res) - res)))))))) diff --git a/usql/operations.lisp b/usql/operations.lisp deleted file mode 100644 index b07c068..0000000 --- a/usql/operations.lisp +++ /dev/null @@ -1,201 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: operations.lisp -;;;; Updated: <04/04/2004 12:07:26 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Definition of SQL operations used with the symbolic SQL syntax. -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-sys) - - -;; Keep a hashtable for mapping symbols to sql generator functions, -;; for use by the bracketed reader syntax. - -(defvar *sql-op-table* (make-hash-table :test #'equal)) - - -;; Define an SQL operation type. - -(defmacro defsql (function definition-keys &body body) - `(progn - (defun ,function ,@body) - (let ((symbol (cadr (member :symbol ',definition-keys)))) - (setf (gethash (if symbol (string-upcase symbol) ',function) - *sql-op-table*) - ',function)))) - - -;; SQL operations - -(defsql sql-query (:symbol "select") (&rest args) - (apply #'make-query args)) - -(defsql sql-any (:symbol "any") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'any :components rest)) - -(defsql sql-all (:symbol "all") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'all :components rest)) - -(defsql sql-not (:symbol "not") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'not :components rest)) - -(defsql sql-union (:symbol "union") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'union :components rest)) - -(defsql sql-intersect (:symbol "intersect") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'intersect :components rest)) - -(defsql sql-minus (:symbol "minus") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'minus :components rest)) - -(defsql sql-group-by (:symbol "group-by") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'group-by :components rest)) - -(defsql sql-limit (:symbol "limit") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'limit :components rest)) - -(defsql sql-having (:symbol "having") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'having :components rest)) - -(defsql sql-null (:symbol "null") (&rest rest) - (if rest - (make-instance 'sql-relational-exp :operator '|IS NULL| - :sub-expressions (list (car rest))) - (make-instance 'sql-value-exp :components 'null))) - -(defsql sql-not-null (:symbol "not-null") () - (make-instance 'sql-value-exp - :components '|NOT NULL|)) - -(defsql sql-exists (:symbol "exists") (&rest rest) - (make-instance 'sql-value-exp - :modifier 'exists :components rest)) - -(defsql sql-* (:symbol "*") (&rest rest) - (if (zerop (length rest)) - (make-instance 'sql-ident :name '*) - ;(error 'clsql-sql-syntax-error :reason "'*' with arguments"))) - (make-instance 'sql-relational-exp :operator '* :sub-expressions rest))) - -(defsql sql-+ (:symbol "+") (&rest rest) - (if (cdr rest) - (make-instance 'sql-relational-exp - :operator '+ :sub-expressions rest) - (make-instance 'sql-value-exp :modifier '+ :components rest))) - -(defsql sql-/ (:symbol "/") (&rest rest) - (make-instance 'sql-relational-exp - :operator '/ :sub-expressions rest)) - -(defsql sql-- (:symbol "-") (&rest rest) - (if (cdr rest) - (make-instance 'sql-relational-exp - :operator '- :sub-expressions rest) - (make-instance 'sql-value-exp :modifier '- :components rest))) - -(defsql sql-like (:symbol "like") (&rest rest) - (make-instance 'sql-relational-exp - :operator 'like :sub-expressions rest)) - -(defsql sql-uplike (:symbol "uplike") (&rest rest) - (make-instance 'sql-upcase-like - :sub-expressions rest)) - -(defsql sql-and (:symbol "and") (&rest rest) - (make-instance 'sql-relational-exp - :operator 'and :sub-expressions rest)) - -(defsql sql-or (:symbol "or") (&rest rest) - (make-instance 'sql-relational-exp - :operator 'or :sub-expressions rest)) - -(defsql sql-in (:symbol "in") (&rest rest) - (make-instance 'sql-relational-exp - :operator 'in :sub-expressions rest)) - -(defsql sql-|| (:symbol "||") (&rest rest) - (make-instance 'sql-relational-exp - :operator '|| :sub-expressions rest)) - -(defsql sql-is (:symbol "is") (&rest rest) - (make-instance 'sql-relational-exp - :operator 'is :sub-expressions rest)) - -(defsql sql-= (:symbol "=") (&rest rest) - (make-instance 'sql-relational-exp - :operator '= :sub-expressions rest)) - -(defsql sql-== (:symbol "==") (&rest rest) - (make-instance 'sql-assignment-exp - :operator '= :sub-expressions rest)) - -(defsql sql-< (:symbol "<") (&rest rest) - (make-instance 'sql-relational-exp - :operator '< :sub-expressions rest)) - - -(defsql sql-> (:symbol ">") (&rest rest) - (make-instance 'sql-relational-exp - :operator '> :sub-expressions rest)) - -(defsql sql-<> (:symbol "<>") (&rest rest) - (make-instance 'sql-relational-exp - :operator '<> :sub-expressions rest)) - -(defsql sql->= (:symbol ">=") (&rest rest) - (make-instance 'sql-relational-exp - :operator '>= :sub-expressions rest)) - -(defsql sql-<= (:symbol "<=") (&rest rest) - (make-instance 'sql-relational-exp - :operator '<= :sub-expressions rest)) - -(defsql sql-count (:symbol "count") (&rest rest) - (make-instance 'sql-function-exp - :name 'count :args rest)) - -(defsql sql-max (:symbol "max") (&rest rest) - (make-instance 'sql-function-exp - :name 'max :args rest)) - -(defsql sql-min (:symbol "min") (&rest rest) - (make-instance 'sql-function-exp - :name 'min :args rest)) - -(defsql sql-avg (:symbol "avg") (&rest rest) - (make-instance 'sql-function-exp - :name 'avg :args rest)) - -(defsql sql-sum (:symbol "sum") (&rest rest) - (make-instance 'sql-function-exp - :name 'sum :args rest)) - -(defsql sql-the (:symbol "the") (&rest rest) - (make-instance 'sql-typecast-exp - :modifier (first rest) :components (second rest))) - -(defsql sql-function (:symbol "function") (&rest args) - (make-instance 'sql-function-exp - :name (make-symbol (car args)) :args (cdr args))) - -;;(defsql sql-distinct (:symbol "distinct") (&rest rest) -;; nil) - -;;(defsql sql-between (:symbol "between") (&rest rest) -;; nil) - diff --git a/usql/package.lisp b/usql/package.lisp deleted file mode 100644 index 39f16a9..0000000 --- a/usql/package.lisp +++ /dev/null @@ -1,433 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: package.lisp -;;;; Author: Marcus Pearce , Kevin Rosenberg -;;;; Created: 30/03/2004 -;;;; Updated: <04/04/2004 12:21:50 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; Package definitions for CLSQL-USQL. -;;;; -;;;; ====================================================================== - -(in-package #:cl-user) - -(eval-when (:compile-toplevel :load-toplevel :execute) - -#+sbcl - (if (find-package 'sb-mop) - (pushnew :usql-sbcl-mop cl:*features*) - (pushnew :usql-sbcl-pcl cl:*features*)) - - #+cmu - (if (eq (symbol-package 'pcl:find-class) - (find-package 'common-lisp)) - (pushnew :usql-cmucl-mop cl:*features*) - (pushnew :usql-cmucl-pcl cl:*features*))) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage #:clsql-usql-sys - (:nicknames #:usql-sys) - (:use #:common-lisp #:clsql-base-sys - #+usql-sbcl-mop #:sb-mop - #+usql-cmucl-mop #:mop - #+allegro #:mop - #+lispworks #:clos - #+scl #:clos - #+openmcl #:openmcl-mop) - - #+allegro - (:shadowing-import-from - #:excl) - #+lispworks - (:shadowing-import-from - #:clos) - #+usql-sbcl-mop - (:shadowing-import-from - #:sb-pcl - #:generic-function-lambda-list) - #+usql-sbcl-pcl - (:shadowing-import-from - #:sb-pcl - #:name - #:class-direct-slots - #:class-of #:class-name #:class-slots #:find-class - #:slot-boundp - #:standard-class - #:slot-definition-name #:finalize-inheritance - #:standard-direct-slot-definition - #:standard-effective-slot-definition #:validate-superclass - #:direct-slot-definition-class #:compute-effective-slot-definition - #:effective-slot-definition-class - #:slot-value-using-class - #:class-prototype #:generic-function-method-class #:intern-eql-specializer - #:make-method-lambda #:generic-function-lambda-list - #:class-precedence-list #:slot-definition-type - #:class-direct-superclasses) - #+usql-cmucl-mop - (:shadowing-import-from - #:pcl - #:generic-function-lambda-list) - #+usql-cmucl-pcl - (:shadowing-import-from - #:pcl - #:class-direct-slots - #:name - #:class-of #:class-name #:class-slots #:find-class #:standard-class - #:slot-boundp - #:slot-definition-name #:finalize-inheritance - #:standard-direct-slot-definition #:standard-effective-slot-definition - #:validate-superclass #:direct-slot-definition-class - #:effective-slot-definition-class - #:compute-effective-slot-definition - #:slot-value-using-class - #:class-prototype #:generic-function-method-class #:intern-eql-specializer - #:make-method-lambda #:generic-function-lambda-list - #:class-precedence-list #:slot-definition-type - #:class-direct-superclasses) - #+scl - (:shadowing-import-from - #:clos - #:class-prototype ;; note: make-method-lambda is not fbound - ) - - (:import-from - #:clsql-base-sys - . - #1=( - ;; conditions - :clsql-condition - :clsql-error - :clsql-simple-error - :clsql-warning - :clsql-simple-warning - :clsql-invalid-spec-error - :clsql-invalid-spec-error-connection-spec - :clsql-invalid-spec-error-database-type - :clsql-invalid-spec-error-template - :clsql-connect-error - :clsql-connect-error-database-type - :clsql-connect-error-connection-spec - :clsql-connect-error-errno - :clsql-connect-error-error - :clsql-sql-error - :clsql-sql-error-database - :clsql-sql-error-expression - :clsql-sql-error-errno - :clsql-sql-error-error - :clsql-database-warning - :clsql-database-warning-database - :clsql-database-warning-message - :clsql-exists-condition - :clsql-exists-condition-new-db - :clsql-exists-condition-old-db - :clsql-exists-warning - :clsql-exists-error - :clsql-closed-error - :clsql-closed-error-database - :clsql-type-error - :clsql-sql-syntax-error - - ;; db-interface - :check-connection-spec - :database-initialize-database-type - :database-type-load-foreign - :database-name-from-spec - :database-create-sequence - :database-drop-sequence - :database-sequence-next - :database-set-sequence-position - :database-query-result-set - :database-dump-result-set - :database-store-next-row - :database-get-type-specifier - :database-list-tables - :database-list-views - :database-list-indexes - :database-list-sequences - :database-list-attributes - :database-attribute-type - :database-add-attribute - :database-type - ;; initialize - :*loaded-database-types* - :reload-database-types - :*default-database-type* - :*initialized-database-types* - :initialize-database-type - ;; classes - :database - :closed-database - :database-name - :command-recording-stream - :result-recording-stream - :database-view-classes - :database-schema - :conn-pool - :print-object - ;; utils - :sql-escape - - ;; database.lisp -- Connection - #:*default-database-type* ; clsql-base xx - #:*default-database* ; classes xx - #:connect ; database xx - #:*connect-if-exists* ; database xx - #:connected-databases ; database xx - #:database ; database xx - #:database-name ; database xx - #:disconnect ; database xx - #:reconnect ; database - #:find-database ; database xx - #:status ; database xx - #:with-database - #:with-default-database - - ;; basic-sql.lisp - #:query - #:execute-command - #:write-large-object - #:read-large-object - #:delete-large-object - #:do-query - #:map-query - - ;; recording.lisp -- SQL I/O Recording - #:record-sql-comand - #: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 - - ;; 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 - )) - (:export - ;; "Private" exports for use by interface packages - :check-connection-spec - :database-initialize-database-type - :database-type-load-foreign - :database-name-from-spec - :database-connect - :database-query - :database-execute-command - :database-create-sequence - :database-drop-sequence - :database-sequence-next - :database-set-sequence-position - :database-query-result-set - :database-dump-result-set - :database-store-next-row - :database-get-type-specifier - :database-list-tables - :database-table-exists-p - :database-list-views - :database-view-exists-p - :database-list-indexes - :database-index-exists-p - :database-list-sequences - :database-sequence-exists-p - :database-list-attributes - :database-attribute-type - - . - ;; Shared exports for re-export by USQL. - ;; I = Implemented, D = Documented - ;; name file ID - ;;==================================================== - #2=(;;------------------------------------------------ - ;; 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 - :loop ; loop-ext x - ;;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 - :create-view ; table xx - :drop-view ; table xx - :create-index ; table xx - :drop-index ; table xx - ;;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 ; - :update-object-joins ; - :*default-update-objects-max-len* ; - :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 - - ;;------------------------------------------------ - ;; Miscellaneous Extensions - ;;------------------------------------------------ - ;;Initialization - :*loaded-database-types* ; clsql-base xx - :reload-database-types ; clsql-base xx - :closed-database ; database xx - :database-type ; database x - :in-schema ; classes x - ;;FDDL - :list-views ; table xx - :view-exists-p ; table xx - :list-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 - :create-sequence-from-class ; objects x - :drop-sequence-from-class ; objects x - ;;OODML - :add-to-relation ; objects x - :remove-from-relation ; objects x - :read-sql-value ; objects x - :database-output-sql-as-type ; objects x - :database-get-type-specifier ; objects x - :database-output-sql ; sql/class xx - - ;;----------------------------------------------- - ;; Symbolic Sql Syntax - ;;----------------------------------------------- - :sql-and-qualifier - :sql-escape - :sql-query - :sql-any - :sql-all - :sql-not - :sql-union - :sql-intersection - :sql-minus - :sql-group-by - :sql-having - :sql-null - :sql-not-null - :sql-exists - :sql-* - :sql-+ - :sql-/ - :sql-like - :sql-uplike - :sql-and - :sql-or - :sql-in - :sql-|| - :sql-is - :sql-= - :sql-== - :sql-< - :sql-> - :sql->= - :sql-<= - :sql-count - :sql-max - :sql-min - :sql-avg - :sql-sum - :sql-view-class - :sql_slot-value - - . - #1# - )) - (:documentation "This is the INTERNAL SQL-Interface package of USQL.")) - - -;; see http://thread.gmane.org/gmane.lisp.lispworks.general/681 -#+lispworks -(setf *packages-for-warn-on-redefinition* - (delete "SQL" *packages-for-warn-on-redefinition* :test 'string=)) - -(defpackage #:clsql-usql - (:nicknames #:usql #:sql) - (:use :common-lisp) - (:import-from :clsql-usql-sys . #2#) - (:export . #2#) - (:documentation "This is the SQL-Interface package of USQL.")) - - ;; This is from USQL's pcl-patch - #+(or usql-sbcl-pcl usql-cmucl-pcl) - (progn - ;; Note that this will no longer required for cmucl as of version 19a. - (in-package #+cmu :pcl #+sbcl :sb-pcl) - (defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars) - &body body) - `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) - ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars) - ,@body)))) - - - #+sbcl - (if (find-package 'sb-mop) - (setq cl:*features* (delete :usql-sbcl-mop cl:*features*)) - (setq cl:*features* (delete :usql-sbcl-pcl cl:*features*))) - - #+cmu - (if (find-package 'mop) - (setq cl:*features* (delete :usql-cmucl-mop cl:*features*)) - (setq cl:*features* (delete :usql-cmucl-pcl cl:*features*))) - -);eval-when - - diff --git a/usql/sql.lisp b/usql/sql.lisp deleted file mode 100644 index b5c7284..0000000 --- a/usql/sql.lisp +++ /dev/null @@ -1,242 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: sql.lisp -;;;; Updated: <04/04/2004 12:05:32 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; The CLSQL-USQL Functional Data Manipulation Language (FDML). -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-sys) - - -;;; Basic operations on databases - - -(defmethod database-query-result-set ((expr %sql-expression) database - &key full-set types) - (database-query-result-set (sql-output expr database) database - :full-set full-set :types types)) - -(defmethod execute-command ((expr %sql-expression) - &key (database *default-database*)) - (execute-command (sql-output expr database) :database database) - (values)) - - - -(defmethod query ((expr %sql-expression) &key (database *default-database*) - (result-types nil) (flatp nil)) - (query (sql-output expr database) :database database :flatp flatp - :result-types result-types)) - -(defun print-query (query-exp &key titles (formats t) (sizes t) (stream t) - (database *default-database*)) - "The PRINT-QUERY function takes a symbolic SQL query expression and -formatting information and prints onto STREAM a table containing the -results of the query. A list of strings to use as column headings is -given by TITLES, which has a default value of NIL. The FORMATS -argument is a list of format strings used to print each attribute, and -has a default value of T, which means that ~A or ~VA are used if sizes -are provided or computed. The field sizes are given by SIZES. It has a -default value of T, which specifies that minimum sizes are -computed. The output stream is given by STREAM, which has a default -value of T. This specifies that *STANDARD-OUTPUT* is used." - (flet ((compute-sizes (data) - (mapcar #'(lambda (x) (apply #'max (mapcar #'length x))) - (apply #'mapcar (cons #'list data)))) - (format-record (record control sizes) - (format stream "~&~?" control - (if (null sizes) record - (mapcan #'(lambda (s f) (list s f)) sizes record))))) - (let* ((query-exp (etypecase query-exp - (string query-exp) - (sql-query (sql-output query-exp)))) - (data (query query-exp :database database)) - (sizes (if (or (null sizes) (listp sizes)) sizes - (compute-sizes (if titles (cons titles data) data)))) - (formats (if (or (null formats) (not (listp formats))) - (make-list (length (car data)) :initial-element - (if (null sizes) "~A " "~VA ")) - formats)) - (control-string (format nil "~{~A~}" formats))) - (when titles (format-record titles control-string sizes)) - (dolist (d data (values)) (format-record d control-string sizes))))) - -(defun insert-records (&key (into nil) - (attributes nil) - (values nil) - (av-pairs nil) - (query nil) - (database *default-database*)) - "Inserts a set of values into a table. The records created contain -values for attributes (or av-pairs). The argument VALUES is a list of -values. If ATTRIBUTES is supplied then VALUES must be a corresponding -list of values for each of the listed attribute names. If AV-PAIRS is -non-nil, then both ATTRIBUTES and VALUES must be nil. If QUERY is -non-nil, then neither VALUES nor AV-PAIRS should be. QUERY should be a -query expression, and the attribute names in it must also exist in the -table INTO. The default value of DATABASE is *DEFAULT-DATABASE*." - (let ((stmt (make-sql-insert :into into :attrs attributes - :vals values :av-pairs av-pairs - :subquery query))) - (execute-command stmt :database database))) - -(defun make-sql-insert (&key (into nil) - (attrs nil) - (vals nil) - (av-pairs nil) - (subquery nil)) - (if (null into) - (error 'clsql-sql-syntax-error :reason ":into keyword not supplied")) - (let ((ins (make-instance 'sql-insert :into into))) - (with-slots (attributes values query) - ins - (cond ((and vals (not attrs) (not query) (not av-pairs)) - (setf values vals)) - ((and vals attrs (not subquery) (not av-pairs)) - (setf attributes attrs) - (setf values vals)) - ((and av-pairs (not vals) (not attrs) (not subquery)) - (setf attributes (mapcar #'car av-pairs)) - (setf values (mapcar #'cadr av-pairs))) - ((and subquery (not vals) (not attrs) (not av-pairs)) - (setf query subquery)) - ((and subquery attrs (not vals) (not av-pairs)) - (setf attributes attrs) - (setf query subquery)) - (t - (error 'clsql-sql-syntax-error - :reason "bad or ambiguous keyword combination."))) - ins))) - -(defun delete-records (&key (from nil) - (where nil) - (database *default-database*)) - "Deletes rows from a database table specified by FROM in which the -WHERE condition is true. The argument DATABASE specifies a database -from which the records are to be removed, and defaults to -*default-database*." - (let ((stmt (make-instance 'sql-delete :from from :where where))) - (execute-command stmt :database database))) - -(defun update-records (table &key - (attributes nil) - (values nil) - (av-pairs nil) - (where nil) - (database *default-database*)) - "Changes the values of existing fields in TABLE with columns -specified by ATTRIBUTES and VALUES (or AV-PAIRS) where the WHERE -condition is true." - (when av-pairs - (setf attributes (mapcar #'car av-pairs) - values (mapcar #'cadr av-pairs))) - (let ((stmt (make-instance 'sql-update :table table - :attributes attributes - :values values - :where where))) - (execute-command stmt :database database))) - - -;; iteration - -;; output-sql - -(defmethod database-output-sql ((str string) database) - (declare (ignore database) - (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3)) - (type (simple-array * (*)) str)) - (let ((len (length str))) - (declare (type fixnum len)) - (cond ((= len 0) - +empty-string+) - ((and (null (position #\' str)) - (null (position #\\ str))) - (concatenate 'string "'" str "'")) - (t - (let ((buf (make-string (+ (* len 2) 2) :initial-element #\'))) - (do* ((i 0 (incf i)) - (j 1 (incf j))) - ((= i len) (subseq buf 0 (1+ j))) - (declare (type integer i j)) - (let ((char (aref str i))) - (cond ((eql char #\') - (setf (aref buf j) #\\) - (incf j) - (setf (aref buf j) #\')) - ((eql char #\\) - (setf (aref buf j) #\\) - (incf j) - (setf (aref buf j) #\\)) - (t - (setf (aref buf j) char)))))))))) - -(let ((keyword-package (symbol-package :foo))) - (defmethod database-output-sql ((sym symbol) database) - (declare (ignore database)) - (if (equal (symbol-package sym) keyword-package) - (concatenate 'string "'" (string sym) "'") - (symbol-name sym)))) - -(defmethod database-output-sql ((tee (eql t)) database) - (declare (ignore database)) - "'Y'") - -(defmethod database-output-sql ((num number) database) - (declare (ignore database)) - (princ-to-string num)) - -(defmethod database-output-sql ((arg list) database) - (if (null arg) - "NULL" - (format nil "(~{~A~^,~})" (mapcar #'(lambda (val) - (sql-output val database)) - arg)))) - -(defmethod database-output-sql ((arg vector) database) - (format nil "~{~A~^,~}" (map 'list #'(lambda (val) - (sql-output val database)) - arg))) - -(defmethod database-output-sql ((self wall-time) database) - (declare (ignore database)) - (db-timestring self)) - -(defmethod database-output-sql (thing database) - (if (or (null thing) - (eq 'null thing)) - "NULL" - (error 'clsql-simple-error - :format-control - "No type conversion to SQL for ~A is defined for DB ~A." - :format-arguments (list (type-of thing) (type-of database))))) - -(defmethod output-sql-hash-key ((arg vector) &optional database) - (list 'vector (map 'list (lambda (arg) - (or (output-sql-hash-key arg database) - (return-from output-sql-hash-key nil))) - arg))) - -(defmethod output-sql (expr &optional (database *default-database*)) - (write-string (database-output-sql expr database) *sql-stream*) - t) - -(defmethod output-sql ((expr list) &optional (database *default-database*)) - (if (null expr) - (write-string +null-string+ *sql-stream*) - (progn - (write-char #\( *sql-stream*) - (do ((item expr (cdr item))) - ((null (cdr item)) - (output-sql (car item) database)) - (output-sql (car item) database) - (write-char #\, *sql-stream*)) - (write-char #\) *sql-stream*))) - t) - - diff --git a/usql/syntax.lisp b/usql/syntax.lisp deleted file mode 100644 index f3f8372..0000000 --- a/usql/syntax.lisp +++ /dev/null @@ -1,168 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: package.lisp -;;;; Updated: <04/04/2004 12:05:16 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; CLSQL-USQL square bracket symbolic query syntax. Functions for -;;;; enabling and disabling the syntax and for building SQL -;;;; expressions using the syntax. -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-sys) - -(defvar *original-reader-enter* nil) - -(defvar *original-reader-exit* nil) - -(defvar *sql-macro-open-char* #\[) - -(defvar *sql-macro-close-char* #\]) - -(defvar *restore-sql-reader-syntax* nil) - - -;; Exported functions for disabling SQL syntax. - -(defmacro disable-sql-reader-syntax () - "Turn off SQL square bracket syntax changing syntax state. Set state -such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax -disabled if it is consequently locally enabled." - '(eval-when (:compile-toplevel :load-toplevel :execute) - (setf *restore-sql-reader-syntax* nil) - (%disable-sql-reader-syntax))) - -(defmacro locally-disable-sql-reader-syntax () - "Turn off SQL square bracket syntax and do not change syntax state." - '(eval-when (:compile-toplevel :load-toplevel :execute) - (%disable-sql-reader-syntax))) - -(defun %disable-sql-reader-syntax () - (when *original-reader-enter* - (set-macro-character *sql-macro-open-char* *original-reader-enter*)) - (setf *original-reader-enter* nil) - (values)) - - -;; Exported functions for enabling SQL syntax. - -(defmacro enable-sql-reader-syntax () - "Turn on SQL square bracket syntax changing syntax state. Set state -such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax enabled -if it is consequently locally disabled." - '(eval-when (:compile-toplevel :load-toplevel :execute) - (setf *restore-sql-reader-syntax* t) - (%enable-sql-reader-syntax))) - -(defmacro locally-enable-sql-reader-syntax () - "Turn on SQL square bracket syntax and do not change syntax state." - '(eval-when (:compile-toplevel :load-toplevel :execute) - (%enable-sql-reader-syntax))) - -(defun %enable-sql-reader-syntax () - (unless *original-reader-enter* - (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*))) - (set-macro-character *sql-macro-open-char* #'sql-reader-open) - (enable-sql-close-syntax) - (values)) - -(defmacro restore-sql-reader-syntax-state () - "Sets the enable/disable square bracket syntax state to reflect the -last call to either DISABLE-SQL-READER-SYNTAX or -ENABLE-SQL-READER-SYNTAX. The default state of the square bracket -syntax is disabled." - '(eval-when (:compile-toplevel :load-toplevel :execute) - (if *restore-sql-reader-syntax* - (%enable-sql-reader-syntax) - (%disable-sql-reader-syntax)))) - -(defun sql-reader-open (stream char) - (declare (ignore char)) - (let ((sqllist (read-delimited-list #\] stream t))) - (if (sql-operator (car sqllist)) - (cons (sql-operator (car sqllist)) (cdr sqllist)) - (apply #'generate-sql-reference sqllist)))) - -;; Internal function that disables the close syntax when leaving sql context. -(defun disable-sql-close-syntax () - (set-macro-character *sql-macro-close-char* *original-reader-exit*) - (setf *original-reader-exit* nil)) - -;; Internal function that enables close syntax when entering SQL context. -(defun enable-sql-close-syntax () - (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*)) - (set-macro-character *sql-macro-close-char* (get-macro-character #\)))) - -(defun generate-sql-reference (&rest arglist) - (cond ((= (length arglist) 1) ; string, table or attribute - (if (stringp (car arglist)) - (sql-expression :string (car arglist)) - (sql-expression :attribute (car arglist)))) - ((<= 2 (length arglist)) - (let ((sqltype (if (keywordp (caddr arglist)) - (caddr arglist) nil)) - (sqlparam (if (keywordp (caddr arglist)) - (caddr arglist)))) - (cond - ((stringp (cadr arglist)) - (sql-expression :table (car arglist) - :alias (cadr arglist) - :type sqltype)) - ((keywordp (cadr arglist)) - (sql-expression :attribute (car arglist) - :type (cadr arglist) - :params sqlparam)) - (t - (sql-expression :attribute (cadr arglist) - :table (car arglist) - :params sqlparam - :type sqltype))))) - (t - (error 'clsql-sql-syntax-error :reason "bad expression syntax")))) - - -;; Exported functions for dealing with SQL syntax - -(defun sql (&rest args) - "Generates SQL from a set of expressions given by ARGS. Each -argument is translated into SQL and then the args are concatenated -with a single space between each pair." - (format nil "~{~A~^ ~}" (mapcar #'sql-output args))) - -(defun sql-expression (&key string table alias attribute type params) - "Generates an SQL expression from the given keywords. Valid -combinations of the arguments are: string; table; table and alias; -table and attribute; table, attribute, and type; table or alias, and -attribute; table or alias, and attribute and type; attribute; and -attribute and type." - (cond - (string - (make-instance 'sql :string string)) - (attribute - (make-instance 'sql-ident-attribute :name attribute - :qualifier (or table alias) - :type type - :params params)) - ((and table (not attribute)) - (make-instance 'sql-ident-table :name table - :table-alias alias)))) - -(defun sql-operator (operation) - "Takes an SQL operator as an argument and returns the Lisp symbol -for the operator." - (typecase operation - (string nil) - (symbol (gethash (string-upcase (symbol-name operation)) - *sql-op-table*)))) - -(defun sql-operation (operation &rest rest) - "Generates an SQL statement from an operator and arguments." - (if (sql-operator operation) - (apply (symbol-function (sql-operator operation)) rest) - (error "~A is not a recognized SQL operator." operation))) - - diff --git a/usql/table.lisp b/usql/table.lisp deleted file mode 100644 index 715cef0..0000000 --- a/usql/table.lisp +++ /dev/null @@ -1,320 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ====================================================================== -;;;; File: table.lisp -;;;; Updated: <04/04/2004 12:05:03 marcusp> -;;;; ====================================================================== -;;;; -;;;; Description ========================================================== -;;;; ====================================================================== -;;;; -;;;; The CLSQL-USQL Functional Data Definition Language (FDDL) -;;;; including functions for schema manipulation. Currently supported -;;;; SQL objects include tables, views, indexes, attributes and -;;;; sequences. -;;;; -;;;; ====================================================================== - -(in-package :clsql-usql-sys) - - -;; Utilities - -(defun database-identifier (name) - (sql-escape (etypecase name - (string - (string-upcase name)) - (sql-ident - (sql-output name)) - (symbol - (sql-output name))))) - - -;; Tables - -(defvar *table-schemas* (make-hash-table :test #'equal) - "Hash of schema name to table lists.") - -(defun create-table (name description &key (database *default-database*) - (constraints nil)) - "Create a table called NAME, in DATABASE which defaults to -*DEFAULT-DATABASE*, containing the attributes in DESCRIPTION which is -a list containing lists of attribute-name and type information pairs." - (let* ((table-name (etypecase name - (symbol (sql-expression :attribute name)) - (string (sql-expression :attribute (make-symbol name))) - (sql-ident name))) - (stmt (make-instance 'sql-create-table - :name table-name - :columns description - :modifiers constraints))) - (pushnew table-name (gethash *default-schema* *table-schemas*) - :test #'equal) - (execute-command stmt :database database))) - -(defun drop-table (name &key (if-does-not-exist :error) - (database *default-database*)) - "Drops table NAME from DATABASE which defaults to -*DEFAULT-DATABASE*. If the table does not exist and IF-DOES-NOT-EXIST -is :ignore then DROP-TABLE returns nil whereas an error is signalled -if IF-DOES-NOT-EXIST is :error." - (let ((table-name (database-identifier name))) - (ecase if-does-not-exist - (:ignore - (unless (table-exists-p table-name :database database) - (return-from drop-table nil))) - (:error - t)) - (let ((expr (concatenate 'string "DROP TABLE " table-name))) - (execute-command expr :database database)))) - -(defun list-tables (&key (owner nil) (database *default-database*)) - "List all tables in DATABASE which defaults to -*DEFAULT-DATABASE*. If OWNER is nil, only user-owned tables are -considered. This is the default. If OWNER is :all , all tables are -considered. If OWNER is a string, this denotes a username and only -tables owned by OWNER are considered. Table names are returned as a -list of strings." - (database-list-tables database :owner owner)) - -(defun table-exists-p (name &key (owner nil) (database *default-database*)) - "Test for existence of an SQL table called NAME in DATABASE which -defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned -tables are considered. This is the default. If OWNER is :all , all -tables are considered. If OWNER is a string, this denotes a username -and only tables owned by OWNER are considered. Table names are -returned as a list of strings." - (when (member (database-identifier name) - (list-tables :owner owner :database database) - :test #'string-equal) - t)) - - -;; Views - -(defvar *view-schemas* (make-hash-table :test #'equal) - "Hash of schema name to view lists.") - -(defun create-view (name &key as column-list (with-check-option nil) - (database *default-database*)) - "Creates a view called NAME using the AS query and the optional -COLUMN-LIST and WITH-CHECK-OPTION. The COLUMN-LIST argument is a list -of columns to add to the view. The WITH-CHECK-OPTION adds 'WITH CHECK -OPTION' to the resulting SQL. The default value of WITH-CHECK-OPTION -is NIL. The default value of DATABASE is *DEFAULT-DATABASE*." - (let* ((view-name (etypecase name - (symbol (sql-expression :attribute name)) - (string (sql-expression :attribute (make-symbol name))) - (sql-ident name))) - (stmt (make-instance 'sql-create-view - :name view-name - :column-list column-list - :query as - :with-check-option with-check-option))) - (pushnew view-name (gethash *default-schema* *view-schemas*) :test #'equal) - (execute-command stmt :database database))) - -(defun drop-view (name &key (if-does-not-exist :error) - (database *default-database*)) - "Deletes view NAME from DATABASE which defaults to -*DEFAULT-DATABASE*. If the view does not exist and IF-DOES-NOT-EXIST -is :ignore then DROP-VIEW returns nil whereas an error is signalled if -IF-DOES-NOT-EXIST is :error." - (let ((view-name (database-identifier name))) - (ecase if-does-not-exist - (:ignore - (unless (view-exists-p view-name :database database) - (return-from drop-view))) - (:error - t)) - (let ((expr (concatenate 'string "DROP VIEW " view-name))) - (execute-command expr :database database)))) - -(defun list-views (&key (owner nil) (database *default-database*)) - "List all views in DATABASE which defaults to *DEFAULT-DATABASE*. If -OWNER is nil, only user-owned views are considered. This is the -default. If OWNER is :all , all views are considered. If OWNER is a -string, this denotes a username and only views owned by OWNER are -considered. View names are returned as a list of strings." - (database-list-views database :owner owner)) - -(defun view-exists-p (name &key (owner nil) (database *default-database*)) - "Test for existence of an SQL view called NAME in DATABASE which -defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned views -are considered. This is the default. If OWNER is :all , all views are -considered. If OWNER is a string, this denotes a username and only -views owned by OWNER are considered. View names are returned as a list -of strings." - (when (member (database-identifier name) - (list-views :owner owner :database database) - :test #'string-equal) - t)) - - -;; Indexes - -(defvar *index-schemas* (make-hash-table :test #'equal) - "Hash of schema name to index lists.") - -(defun create-index (name &key on (unique nil) attributes - (database *default-database*)) - "Creates an index called NAME on the table specified by ON. The -attributes of the table to index are given by ATTRIBUTES. Setting -UNIQUE to T includes UNIQUE in the SQL index command, specifying that -the columns indexed must contain unique values. The default value of -UNIQUE is nil. The default value of DATABASE is *DEFAULT-DATABASE*." - (let* ((index-name (database-identifier name)) - (table-name (database-identifier on)) - (attributes (mapcar #'database-identifier (listify attributes))) - (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})" - (if unique "UNIQUE" "") - index-name table-name attributes))) - (pushnew index-name (gethash *default-schema* *index-schemas*)) - (execute-command stmt :database database))) - -(defun drop-index (name &key (if-does-not-exist :error) - (on nil) - (database *default-database*)) - "Deletes index NAME from table FROM in DATABASE which defaults to -*DEFAULT-DATABASE*. If the index does not exist and IF-DOES-NOT-EXIST -is :ignore then DROP-INDEX returns nil whereas an error is signalled -if IF-DOES-NOT-EXIST is :error. The argument ON allows the optional -specification of a table to drop the index from." - (let ((index-name (database-identifier name))) - (ecase if-does-not-exist - (:ignore - (unless (index-exists-p index-name :database database) - (return-from drop-index))) - (:error t)) - (execute-command (format nil "DROP INDEX ~A~A" index-name - (if (null on) "" - (concatenate 'string " ON " - (database-identifier on)))) - :database database))) - -(defun list-indexes (&key (owner nil) (database *default-database*)) - "List all indexes in DATABASE, which defaults to -*default-database*. If OWNER is :all , all indexs are considered. If -OWNER is a string, this denotes a username and only indexs owned by -OWNER are considered. Index names are returned as a list of strings." - (database-list-indexes database :owner owner)) - -(defun index-exists-p (name &key (owner nil) (database *default-database*)) - "Test for existence of an index called NAME in DATABASE which -defaults to *DEFAULT-DATABASE*. If OWNER is :all , all indexs are -considered. If OWNER is a string, this denotes a username and only -indexs owned by OWNER are considered. Index names are returned as a -list of strings." - (when (member (database-identifier name) - (list-indexes :owner owner :database database) - :test #'string-equal) - t)) - -;; Attributes - -(defun list-attributes (name &key (owner nil) (database *default-database*)) - "List the attributes of a attribute called NAME in DATABASE which -defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned -attributes are considered. This is the default. If OWNER is :all , all -attributes are considered. If OWNER is a string, this denotes a -username and only attributes owned by OWNER are considered. Attribute -names are returned as a list of strings. Attributes are returned as a -list of strings." - (database-list-attributes (database-identifier name) database :owner owner)) - -(defun attribute-type (attribute table &key (owner nil) - (database *default-database*)) - "Return the field type of the ATTRIBUTE in TABLE. The optional -keyword argument DATABASE specifies the database to query, defaulting -to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned attributes are -considered. This is the default. If OWNER is :all , all attributes are -considered. If OWNER is a string, this denotes a username and only -attributes owned by OWNER are considered. Attribute names are returned -as a list of strings. Attributes are returned as a list of strings." - (database-attribute-type (database-identifier attribute) - (database-identifier table) - database - :owner owner)) - -(defun list-attribute-types (table &key (owner nil) - (database *default-database*)) - "Returns type information for the attributes in TABLE from DATABASE -which has a default value of *default-database*. If OWNER is nil, only -user-owned attributes are considered. This is the default. If OWNER is -:all, all attributes are considered. If OWNER is a string, this -denotes a username and only attributes owned by OWNER are -considered. Returns a list in which each element is a list (attribute -datatype). Attribute is a string denoting the atribute name. Datatype -is the vendor-specific type returned by ATTRIBUTE-TYPE." - (mapcar #'(lambda (type) - (list type (attribute-type type table :database database - :owner owner))) - (list-attributes table :database database :owner owner))) - -;(defun add-attribute (table attribute &key (database *default-database*)) -; (database-add-attribute table attribute database)) - -;(defun rename-attribute (table oldatt newname -; &key (database *default-database*)) -; (error "(rename-attribute ~a ~a ~a ~a) is not implemented" -; table oldatt newname database)) - - -;; Sequences - -(defvar *sequence-schemas* (make-hash-table :test #'equal) - "Hash of schema name to sequence lists.") - -(defun create-sequence (name &key (database *default-database*)) - "Create a sequence called NAME in DATABASE which defaults to -*DEFAULT-DATABASE*." - (let ((sequence-name (database-identifier name))) - (database-create-sequence sequence-name database) - (pushnew sequence-name (gethash *default-schema* *sequence-schemas*) - :test #'equal)) - (values)) - -(defun drop-sequence (name &key (if-does-not-exist :error) - (database *default-database*)) - "Drops sequence NAME from DATABASE which defaults to -*DEFAULT-DATABASE*. If the sequence does not exist and -IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil whereas an -error is signalled if IF-DOES-NOT-EXIST is :error." - (let ((sequence-name (database-identifier name))) - (ecase if-does-not-exist - (:ignore - (unless (sequence-exists-p sequence-name :database database) - (return-from drop-sequence))) - (:error t)) - (database-drop-sequence sequence-name database)) - (values)) - -(defun list-sequences (&key (owner nil) (database *default-database*)) - "List all sequences in DATABASE, which defaults to -*default-database*. If OWNER is nil, only user-owned sequences are -considered. This is the default. If OWNER is :all , all sequences are -considered. If OWNER is a string, this denotes a username and only -sequences owned by OWNER are considered. Sequence names are returned -as a list of strings." - (database-list-sequences database :owner owner)) - -(defun sequence-exists-p (name &key (owner nil) - (database *default-database*)) - "Test for existence of a sequence called NAME in DATABASE which -defaults to *DEFAULT-DATABASE*." - (when (member (database-identifier name) - (list-sequences :owner owner :database database) - :test #'string-equal) - t)) - -(defun sequence-next (name &key (database *default-database*)) - "Return the next value in the sequence NAME in DATABASE." - (database-sequence-next (database-identifier name) database)) - -(defun set-sequence-position (name position &key (database *default-database*)) - "Explicitly set the the position of the sequence NAME in DATABASE to -POSITION." - (database-set-sequence-position (database-identifier name) position database)) - -(defun sequence-last (name &key (database *default-database*)) - "Return the last value of the sequence NAME in DATABASE." - (database-sequence-last (database-identifier name) database)) \ No newline at end of file