------------------
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 <m.t.pearce@city.ac.uk> (initial port of USQL to CLSQL)
Marc Battyani
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; *************************************************************************
+;;;; FILE IDENTIFICATION
+;;;;
+;;;; File: clsql-tests.asd
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: clsql-usql-tests.asd
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: usql.asd
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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))))))
-
--- /dev/null
+;;;; -*- 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))))))
+
--- /dev/null
+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).
+
+
--- /dev/null
+
+(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))
--- /dev/null
+;;;; -*- 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 " "))))))))
+
--- /dev/null
+;;;; -*- 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))
+ )
+
--- /dev/null
+;;;; -*- 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 <db info .... >)?
+
+ (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*))
+ )
--- /dev/null
+;;;; -*- 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))))))))
--- /dev/null
+;;;; -*- 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)
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: package.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>, 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
+
+
--- /dev/null
+;;;; -*- 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)
+
+
--- /dev/null
+;;;; -*- 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)))
+
+
--- /dev/null
+;;;; -*- 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
--- /dev/null
+* 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
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: package.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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."))
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-connection.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-fddl.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-fdml.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-init.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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))
+
+
+
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-ooddl.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-oodml.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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)
--- /dev/null
+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+;;;; ======================================================================
+;;;; File: test-syntax.lisp
+;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
+;;;; 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
+++ /dev/null
-* 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
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: package.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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."))
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: test-connection.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: test-fddl.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: test-fdml.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: test-init.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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))
-
-
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: test-ooddl.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: test-oodml.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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)
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: test-syntax.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>
-;;;; 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
+++ /dev/null
-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).
-
-
+++ /dev/null
-;;;; -*- 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 " "))))))))
-
+++ /dev/null
-;;;; -*- 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))
- )
-
+++ /dev/null
-;;;; -*- 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 <db info .... >)?
-
- (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*))
- )
+++ /dev/null
-;;;; -*- 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))))))))
+++ /dev/null
-;;;; -*- 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)
-
+++ /dev/null
-;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
-;;;; ======================================================================
-;;;; File: package.lisp
-;;;; Author: Marcus Pearce <m.t.pearce@city.ac.uk>, 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
-
-
+++ /dev/null
-;;;; -*- 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)
-
-
+++ /dev/null
-;;;; -*- 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)))
-
-
+++ /dev/null
-;;;; -*- 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
projects / clsql.git / commitdiff