From ce0e343835a040406678dff74a62d1b0cb56f317 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 5 Apr 2004 20:54:27 +0000 Subject: [PATCH] r8821: integrate usql support --- base/basic-sql.lisp | 52 ++ base/classes.lisp | 7 +- base/cmucl-compat.lisp | 12 +- base/conditions.lisp | 12 +- base/database.lisp | 217 ++++++ base/db-interface.lisp | 7 +- base/initialize.lisp | 7 +- {sql => base}/loop-extension.lisp | 0 base/package.lisp | 133 +++- {sql => base}/pool.lisp | 30 +- base/recording.lisp | 147 ++++ base/time.lisp | 1067 +++++++++++++++++++++++++++ base/transaction.lisp | 102 +++ base/utils.lisp | 7 +- clsql-base.asd | 13 +- clsql-usql-tests.asd | 35 + clsql-usql.asd | 54 ++ clsql.asd | 8 +- debian/changelog | 6 + sql/functional.lisp | 18 +- sql/package.lisp | 34 +- sql/sql.lisp | 152 +--- sql/transactions.lisp | 87 --- sql/usql.lisp | 12 +- usql-tests/package.lisp | 28 + usql-tests/test-connection.lisp | 24 + usql-tests/test-fddl.lisp | 211 ++++++ usql-tests/test-fdml.lisp | 395 ++++++++++ usql-tests/test-init.lisp | 310 ++++++++ usql-tests/test-ooddl.lisp | 87 +++ usql-tests/test-oodml.lisp | 241 +++++++ usql-tests/test-syntax.lisp | 162 +++++ usql/CONTRIBUTORS | 22 + usql/COPYING | 84 +++ usql/README | 64 ++ usql/TODO | 101 +++ usql/basic-cmds.lisp | 32 + usql/classes.lisp | 740 +++++++++++++++++++ usql/doc/usql-tests.txt | 110 +++ usql/doc/usql-tutorial.lisp | 190 +++++ usql/doc/usql-tutorial.txt | 509 +++++++++++++ usql/metaclasses.lisp | 495 +++++++++++++ usql/objects.lisp | 1108 +++++++++++++++++++++++++++++ usql/operations.lisp | 201 ++++++ usql/package.lisp | 327 +++++++++ usql/pcl-patch.lisp | 12 + usql/sql.lisp | 355 +++++++++ usql/syntax.lisp | 168 +++++ usql/table.lisp | 320 +++++++++ 49 files changed, 8203 insertions(+), 312 deletions(-) create mode 100644 base/basic-sql.lisp create mode 100644 base/database.lisp rename {sql => base}/loop-extension.lisp (100%) rename {sql => base}/pool.lisp (80%) create mode 100644 base/recording.lisp create mode 100644 base/time.lisp create mode 100644 base/transaction.lisp create mode 100644 clsql-usql-tests.asd create mode 100644 clsql-usql.asd delete mode 100644 sql/transactions.lisp create mode 100644 usql-tests/package.lisp create mode 100644 usql-tests/test-connection.lisp create mode 100644 usql-tests/test-fddl.lisp create mode 100644 usql-tests/test-fdml.lisp create mode 100644 usql-tests/test-init.lisp create mode 100644 usql-tests/test-ooddl.lisp create mode 100644 usql-tests/test-oodml.lisp create mode 100644 usql-tests/test-syntax.lisp create mode 100644 usql/CONTRIBUTORS create mode 100644 usql/COPYING create mode 100644 usql/README create mode 100644 usql/TODO create mode 100644 usql/basic-cmds.lisp create mode 100644 usql/classes.lisp create mode 100644 usql/doc/usql-tests.txt create mode 100644 usql/doc/usql-tutorial.lisp create mode 100644 usql/doc/usql-tutorial.txt create mode 100644 usql/metaclasses.lisp create mode 100644 usql/objects.lisp create mode 100644 usql/operations.lisp create mode 100644 usql/package.lisp create mode 100644 usql/pcl-patch.lisp create mode 100644 usql/sql.lisp create mode 100644 usql/syntax.lisp create mode 100644 usql/table.lisp diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp new file mode 100644 index 0000000..df5d93b --- /dev/null +++ b/base/basic-sql.lisp @@ -0,0 +1,52 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; $Id: $ + +(in-package #:clsql-base-sys) + +;;; Query + +(defgeneric query (query-expression &key database result-types flatp) + (:documentation + "Execute the SQL query expression QUERY-EXPRESSION on the given +DATABASE which defaults to *default-database*. RESULT-TYPES is a list +of symbols such as :string and :integer, one for each field in the +query, which are used to specify the types to return. The FLATP +argument, which has a default value of nil, specifies if full +bracketed results should be returned for each matched entry. If FLATP +is nil, the results are returned as a list of lists. If FLATP is t, +the results are returned as elements of a list, only if there is only +one result per row. Returns a list of lists of values of the result of +that expression and a list of field names selected in sql-exp.")) + +(defmethod query ((query-expression string) &key (database *default-database*) + (result-types nil) (flatp nil)) + (record-sql-command query-expression database) + (let* ((res (database-query query-expression database result-types)) + (res (if (and flatp (= (length + (slot-value query-expression 'selections)) + 1)) + (mapcar #'car res) + res))) + (record-sql-result res database) + res)) + +;;; Execute + +(defgeneric execute-command (expression &key database) + (:documentation + "Executes the SQL command specified by EXPRESSION for the database +specified by DATABASE, which has a default value of +*DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement +other than a query. To run a stored procedure, pass an appropriate +string. The call to the procedure needs to be wrapped in a BEGIN END +pair.")) + +(defmethod execute-command ((sql-expression string) + &key (database *default-database*)) + (record-sql-command sql-expression database) + (let ((res (database-execute-command sql-expression database))) + (record-sql-result res database)) + (values)) + + diff --git a/base/classes.lisp b/base/classes.lisp index 26655d8..f7a700e 100644 --- a/base/classes.lisp +++ b/base/classes.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: classes.cl +;;;; Name: classes.lisp ;;;; Purpose: Classes for High-level SQL interface ;;;; Programmers: Kevin M. Rosenberg based on ;;;; original code by Pierre R. Mai @@ -10,7 +10,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -18,8 +18,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-sys) +(in-package #:clsql-base-sys) (defclass database () diff --git a/base/cmucl-compat.lisp b/base/cmucl-compat.lisp index 61b9ad0..d285788 100644 --- a/base/cmucl-compat.lisp +++ b/base/cmucl-compat.lisp @@ -2,23 +2,23 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: cmucl-compat.sql +;;;; Name: cmucl-compat.lisp ;;;; Purpose: Compatiblity library for CMUCL functions ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; ;;;; 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) +(in-package #:cl-user) -(defpackage :cmucl-compat +(defpackage #:cmucl-compat (:use #:common-lisp) (:export #:shrink-vector @@ -26,7 +26,7 @@ #:result-type-or-lose #:required-argument )) -(in-package :cmucl-compat) +(in-package #:cmucl-compat) #+(or cmu scl) (defmacro required-argument () @@ -79,7 +79,7 @@ Needs to be a macro to overwrite value of VEC." (defun make-sequence-of-type (type len) (lisp::make-sequence-of-type type len)) (defun make-sequence-of-type (type len) - (system::make-sequence-of-type type len))) + (common-lisp::make-sequence-of-type type len))) #-(or cmu scl) (defun result-type-or-lose (type nil-ok) diff --git a/base/conditions.lisp b/base/conditions.lisp index 7fc7781..138aa58 100644 --- a/base/conditions.lisp +++ b/base/conditions.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: conditions.cl +;;;; Name: conditions.lisp ;;;; Purpose: Error conditions for high-level SQL interface ;;;; Programmers: Kevin M. Rosenberg based on ;;;; Original code by Pierre R. Mai @@ -10,7 +10,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -18,8 +18,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-sys) +(in-package #:clsql-base-sys) ;;; Conditions (define-condition clsql-condition () @@ -157,6 +156,9 @@ and signal an clsql-invalid-spec-error if they don't match." 'clsql-nodb-error :database database)) +(defun signal-no-database-error () + (cerror "Ignore this error and return nil." + 'clsql-nodb-error)) ;; for USQL support @@ -179,4 +181,4 @@ and signal an clsql-invalid-spec-error if they don't match." :reader clsql-sql-syntax-error-reason)) (:report (lambda (c stream) (format stream "Invalid SQL syntax: ~A" - (clsql-sql-syntax-error-reason c))))) \ No newline at end of file + (clsql-sql-syntax-error-reason c))))) diff --git a/base/database.lisp b/base/database.lisp new file mode 100644 index 0000000..839204f --- /dev/null +++ b/base/database.lisp @@ -0,0 +1,217 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id: $ + +(in-package #:clsql-base-sys) + +(setf (documentation 'database-name 'function) + "Returns the name of a database.") + +;;; Database handling + +(defvar *connect-if-exists* :error + "Default value for the if-exists parameter of connect calls.") + +(defvar *connected-databases* nil + "List of active database objects.") + +(defun connected-databases () + "Return the list of active database objects." + *connected-databases*) + +(defvar *default-database* nil + "Specifies the default database to be used.") + +;;; usql +(defun find-database (database &key (errorp t) (db-type nil)) + "The function FIND-DATABASE, given a string DATABASE, searches +amongst the connected databases for one matching the name DATABASE. If +there is exactly one such database, it is returned and the second +return value count is 1. If more than one databases match and ERRORP +is nil, then the most recently connected of the matching databases is +returned and count is the number of matches. If no matching database +is found and ERRORP is nil, then nil is returned. If none, or more +than one, matching databases are found and ERRORP is true, then an +error is signalled. If the argument database is a database, it is +simply returned." + (etypecase database + (database + (values database 1)) + (string + (let* ((matches (remove-if + #'(lambda (db) + (not (and (string= (database-name db) database) + (if db-type + (equal (database-type db) db-type) + t)))) + (connected-databases))) + (count (length matches))) + (if (or (not errorp) (= count 1)) + (values (car matches) count) + (cerror "Return nil." + 'clsql-simple-error + :format-control "There exists ~A database called ~A." + :format-arguments + (list (if (zerop count) "no" "more than one") + database))))))) + + +(defun connect (connection-spec + &key (if-exists *connect-if-exists*) + (make-default t) + (pool nil) + (database-type *default-database-type*)) + "Connects to a database of the given database-type, using the +type-specific connection-spec. The value of if-exists determines what +happens if a connection to that database is already established. A +value of :new means create a new connection. A value of :warn-new +means warn the user and create a new connect. A value of :warn-old +means warn the user and use the old connection. A value of :error +means fail, notifying the user. A value of :old means return the old +connection. If make-default is true, then *default-database* is set +to the new connection, otherwise *default-database is not changed. If +pool is t the connection will be taken from the general pool, if pool +is a conn-pool object the connection will be taken from this pool." + (if pool + (acquire-from-pool connection-spec database-type pool) + (let* ((db-name (database-name-from-spec connection-spec database-type)) + (old-db (unless (eq if-exists :new) + (find-database db-name :db-type database-type + :errorp nil))) + (result nil)) + (if old-db + (ecase if-exists + (:warn-new + (setq result + (database-connect connection-spec database-type)) + (warn 'clsql-exists-warning :old-db old-db :new-db result)) + (:error + (restart-case + (error 'clsql-exists-error :old-db old-db) + (create-new () + :report "Create a new connection." + (setq result + (database-connect connection-spec database-type))) + (use-old () + :report "Use the existing connection." + (setq result old-db)))) + (:warn-old + (setq result old-db) + (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) + (:old + (setq result old-db))) + (setq result + (database-connect connection-spec database-type))) + (when result + (pushnew result *connected-databases*) + (when make-default (setq *default-database* result)) + result)))) + + +(defun disconnect (&key (database *default-database*) (error nil)) + + "Closes the connection to DATABASE and resets *default-database* if +that database was disconnected. If database is a database object, then +it is used directly. Otherwise, the list of connected databases is +searched to find one with DATABASE as its connection +specifications. If no such database is found, then if ERROR and +DATABASE are both non-nil an error is signaled, otherwise DISCONNECT +returns nil. If the database is from a pool it will be released to +this pool." + (let ((database (find-database database :errorp (and database error)))) + (when database + (if (conn-pool database) + (when (release-to-pool database) + (setf *connected-databases* (delete database *connected-databases*)) + (when (eq database *default-database*) + (setf *default-database* (car *connected-databases*))) + t) + (when (database-disconnect database) + (setf *connected-databases* (delete database *connected-databases*)) + (when (eq database *default-database*) + (setf *default-database* (car *connected-databases*))) + (change-class database 'closed-database) + t))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + + +(defun reconnect (&key (database *default-database*) (error nil) (force t)) + "Reconnects DATABASE to its underlying RDBMS. If successful, returns +t and the variable *default-database* is set to the newly reconnected +database. The default value for DATABASE is *default-database*. If +DATABASE is a database object, then it is used directly. Otherwise, +the list of connected databases is searched to find one with database +as its connection specifications (see CONNECT). If no such database is +found, then if ERROR and DATABASE are both non-nil an error is +signaled, otherwise RECONNECT returns nil. FORCE controls whether an +error should be signaled if the existing database connection cannot be +closed. When non-nil (this is the default value) the connection is +closed without error checking. When FORCE is nil, an error is signaled +if the database connection has been lost." + ;; TODO: just a placeholder + (declare (ignore database error force))) + + + +(defun status (&optional full) + "The function STATUS prints status information to the standard +output, for the connected databases and initialized database types. If +full is T, detailed status information is printed. The default value +of full is NIL." + (declare (ignore full)) + ;; TODO: table details if full is true? + (flet ((get-data () + (let ((data '())) + (dolist (db (connected-databases) data) + (push (list (database-name db) + (string (database-type db)) + (when (conn-pool db) "T" "NIL") + (format nil "~A" (length (database-list-tables db))) + (format nil "~A" (length (database-list-views db))) + (if (equal db *default-database*) " *" "")) + data)))) + (compute-sizes (data) + (mapcar #'(lambda (x) (apply #'max (mapcar #'length x))) + (apply #'mapcar (cons #'list data)))) + (print-separator (size) + (format t "~&~A" (make-string size :initial-element #\-)))) + (let ((data (get-data))) + (when data + (let* ((titles (list "NAME" "TYPE" "POOLED" "TABLES" "VIEWS" "DEFAULT")) + (sizes (compute-sizes (cons titles data))) + (total-size (+ (apply #'+ sizes) (* 2 (1- (length titles))))) + (control-string (format nil "~~&~~{~{~~~AA ~}~~}" sizes))) + (print-separator total-size) + (format t control-string titles) + (print-separator total-size) + (dolist (d data) (format t control-string d)) + (print-separator total-size)))) + (values))) + + +(defmacro with-database ((db-var connection-spec &rest connect-args) &body body) + "Evaluate the body in an environment, where `db-var' is bound to the +database connection given by `connection-spec' and `connect-args'. +The connection is automatically closed or released to the pool on exit from the body." + (let ((result (gensym "result-"))) + (unless db-var (setf db-var '*default-database*)) + `(let ((,db-var (connect ,connection-spec ,@connect-args)) + (,result nil)) + (unwind-protect + (let ((,db-var ,db-var)) + (setf ,result (progn ,@body))) + (disconnect :database ,db-var)) + ,result))) + + +(defmacro with-default-database ((database) &rest body) + "Perform BODY with DATABASE bound as *default-database*." + `(progv '(*default-database*) + (list ,database) + ,@body)) diff --git a/base/db-interface.lisp b/base/db-interface.lisp index a27a958..93e3973 100644 --- a/base/db-interface.lisp +++ b/base/db-interface.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: db-interface.cl +;;;; Name: db-interface.lisp ;;;; Purpose: Generic function definitions for DB interfaces ;;;; Programmers: Kevin M. Rosenberg based on ;;;; Original code by Pierre R. Mai. Additions from @@ -11,7 +11,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai, and onShoreD ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -19,8 +19,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-sys) +(in-package #:clsql-base-sys) (defgeneric database-type-load-foreign (database-type) (:documentation diff --git a/base/initialize.lisp b/base/initialize.lisp index 8e98d5e..1d96a8f 100644 --- a/base/initialize.lisp +++ b/base/initialize.lisp @@ -2,14 +2,14 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: initialize.cl +;;;; Name: initialize.lisp ;;;; Purpose: Initializion routines for backend ;;;; Programmers: Kevin M. Rosenberg ;;;; Date Started: May 2002 ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -17,8 +17,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-sys) +(in-package #:clsql-base-sys) (defvar *loaded-database-types* nil "Contains a list of database types which have been defined/loaded.") diff --git a/sql/loop-extension.lisp b/base/loop-extension.lisp similarity index 100% rename from sql/loop-extension.lisp rename to base/loop-extension.lisp diff --git a/base/package.lisp b/base/package.lisp index ea9f936..f819759 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: package.cl +;;;; Name: package.lisp ;;;; Purpose: Package definition for base (low-level) SQL interface ;;;; Programmers: Kevin M. Rosenberg based on ;;;; Original code by Pierre R. Mai @@ -10,7 +10,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -119,15 +119,140 @@ #:transaction-level #:conn-pool - ;; utils.cl + ;; utils.lisp #:number-to-sql-string #:float-to-sql-string #:sql-escape-quotes + + ;; time.lisp + #:bad-component + #:current-day + #:current-month + #:current-year + #:day-duration + #:db-timestring + #:decode-duration + #:decode-time + #:duration + #:duration+ + #:duration< + #:duration<= + #:duration= + #:duration> + #:duration>= + #:duration-day + #:duration-hour + #:duration-minute + #:duration-month + #:duration-second + #:duration-year + #:duration-reduce + #:format-duration + #:format-time + #:get-time + #:interval-clear + #:interval-contained + #:interval-data + #:interval-edit + #:interval-end + #:interval-match + #:interval-push + #:interval-relation + #:interval-start + #:interval-type + #:make-duration + #:make-interval + #:make-time + #:merged-time + #:midnight + #:month-name + #:parse-date-time + #:parse-timestring + #:print-date + #:roll + #:roll-to + #:time + #:time+ + #:time- + #:time-by-adding-duration + #:time-compare + #:time-difference + #:time-dow + #:time-element + #:time-max + #:time-min + #:time-mjd + #:time-msec + #:time-p + #:time-sec + #:time-well-formed + #:time-ymd + #:time< + #:time<= + #:time= + #:time> + #:time>= + #:timezone + #:universal-time + #:wall-time + #:wall-timestring + #:week-containing + + ;; 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 + + ;; 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 + + ;; Transactions + #:with-transaction + #:commit-transaction + #:rollback-transaction + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + #:commit ; transact xx + #:rollback ; transact xx + #:with-transaction ; transact xx . + #:start-transaction ; transact xx + #:in-transaction-p ; transact xx + #:database-start-transaction + #:database-abort-transaction + #:database-commit-transaction + #:transaction-level + #:transaction + )) (:documentation "This is the INTERNAL SQL-Interface package of CLSQL-BASE.")) (defpackage #:clsql-base - (:import-from :clsql-base-sys . #1#) + (:import-from #:clsql-base-sys . #1#) (:export . #1#) (:documentation "This is the SQL-Interface package of CLSQL-BASE.")) );eval-when diff --git a/sql/pool.lisp b/base/pool.lisp similarity index 80% rename from sql/pool.lisp rename to base/pool.lisp index f58e752..2a9f91b 100644 --- a/sql/pool.lisp +++ b/base/pool.lisp @@ -7,7 +7,7 @@ ;;;; Programmers: Kevin M. Rosenberg, Marc Battyani ;;;; Date Started: Apr 2002 ;;;; -;;;; $Id$ +;;;; $Id: pool.lisp 7061 2003-09-07 06:34:45Z kevin $ ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 by Kevin M. Rosenberg ;;;; @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package clsql-sys) +(in-package #:clsql-base-sys) (defun make-process-lock (name) #+allegro (mp:make-process-lock :name name) @@ -77,7 +77,8 @@ nil) (defun find-or-create-connection-pool (connection-spec database-type) - "Find connection pool in hash table, creates a new connection pool if not found" + "Find connection pool in hash table, creates a new connection pool +if not found" (with-process-lock (*db-pool-lock* "Find-or-create connection") (let* ((key (list connection-spec database-type)) (conn-pool (gethash key *db-pool*))) @@ -97,7 +98,7 @@ (release-to-conn-pool database)) (defun disconnect-pooled (&optional clear) - "Disconnects all connections in the pool" + "Disconnects all connections in the pool." (with-process-lock (*db-pool-lock* "Disconnect pooled") (maphash #'(lambda (key conn-pool) @@ -106,3 +107,24 @@ *db-pool*) (when clear (clrhash *db-pool*))) t) + +;(defun pool-start-sql-recording (pool &key (types :command)) +; "Start all stream in the pool recording actions of TYPES" +; (dolist (con (pool-connections pool)) +; (start-sql-recording :type types +; :database (connection-database con)))) + +;(defun pool-stop-sql-recording (pool &key (types :command)) +; "Start all stream in the pool recording actions of TYPES" +; (dolist (con (pool-connections pool)) +; (stop-sql-recording :type types +; :database (connection-database con)))) + +;(defmacro with-database-connection (pool &body body) +; `(let ((connection (obtain-connection ,pool)) +; (results nil)) +; (unwind-protect +; (with-database ((connection-database connection)) +; (setq results (multiple-value-list (progn ,@body)))) +; (release-connection connection)) +; (values-list results))) diff --git a/base/recording.lisp b/base/recording.lisp new file mode 100644 index 0000000..b7565f9 --- /dev/null +++ b/base/recording.lisp @@ -0,0 +1,147 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; $Id: $ +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; CLSQL-USQL broadcast streams which can be used to monitor the +;;;; flow of commands to, and results from, a database. +;;;; +;;;; ====================================================================== + +(in-package #:clsql-base-sys) + +(defun start-sql-recording (&key (type :commands) (database *default-database*)) + "Begin recording SQL command or result traffic. By default the +broadcast stream is just *STANDARD-OUTPUT* but this can be modified +using ADD-SQL-STREAM or DELETE-SQL-STREAM. TYPE determines whether SQL +command or result traffic is recorded, or both. It must be either +:commands, :results or :both, and defaults to :commands. DATABASE +defaults to *default-database*." + (when (or (eq type :both) (eq type :commands)) + (setf (command-recording-stream database) + (make-broadcast-stream *standard-output*))) + (when (or (eq type :both) (eq type :results)) + (setf (result-recording-stream database) + (make-broadcast-stream *standard-output*))) + (values)) + +(defun stop-sql-recording (&key (type :commands) (database *default-database*)) + "Stops recording of SQL command or result traffic. TYPE determines +whether to stop SQL command or result traffic, or both. It must be +either :commands, :results or :both, defaulting to :commands. DATABASE +defaults to *default-database*." + (when (or (eq type :both) (eq type :commands)) + (setf (command-recording-stream database) nil)) + (when (or (eq type :both) (eq type :results)) + (setf (result-recording-stream database) nil)) + (values)) + +(defun sql-recording-p (&key (type :commands) (database *default-database*)) + "Returns t if recording of TYPE of SQL interaction specified is +enabled. TYPE must be either :commands, :results, :both or :either. +DATABASE defaults to *default-database*." + (when (or (and (eq type :commands) + (command-recording-stream database)) + (and (eq type :results) + (result-recording-stream database)) + (and (eq type :both) + (result-recording-stream database) + (command-recording-stream database)) + (and (eq type :either) + (or (result-recording-stream database) + (command-recording-stream database)))) + t)) + +(defun add-sql-stream (stream &key (type :commands) + (database *default-database*)) + "Add the given STREAM as a component stream for the recording +broadcast stream for the given SQL interaction TYPE. TYPE must be +either :commands, :results, or :both, defaulting to :commands. +DATABASE defaults to *default-database*." + (when (or (eq type :both) (eq type :commands)) + (unless (member stream + (list-sql-streams :type :commands :database database)) + (setf (command-recording-stream database) + (apply #'make-broadcast-stream + (cons stream (list-sql-streams :type :commands + :database database)))))) + (when (or (eq type :both) (eq type :results)) + (unless (member stream (list-sql-streams :type :results :database database)) + (setf (result-recording-stream database) + (apply #'make-broadcast-stream + (cons stream (list-sql-streams :type :results + :database database)))))) + stream) + +(defun delete-sql-stream (stream &key (type :commands) + (database *default-database*)) + "Removes the given STREAM from the recording broadcast stream for +the given TYPE of SQL interaction. TYPE must be either :commands, +:results, or :both, defaulting to :commands. DATABASE defaults to +*default-database*." + (when (or (eq type :both) (eq type :commands)) + (setf (command-recording-stream database) + (apply #'make-broadcast-stream + (remove stream (list-sql-streams :type :commands + :database database))))) + (when (or (eq type :both) (eq type :results)) + (setf (result-recording-stream database) + (apply #'make-broadcast-stream + (remove stream (list-sql-streams :type :results + :database database))))) + stream) + +(defun list-sql-streams (&key (type :commands) (database *default-database*)) + "Returns the set of streams which the recording broadcast stream +send SQL interactions of the given TYPE sends data. TYPE must be +either :commands, :results, or :both, defaulting to :commands. +DATABASE defaults to *default-database*." + (let ((crs (command-recording-stream database)) + (rrs (result-recording-stream database))) + (cond + ((eq type :commands) + (when crs (broadcast-stream-streams crs))) + ((eq type :results) + (when rrs (broadcast-stream-streams rrs))) + ((eq type :both) + (append (when crs (broadcast-stream-streams crs)) + (when rrs (broadcast-stream-streams rrs)))) + (t + (error "Unknown recording type. ~A" type))))) + +(defun sql-stream (&key (type :commands) (database *default-database*)) + "Returns the broadcast streams used for recording SQL commands or +results traffic. TYPE must be either :commands or :results defaulting +to :commands while DATABASE defaults to *default-database*." + (cond + ((eq type :commands) + (command-recording-stream database)) + ((eq type :results) + (result-recording-stream database)) + (t + (error "Unknown recording type. ~A" type)))) + +(defun record-sql-command (expr database) + (if database + (with-slots (command-recording-stream) + database + (if command-recording-stream + (format command-recording-stream "~&;; ~A ~A => ~A~%" + (iso-timestring (get-time)) + (database-name database) + expr))))) + +(defun record-sql-result (res database) + (if database + (with-slots (result-recording-stream) + database + (if result-recording-stream + (format result-recording-stream "~&;; ~A ~A <= ~A~%" + (iso-timestring (get-time)) + (database-name database) + res))))) + + + diff --git a/base/time.lisp b/base/time.lisp new file mode 100644 index 0000000..75034cf --- /dev/null +++ b/base/time.lisp @@ -0,0 +1,1067 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; $Id: $ +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; A variety of structures and function for creating and +;;;; manipulating dates, times, durations and intervals for +;;;; CLSQL-USQL. +;;;; +;;;; This file was originally part of ODCL and is Copyright (c) 2002 - +;;;; 2003 onShore Development, Inc. +;;;; +;;;; ====================================================================== + + +(in-package #:clsql-base-sys) + + +;; ------------------------------------------------------------ +;; Months + +(defvar *month-keywords* + '(:january :february :march :april :may :june :july :august :september + :october :november :december)) + +(defvar *month-names* + '("" "January" "February" "March" "April" "May" "June" "July" "August" + "September" "October" "November" "December")) + +(defun month-name (month-index) + (nth month-index *month-names*)) + +(defun ordinal-month (month-keyword) + "Return the zero-based month number for the given MONTH keyword." + (position month-keyword *month-keywords*)) + + +;; ------------------------------------------------------------ +;; Days + +(defvar *day-keywords* + '(:sunday :monday :tuesday :wednesday :thursday :friday :saturday)) + +(defvar *day-names* + '("Sunday" "Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday")) + +(defun day-name (day-index) + (nth day-index *day-names*)) + +(defun ordinal-day (day-keyword) + "Return the zero-based day number for the given DAY keyword." + (position day-keyword *day-keywords*)) + + +;; ------------------------------------------------------------ +;; time classes: wall-time, duration + +(eval-when (:compile-toplevel :load-toplevel) + +(defstruct (wall-time (:conc-name time-) + (:constructor %make-wall-time) + (:print-function %print-wall-time)) + (mjd 0 :type fixnum) + (second 0 :type fixnum)) + +(defun %print-wall-time (time stream depth) + (declare (ignore depth)) + (format stream "#" (format-time nil time))) + +(defstruct (duration (:constructor %make-duration) + (:print-function %print-duration)) + (year 0 :type fixnum) + (month 0 :type fixnum) + (day 0 :type fixnum) + (hour 0 :type fixnum) + (second 0 :type fixnum) + (minute 0 :type fixnum)) + +(defun %print-duration (duration stream depth) + (declare (ignore depth)) + (format stream "#" + (format-duration nil duration :precision :second))) + +);eval-when + + +;; ------------------------------------------------------------ +;; Constructors + +(defun make-time (&key (year 0) (month 1) (day 1) (hour 0) (minute 0) + (second 0) (offset 0)) + (let ((mjd (gregorian-to-mjd month day year)) + (sec (+ (* hour 60 60) + (* minute 60) + second (- offset)))) + (multiple-value-bind (day-add raw-sec) + (floor sec (* 60 60 24)) + (%make-wall-time :mjd (+ mjd day-add) :second raw-sec)))) + +(defun copy-time (time) + (%make-wall-time :mjd (time-mjd time) + :second (time-second time))) + +(defun get-time () + "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)" + (multiple-value-bind (second minute hour day mon year) + (decode-universal-time (get-universal-time)) + (make-time :year year :month mon :day day :hour hour :minute minute + :second second))) + +(defun make-duration (&key (year 0) (month 0) (day 0) (hour 0) (minute 0) + (second 0)) + (multiple-value-bind (minute-add second-60) + (floor second 60) + (multiple-value-bind (hour-add minute-60) + (floor (+ minute minute-add) 60) + (multiple-value-bind (day-add hour-24) + (floor (+ hour hour-add) 24) + (%make-duration :year year :month month :day (+ day day-add) + :hour hour-24 + :minute minute-60 + :second second-60))))) + + +;; ------------------------------------------------------------ +;; Accessors + +(defun time-hms (time) + (multiple-value-bind (hourminute second) + (floor (time-second time) 60) + (multiple-value-bind (hour minute) + (floor hourminute 60) + (values hour minute second)))) + +(defun time-ymd (time) + (destructuring-bind (minute day year) + (mjd-to-gregorian (time-mjd time)) + (values year minute day))) + +(defun time-dow (time) + "Return the 0 indexed Day of the week starting with Sunday" + (mod (+ 3 (time-mjd time)) 7)) + +(defun decode-time (time) + "returns the decoded time as multiple values: second, minute, hour, day, +month, year, integer day-of-week" + (multiple-value-bind (year month day) + (time-ymd time) + (multiple-value-bind (hour minute second) + (time-hms time) + (values second minute hour day month year (mod (+ (time-mjd time) 3) 7))))) + +;; duration specific +(defun duration-reduce (duration precision) + (ecase precision + (:second + (+ (duration-second duration) + (* (duration-reduce duration :minute) 60))) + (:minute + (+ (duration-minute duration) + (* (duration-reduce duration :hour) 60))) + (:hour + (+ (duration-hour duration) + (* (duration-reduce duration :day) 24))) + (:day + (duration-day duration)))) + + +;; ------------------------------------------------------------ +;; Arithemetic and comparators + +(defun duration= (duration-a duration-b) + (= (duration-reduce duration-a :second) + (duration-reduce duration-b :second))) + +(defun duration< (duration-a duration-b) + (< (duration-reduce duration-a :second) + (duration-reduce duration-b :second))) + +(defun duration<= (duration-a duration-b) + (<= (duration-reduce duration-a :second) + (duration-reduce duration-b :second))) + +(defun duration>= (x y) + (duration<= y x)) + +(defun duration> (x y) + (duration< y x)) + +(defun %time< (x y) + (let ((mjd-x (time-mjd x)) + (mjd-y (time-mjd y))) + (if (/= mjd-x mjd-y) + (< mjd-x mjd-y) + (< (time-second x) (time-second y))))) + +(defun %time>= (x y) + (if (/= (time-mjd x) (time-mjd y)) + (>= (time-mjd x) (time-mjd y)) + (>= (time-second x) (time-second y)))) + +(defun %time<= (x y) + (if (/= (time-mjd x) (time-mjd y)) + (<= (time-mjd x) (time-mjd y)) + (<= (time-second x) (time-second y)))) + +(defun %time> (x y) + (if (/= (time-mjd x) (time-mjd y)) + (> (time-mjd x) (time-mjd y)) + (> (time-second x) (time-second y)))) + +(defun %time= (x y) + (and (= (time-mjd x) (time-mjd y)) + (= (time-second x) (time-second y)))) + +(defun time= (number &rest more-numbers) + "Returns T if all of its arguments are numerically equal, NIL otherwise." + (do ((nlist more-numbers (cdr nlist))) + ((atom nlist) t) + (declare (list nlist)) + (if (not (%time= (car nlist) number)) (return nil)))) + +(defun time/= (number &rest more-numbers) + "Returns T if no two of its arguments are numerically equal, NIL otherwise." + (do* ((head number (car nlist)) + (nlist more-numbers (cdr nlist))) + ((atom nlist) t) + (declare (list nlist)) + (unless (do* ((nl nlist (cdr nl))) + ((atom nl) t) + (declare (list nl)) + (if (%time= head (car nl)) (return nil))) + (return nil)))) + +(defun time< (number &rest more-numbers) + "Returns T if its arguments are in strictly increasing order, NIL otherwise." + (do* ((n number (car nlist)) + (nlist more-numbers (cdr nlist))) + ((atom nlist) t) + (declare (list nlist)) + (if (not (%time< n (car nlist))) (return nil)))) + +(defun time> (number &rest more-numbers) + "Returns T if its arguments are in strictly decreasing order, NIL otherwise." + (do* ((n number (car nlist)) + (nlist more-numbers (cdr nlist))) + ((atom nlist) t) + (declare (list nlist)) + (if (not (%time> n (car nlist))) (return nil)))) + +(defun time<= (number &rest more-numbers) + "Returns T if arguments are in strictly non-decreasing order, NIL otherwise." + (do* ((n number (car nlist)) + (nlist more-numbers (cdr nlist))) + ((atom nlist) t) + (declare (list nlist)) + (if (not (%time<= n (car nlist))) (return nil)))) + +(defun time>= (number &rest more-numbers) + "Returns T if arguments are in strictly non-increasing order, NIL otherwise." + (do* ((n number (car nlist)) + (nlist more-numbers (cdr nlist))) + ((atom nlist) t) + (declare (list nlist)) + (if (not (%time>= n (car nlist))) (return nil)))) + +(defun time-max (number &rest more-numbers) + "Returns the greatest of its arguments." + (do ((nlist more-numbers (cdr nlist)) + (result number)) + ((null nlist) (return result)) + (declare (list nlist)) + (if (%time> (car nlist) result) (setq result (car nlist))))) + +(defun time-min (number &rest more-numbers) + "Returns the least of its arguments." + (do ((nlist more-numbers (cdr nlist)) + (result number)) + ((null nlist) (return result)) + (declare (list nlist)) + (if (%time< (car nlist) result) (setq result (car nlist))))) + +(defun time-compare (time-a time-b) + (let ((mjd-a (time-mjd time-a)) + (mjd-b (time-mjd time-b)) + (sec-a (time-second time-a)) + (sec-b (time-second time-b))) + (if (= mjd-a mjd-b) + (if (= sec-a sec-b) + :equal + (if (< sec-a sec-b) + :less-than + :greater-than)) + (if (< mjd-a mjd-b) + :less-than + :greater-than)))) + + +;; ------------------------------------------------------------ +;; Formatting and output + +(defvar +decimal-printer+ #(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + +(defun db-timestring (time) + "return the string to store the given time in the database" + (declare (optimize (speed 3))) + (let ((output (copy-seq "'XXXX-XX-XX XX:XX:XX'"))) + (flet ((inscribe-base-10 (output offset size decimal) + (declare (type fixnum offset size decimal) + (type (simple-vector 10) +decimal-printer+)) + (dotimes (x size) + (declare (type fixnum x) + (optimize (safety 0))) + (multiple-value-bind (next this) + (floor decimal 10) + (setf (aref output (+ (- size x 1) offset)) + (aref +decimal-printer+ this)) + (setf decimal next))))) + (multiple-value-bind (second minute hour day month year) + (decode-time time) + (inscribe-base-10 output 1 4 year) + (inscribe-base-10 output 6 2 month) + (inscribe-base-10 output 9 2 day) + (inscribe-base-10 output 12 2 hour) + (inscribe-base-10 output 15 2 minute) + (inscribe-base-10 output 18 2 second) + output)))) + +(defun iso-timestring (time) + "return the string to store the given time in the database" + (declare (optimize (speed 3))) + (let ((output (copy-seq "XXXX-XX-XX XX:XX:XX"))) + (flet ((inscribe-base-10 (output offset size decimal) + (declare (type fixnum offset size decimal) + (type (simple-vector 10) +decimal-printer+)) + (dotimes (x size) + (declare (type fixnum x) + (optimize (safety 0))) + (multiple-value-bind (next this) + (floor decimal 10) + (setf (aref output (+ (- size x 1) offset)) + (aref +decimal-printer+ this)) + (setf decimal next))))) + (multiple-value-bind (second minute hour day month year) + (decode-time time) + (inscribe-base-10 output 0 4 year) + (inscribe-base-10 output 5 2 month) + (inscribe-base-10 output 8 2 day) + (inscribe-base-10 output 11 2 hour) + (inscribe-base-10 output 14 2 minute) + (inscribe-base-10 output 17 2 second) + output)))) + + +;; ------------------------------------------------------------ +;; Intervals + +(defstruct interval + (start nil) + (end nil) + (contained nil) + (type nil) + (data nil)) + +;; fix : should also return :contains / :contained + +(defun interval-relation (x y) + "Compare the relationship of node x to node y. Returns either +:contained :contains :follows :overlaps or :precedes." + (let ((xst (interval-start x)) + (xend (interval-end x)) + (yst (interval-start y)) + (yend (interval-end y))) + (case (time-compare xst yst) + (:equal + (case (time-compare xend yend) + (:less-than + :contained) + ((:equal :greater-than) + :contains))) + (:greater-than + (case (time-compare xst yend) + ((:equal :greater-than) + :follows) + (:less-than + (case (time-compare xend yend) + ((:less-than :equal) + :contained) + ((:greater-than) + :overlaps))))) + (:less-than + (case (time-compare xend yst) + ((:equal :less-than) + :precedes) + (:greater-than + (case (time-compare xend yend) + (:less-than + :overlaps) + ((:equal :greater-than) + :contains)))))))) + +;; ------------------------------------------------------------ +;; interval lists + +(defun sort-interval-list (list) + (sort list (lambda (x y) + (case (interval-relation x y) + ((:precedes :contains) t) + ((:follows :overlaps :contained) nil))))) + +;; interval push will return its list of intervals in strict order. +(defun interval-push (interval-list interval &optional container-rule) + (declare (ignore container-rule)) + (let ((sorted-list (sort-interval-list interval-list))) + (dotimes (x (length sorted-list)) + (let ((elt (nth x sorted-list))) + (case (interval-relation elt interval) + (:follows + (return-from interval-push (insert-at-index x sorted-list interval))) + (:contains + (return-from interval-push + (replace-at-index x sorted-list + (make-interval :start (interval-start elt) + :end (interval-end elt) + :type (interval-type elt) + :contained (interval-push (interval-contained elt) interval) + :data (interval-data elt))))) + ((:overlaps :contained) + (error "Overlap"))))) + (append sorted-list (list interval)))) + +;; interval lists + +(defun interval-match (list time) + "Return the index of the first interval in list containing time" + ;; this depends on ordering of intervals! + (dotimes (x (length list)) + (let ((elt (nth x list))) + (when (and (time<= (interval-start elt) time) + (time< time (interval-end elt))) + (return-from interval-match x)) + (when (time< time (interval-start elt)) + (return-from interval-match nil))))) + +(defun interval-clear (list time) + ;(cmsg "List = ~s" list) + (dotimes (x (length list)) + (let ((elt (nth x list))) + (when (and (time<= (interval-start elt) time) + (time< time (interval-end elt))) + (if (interval-match (interval-contained elt) time) + (return-from interval-clear + (replace-at-index x list + (make-interval :start (interval-start elt) + :end (interval-end elt) + :type (interval-type elt) + :contained (interval-clear (interval-contained elt) time) + :data (interval-data elt)))) + (return-from interval-clear + (delete-at-index x list))))))) + +(defun interval-edit (list time start end &optional tag) + "Attempts to modify the most deeply nested interval in list which +begins at time. If no changes are made, returns nil." + ;; function required sorted interval list + (let ((list (sort-interval-list list))) + (if (null list) nil + (dotimes (x (length list)) + (let ((elt (nth x list))) + (when (and (time<= (interval-start elt) time) + (time< time (interval-end elt))) + (or (interval-edit (interval-contained elt) time start end tag) + (cond ((and (< 0 x) + (time< start (interval-end (nth (1- x) list)))) + (error "Overlap of previous interval")) + ((and (< x (1- (length list))) + (time< (interval-start (nth (1+ x) list)) end)) + (error "~S ~S ~S ~S Overlap of next interval" x (length list) (interval-start (nth (1+ x) list)) end )) + ((time= (interval-start elt) time) + (return-from interval-edit + (replace-at-index x list + (make-interval :start start + :end end + :type (interval-type elt) + :contained (restrict-intervals (interval-contained elt) start end) + :data (or tag (interval-data elt)))))))))))))) + +(defun restrict-intervals (list start end &aux newlist) + (let ((test-interval (make-interval :start start :end end))) + (dolist (elt list) + (when (equal :contained + (interval-relation elt test-interval)) + (push elt newlist))) + (nreverse newlist))) + +;;; utils from odcl/list.lisp + +(defun replace-at-index (idx list elt) + (cond ((= idx 0) + (cons elt (cdr list))) + ((= idx (1- (length list))) + (append (butlast list) (list elt))) + (t + (append (subseq list 0 idx) + (list elt) + (subseq list (1+ idx)))))) + +(defun insert-at-index (idx list elt) + (cond ((= idx 0) + (cons elt list)) + ((= idx (1- (length list))) + (append list (list elt))) + (t + (append (subseq list 0 idx) + (list elt) + (subseq list idx))))) + +(defun delete-at-index (idx list) + (cond ((= idx 0) + (cdr list)) + ((= idx (1- (length list))) + (butlast list)) + (t + (append (subseq list 0 idx) + (subseq list (1+ idx)))))) + + +;; ------------------------------------------------------------ +;; return MJD for Gregorian date + +(defun gregorian-to-mjd (month day year) + (let ((b 0) + (month-adj month) + (year-adj (if (< year 0) + (+ year 1) + year)) + d + c) + (when (< month 3) + (incf month-adj 12) + (decf year-adj)) + (unless (or (< year 1582) + (and (= year 1582) + (or (< month 10) + (and (= month 10) + (< day 15))))) + (let ((a (floor (/ year-adj 100)))) + (setf b (+ (- 2 a) (floor (/ a 4)))))) + (if (< year-adj 0) + (setf c (floor (- (* 365.25d0 year-adj) 679006.75d0))) + (setf c (floor (- (* 365.25d0 year-adj) 679006d0)))) + (setf d (floor (* 30.6001 (+ 1 month-adj)))) + ;; (cmsg "b ~s c ~s d ~s day ~s" b c d day) + (+ b c d day))) + +;; convert MJD to Gregorian date + +(defun mjd-to-gregorian (mjd) + (let (z r g a b c year month day) + (setf z (floor (+ mjd 678882))) + (setf r (- (+ mjd 678882) z)) + (setf g (- z .25)) + (setf a (floor (/ g 36524.25))) + (setf b (- a (floor (/ a 4)))) + (setf year (floor (/ (+ b g) 365.25))) + (setf c (- (+ b z) (floor (* 365.25 year)))) + (setf month (truncate (/ (+ (* 5 c) 456) 153))) + (setf day (+ (- c (truncate (/ (- (* 153 month) 457) 5))) r)) + (when (> month 12) + (incf year) + (decf month 12)) + (list month day year))) + +(defun duration+ (time &rest durations) + "Add each DURATION to TIME, returning a new wall-time value." + (let ((year (duration-year time)) + (month (duration-month time)) + (day (duration-day time)) + (hour (duration-hour time)) + (minute (duration-minute time)) + (second (duration-second time))) + (dolist (duration durations) + (incf year (duration-year duration)) + (incf month (duration-month duration)) + (incf day (duration-day duration)) + (incf hour (duration-hour duration)) + (incf minute (duration-minute duration)) + (incf second (duration-second duration))) + (make-duration :year year :month month :day day :hour hour :minute minute + :second second))) + +(defun duration- (duration &rest durations) + "Subtract each DURATION from TIME, returning a new duration value." + (let ((year (duration-year duration)) + (month (duration-month duration)) + (day (duration-day duration)) + (hour (duration-hour duration)) + (minute (duration-minute duration)) + (second (duration-second duration))) + (dolist (duration durations) + (decf year (duration-year duration)) + (decf month (duration-month duration)) + (decf day (duration-day duration)) + (decf hour (duration-hour duration)) + (decf minute (duration-minute duration)) + (decf second (duration-second duration))) + (make-duration :year year :month month :day day :hour hour :minute minute + :second second))) + +;; Date + Duration + +(defun time+ (time &rest durations) + "Add each DURATION to TIME, returning a new wall-time value." + (let ((new-time (copy-time time))) + (dolist (duration durations) + (roll new-time + :year (duration-year duration) + :month (duration-month duration) + :day (duration-day duration) + :hour (duration-hour duration) + :minute (duration-minute duration) + :second (duration-second duration) + :destructive t)) + new-time)) + +(defun time- (time &rest durations) + "Subtract each DURATION from TIME, returning a new wall-time value." + (let ((new-time (copy-time time))) + (dolist (duration durations) + (roll new-time + :year (- (duration-year duration)) + :month (- (duration-month duration)) + :day (- (duration-day duration)) + :hour (- (duration-hour duration)) + :minute (- (duration-minute duration)) + :second (- (duration-second duration)) + :destructive t)) + new-time)) + +(defun time-difference (time1 time2) + "Returns a DURATION representing the difference between TIME1 and +TIME2." + (flet ((do-diff (time1 time2) + + (let (day-diff sec-diff) + (setf day-diff (- (time-mjd time2) + (time-mjd time1))) + (if (> day-diff 0) + (progn (decf day-diff) + (setf sec-diff (+ (time-second time2) + (- (* 60 60 24) + (time-second time1))))) + (setf sec-diff (- (time-second time2) + (time-second time1)))) + (make-duration :day day-diff + :second sec-diff)))) + (if (time< time1 time2) + (do-diff time1 time2) + (do-diff time2 time1)))) + +(defun format-time (stream time &key format + (date-separator "-") + (time-separator ":") + (internal-separator " ")) + "produces on stream the timestring corresponding to the wall-time +with the given options" + (multiple-value-bind (second minute hour day month year dow) + (decode-time time) + (case format + (:pretty + (format stream "~A ~A, ~A ~D, ~D" + (pretty-time hour minute) + (day-name dow) + (month-name month) + day + year)) + (:short-pretty + (format stream "~A, ~D/~D/~D" + (pretty-time hour minute) + month day year)) + (:iso + (let ((string (iso-timestring time))) + (if stream + (write-string string stream) + string))) + (t + (format stream "~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D~A~2,'0D" + year date-separator month date-separator day + internal-separator hour time-separator minute time-separator + second))))) + +(defun pretty-time (hour minute) + (cond + ((eq hour 0) + (format nil "12:~2,'0D AM" minute)) + ((eq hour 12) + (format nil "12:~2,'0D PM" minute)) + ((< hour 12) + (format nil "~D:~2,'0D AM" hour minute)) + ((and (> hour 12) (< hour 24)) + (format nil "~D:~2,'0D PM" (- hour 12) minute)) + (t + (error "pretty-time got bad hour")))) + +(defun leap-days-in-days (days) + ;; return the number of leap days between Mar 1 2000 and + ;; (Mar 1 2000) + days, where days can be negative + (if (< days 0) + (ceiling (/ (- days) (* 365 4))) + (floor (/ days (* 365 4))))) + +(defun current-year () + (third (mjd-to-gregorian (time-mjd (get-time))))) + +(defun current-day () + (second (mjd-to-gregorian (time-mjd (get-time))))) + +(defun current-month () + (first (mjd-to-gregorian (time-mjd (get-time))))) + +(defun parse-date-time (string) + "parses date like 08/08/01, 8.8.2001, eg" + (when (> (length string) 1) + (let ((m (current-month)) + (d (current-day)) + (y (current-year))) + (let ((integers (mapcar #'parse-integer (hork-integers string)))) + (case (length integers) + (1 + (setf y (car integers))) + (2 + (setf m (car integers)) + (setf y (cadr integers))) + (3 + (setf m (car integers)) + (setf d (cadr integers)) + (setf y (caddr integers))) + (t + (return-from parse-date-time)))) + (when (< y 100) + (incf y 2000)) + (make-time :year y :month m :day d)))) + +(defun hork-integers (input) + (let ((output '()) + (start 0)) + (dotimes (x (length input)) + (unless (<= 48 (char-code (aref input x)) 57) + (push (subseq input start x) output) + (setf start (1+ x)))) + (nreverse (push (subseq input start) output)))) + +(defun merged-time (day time-of-day) + (%make-wall-time :mjd (time-mjd day) + :second (time-second time-of-day))) + +(defun time-meridian (hours) + (cond ((= hours 0) + (values 12 "AM")) + ((= hours 12) + (values 12 "PM")) + ((< 12 hours) + (values (- hours 12) "PM")) + (t + (values hours "AM")))) + +(defun print-date (time &optional (style :daytime)) + (multiple-value-bind (second minute hour day month year dow) + (decode-time time) + (declare (ignore second)) + (multiple-value-bind (hours meridian) + (time-meridian hour) + (ecase style + (:time-of-day + ;; 2:00 PM + (format nil "~d:~2,'0d ~a" hours minute meridian)) + (:long-day + ;; October 11th, 2000 + (format nil "~a ~d, ~d" (month-name month) day year)) + (:month + ;; October + (month-name month)) + (:month-year + ;; October 2000 + (format nil "~a ~d" (month-name month) year)) + (:full + ;; 11:08 AM, November 22, 2002 + (format nil "~d:~2,'0d ~a, ~a ~d, ~d" + hours minute meridian (month-name month) day year)) + (:full+weekday + ;; 11:09 AM Friday, November 22, 2002 + (format nil "~d:~2,'0d ~a ~a, ~a ~d, ~d" + hours minute meridian (nth dow *day-names*) + (month-name month) day year)) + (:daytime + ;; 11:09 AM, 11/22/2002 + (format-time nil time :format :short-pretty)) + (:day + ;; 11/22/2002 + (format nil "~d/~d/~d" month day year)))))) + +(defun time-element (time element) + (multiple-value-bind (second minute hour day month year dow) + (decode-time time) + (ecase element + (:seconds + second) + (:minutes + minute) + (:hours + hour) + (:day-of-month + day) + (:integer-day-of-week + dow) + (:day-of-week + (nth dow *day-keywords*)) + (:month + month) + (:year + year)))) + +(defun format-duration (stream duration &key (precision :minute)) + (let ((second (duration-second duration)) + (minute (duration-minute duration)) + (hour (duration-hour duration)) + (day (duration-day duration)) + (return (null stream)) + (stream (or stream (make-string-output-stream)))) + (ecase precision + (:day + (setf hour 0 second 0 minute 0)) + (:hour + (setf second 0 minute 0)) + (:minute + (setf second 0)) + (:second + t)) + (if (= 0 day hour minute) + (format stream "0 minutes") + (let ((sent? nil)) + (when (< 0 day) + (format stream "~d day~p" day day) + (setf sent? t)) + (when (< 0 hour) + (when sent? + (write-char #\Space stream)) + (format stream "~d hour~p" hour hour) + (setf sent? t)) + (when (< 0 minute) + (when sent? + (write-char #\Space stream)) + (format stream "~d min~p" minute minute) + (setf sent? t)) + (when (< 0 second) + (when sent? + (write-char #\Space stream)) + (format stream "~d sec~p" second second)))) + (when return + (get-output-stream-string stream)))) + +(defgeneric midnight (self)) +(defmethod midnight ((self wall-time)) + "truncate hours, minutes and seconds" + (%make-wall-time :mjd (time-mjd self))) + +(defun roll (date &key (year 0) (month 0) (day 0) (second 0) (hour 0) + (minute 0) (destructive nil)) + (unless (= 0 year month) + (multiple-value-bind (year-orig month-orig day-orig) + (time-ymd date) + (setf date (make-time :year (+ year year-orig) + :month (+ month month-orig) + :day day-orig + :second (time-second date))))) + (let ((mjd (time-mjd date)) + (sec (time-second date))) + (multiple-value-bind (mjd-new sec-new) + (floor (+ sec second + (* 60 minute) + (* 60 60 hour)) (* 60 60 24)) + (if destructive + (progn + (setf (time-mjd date) (+ mjd mjd-new day) + (time-second date) sec-new) + date) + (%make-wall-time :mjd (+ mjd mjd-new day) + :second sec-new))))) + +(defun roll-to (date size position) + (ecase size + (:month + (ecase position + (:beginning + (roll date :day (+ 1 + (- (time-element date :day-of-month))))) + (:end + (roll date :day (+ (days-in-month (time-element date :month) + (time-element date :year)) + (- (time-element date :day-of-month))))))))) + +(defun week-containing (time) + (let* ((midn (midnight time)) + (dow (time-element midn :integer-day-of-week))) + (list (roll midn :day (- dow)) + (roll midn :day (- 7 dow))))) + +(defun leap-year? (year) + "t if YEAR is a leap yeap in the Gregorian calendar" + (and (= 0 (mod year 4)) + (or (not (= 0 (mod year 100))) + (= 0 (mod year 400))))) + +(defun valid-month-p (month) + "t if MONTH exists in the Gregorian calendar" + (<= 1 month 12)) + +(defun valid-gregorian-date-p (date) + "t if DATE (year month day) exists in the Gregorian calendar" + (let ((max-day (days-in-month (nth 1 date) (nth 0 date)))) + (<= 1 (nth 2 date) max-day))) + +(defun days-in-month (month year &key (careful t)) + "the number of days in MONTH of YEAR, observing Gregorian leap year +rules" + (declare (type fixnum month year)) + (when careful + (check-type month (satisfies valid-month-p) + "between 1 (January) and 12 (December)")) + (if (eql month 2) ; feb + (if (leap-year? year) + 29 28) + (let ((even (mod (1- month) 2))) + (if (< month 8) ; aug + (- 31 even) + (+ 30 even))))) + +(defun day-of-year (year month day &key (careful t)) + "the day number within the year of the date DATE. For example, +1987 1 1 returns 1" + (declare (type fixnum year month day)) + (when careful + (let ((date (list year month day))) + (check-type date (satisfies valid-gregorian-date-p) + "a valid Gregorian date"))) + (let ((doy (+ day (* 31 (1- month))))) + (declare (type fixnum doy)) + (when (< 2 month) + (setq doy (- doy (floor (+ 23 (* 4 month)) 10))) + (when (leap-year? year) + (incf doy))) + doy)) + + +;; ------------------------------------------------------------ +;; Parsing iso-8601 timestrings + +(define-condition iso-8601-syntax-error (error) + ((bad-component;; year, month whatever + :initarg :bad-component + :reader bad-component))) + +(defun parse-timestring (timestring &key (start 0) end junk-allowed) + "parse a timestring and return the corresponding wall-time. If the +timestring starts with P, read a duration; otherwise read an ISO 8601 +formatted date string." + (declare (ignore junk-allowed)) ;; FIXME + (let ((string (subseq timestring start end))) + (if (char= (aref string 0) #\P) + (parse-iso-8601-duration string) + (parse-iso-8601-time string)))) + +(defvar *iso-8601-duration-delimiters* + '((#\D . :days) + (#\H . :hours) + (#\M . :minutes) + (#\S . :seconds))) + +(defun iso-8601-delimiter (elt) + (cdr (assoc elt *iso-8601-duration-delimiters*))) + +(defun iso-8601-duration-subseq (string start) + (let* ((pos (position-if #'iso-8601-delimiter string :start start)) + (number (when pos (parse-integer (subseq string start pos) + :junk-allowed t)))) + (when number + (values number + (1+ pos) + (iso-8601-delimiter (aref string pos)))))) + +(defun parse-iso-8601-duration (string) + "return a wall-time from a duration string" + (block parse + (let ((days 0) (secs 0) (hours 0) (minutes 0) (index 1)) + (loop + (multiple-value-bind (duration next-index duration-type) + (iso-8601-duration-subseq string index) + (case duration-type + (:hours + (incf hours duration)) + (:minutes + (incf minutes duration)) + (:seconds + (incf secs duration)) + (:days + (incf days duration)) + (t + (return-from parse (make-duration :day days :hour hours + :minute minutes :second secs)))) + (setq index next-index)))))) + +;; e.g. 2000-11-11 00:00:00-06 + +(defun parse-iso-8601-time (string) + "return the wall-time corresponding to the given ISO 8601 datestring" + (multiple-value-bind (year month day hour minute second offset) + (syntax-parse-iso-8601 string) + (make-time :year year + :month month + :day day + :hour hour + :minute minute + :second second + :offset offset))) + + +(defun syntax-parse-iso-8601 (string) + (let (year month day hour minute second gmt-sec-offset) + (handler-case + (progn + (setf year (parse-integer (subseq string 0 4)) + month (parse-integer (subseq string 5 7)) + day (parse-integer (subseq string 8 10)) + hour (if (<= 13 (length string)) + (parse-integer (subseq string 11 13)) + 0) + minute (if (<= 16 (length string)) + (parse-integer (subseq string 14 16)) + 0) + second (if (<= 19 (length string)) + (parse-integer (subseq string 17 19)) + 0) + gmt-sec-offset (if (<= 22 (length string)) + (* 60 60 + (parse-integer (subseq string 19 22))) + 0)) + (unless (< 0 year) + (error 'iso-8601-syntax-error + :bad-component '(year . 0))) + (unless (< 0 month) + (error 'iso-8601-syntax-error + :bad-component '(month . 0))) + (unless (< 0 day) + (error 'iso-8601-syntax-error + :bad-component '(month . 0))) + (values year month day hour minute second gmt-sec-offset)) + (simple-error () + (error 'iso-8601-syntax-error + :bad-component + (car (find-if (lambda (pair) (null (cdr pair))) + `((year . ,year) (month . ,month) + (day . ,day) (hour ,hour) + (minute ,minute) (second ,second) + (timezone ,gmt-sec-offset))))))))) diff --git a/base/transaction.lisp b/base/transaction.lisp new file mode 100644 index 0000000..9a91455 --- /dev/null +++ b/base/transaction.lisp @@ -0,0 +1,102 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id: transactions.lisp 7061 2003-09-07 06:34:45Z kevin $ + +(in-package #:clsql-base-sys) + +(defclass transaction () + ((commit-hooks :initform () :accessor commit-hooks) + (rollback-hooks :initform () :accessor rollback-hooks) + (status :initform nil :accessor transaction-status))) ; nil or :committed + +(defun commit-transaction (database) + (when (and (transaction database) + (not (transaction-status (transaction database)))) + (setf (transaction-status (transaction database)) :committed))) + +(defun add-transaction-commit-hook (database commit-hook) + (when (transaction database) + (push commit-hook (commit-hooks (transaction database))))) + +(defun add-transaction-rollback-hook (database rollback-hook) + (when (transaction database) + (push rollback-hook (rollback-hooks (transaction database))))) + +(defmethod database-start-transaction ((database closed-database)) + (signal-closed-database-error database)) + +(defmethod database-start-transaction (database) + (unless database (error 'clsql-nodb-error)) + (unless (transaction database) + (setf (transaction database) (make-instance 'transaction))) + (when (= (incf (transaction-level database) 1)) + (let ((transaction (transaction database))) + (setf (commit-hooks transaction) nil + (rollback-hooks transaction) nil + (transaction-status transaction) nil) + (execute-command "BEGIN" :database database)))) + +(defmethod database-commit-transaction ((database closed-database)) + (signal-closed-database-error database)) + +(defmethod database-commit-transaction (database) + (if (> (transaction-level database) 0) + (when (zerop (decf (transaction-level database))) + (execute-command "COMMIT" :database database) + (map nil #'funcall (commit-hooks (transaction database)))) + (warn 'clsql-simple-warning + :format-control "Cannot commit transaction against ~A because there is no transaction in progress." + :format-arguments (list database)))) + +(defmethod database-abort-transaction ((database closed-database)) + (signal-closed-database-error database)) + +(defmethod database-abort-transaction (database) + (if (> (transaction-level database) 0) + (when (zerop (decf (transaction-level database))) + (unwind-protect + (execute-command "ROLLBACK" :database database) + (map nil #'funcall (rollback-hooks (transaction database))))) + (warn 'clsql-simple-warning + :format-control "Cannot abort transaction against ~A because there is no transaction in progress." + :format-arguments (list database)))) + + +(defmacro with-transaction ((&key (database *default-database*)) &rest body) + "Executes BODY within a transaction for DATABASE (which defaults to +*DEFAULT-DATABASE*). The transaction is committed if the body finishes +successfully (without aborting or throwing), otherwise the database is +rolled back." + (let ((db (gensym "db-"))) + `(let ((,db ,database)) + (unwind-protect + (progn + (database-start-transaction ,db) + ,@body + (commit-transaction ,db)) + (if (eq (transaction-status (transaction ,db)) :committed) + (database-commit-transaction ,db) + (database-abort-transaction ,db)))))) + +(defun commit (&key (database *default-database*)) + "Commits changes made to DATABASE which defaults to *DEFAULT-DATABASE*." + (database-commit-transaction database)) + +(defun rollback (&key (database *default-database*)) + "Rolls back changes made in DATABASE, which defaults to +*DEFAULT-DATABASE* since the last commit, that is changes made since +the last commit are not recorded." + (database-abort-transaction database)) + +(defun start-transaction (&key (database *default-database*)) + "Starts a transaction block on DATABASE which defaults to +*default-database* and which continues until ROLLBACK or COMMIT are +called." + (unless (in-transaction-p :database database) + (database-start-transaction database))) + +(defun in-transaction-p (&key (database *default-database*)) + "A predicate to test whether we are currently within the scope of a +transaction in DATABASE." + (and database (transaction database) (= (transaction-level database) 1))) diff --git a/base/utils.lisp b/base/utils.lisp index 879c675..f123b4f 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -2,22 +2,21 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: utils.cl +;;;; Name: utils.lisp ;;;; Purpose: SQL utility functions ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Mar 2002 ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; ;;;; 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. ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-base-sys) +(in-package #:clsql-base-sys) (defun number-to-sql-string (num) (etypecase num diff --git a/clsql-base.asd b/clsql-base.asd index 51fbfe8..f535a3a 100644 --- a/clsql-base.asd +++ b/clsql-base.asd @@ -16,6 +16,9 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* +(eval-when (:compile-toplevel) + (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))) + (defpackage #:clsql-base-system (:use #:asdf #:cl)) (in-package #:clsql-base-system) @@ -37,5 +40,13 @@ (:file "classes" :depends-on ("package")) (:file "conditions" :depends-on ("classes")) (:file "db-interface" :depends-on ("conditions")) - (:file "initialize" :depends-on ("db-interface")))))) + (:file "initialize" :depends-on ("db-interface")) + (:file "loop-extension" :depends-on ("db-interface")) + (:file "time" :depends-on ("package")) + (:file "database" :depends-on ("initialize")) + (:file "recording" :depends-on ("time" "database")) + (:file "basic-sql" :depends-on ("database")) + (:file "pool" :depends-on ("basic-sql")) + (:file "transaction" :depends-on ("basic-sql")) + )))) diff --git a/clsql-usql-tests.asd b/clsql-usql-tests.asd new file mode 100644 index 0000000..e60abab --- /dev/null +++ b/clsql-usql-tests.asd @@ -0,0 +1,35 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: clsql-usql-tests.asd +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 12:34:41 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; ASDF system definition for CLSQL-USQL test suite. +;;;; +;;;; ====================================================================== + +(in-package #:cl-user) + +(asdf:defsystem :clsql-usql-tests + :name "CLSQL-USQL Tests" + :author "" + :maintainer "" + :version "" + :licence "" + :description "A regression test suite for CLSQL-USQL." + :components + ((:module usql-tests + :components ((:file "package") + (:file "test-init") + (:file "test-connection") + (:file "test-fddl") + (:file "test-fdml") + (:file "test-ooddl") + (:file "test-oodml") + (:file "test-syntax")))) + :depends-on (:clsql-usql :rt)) diff --git a/clsql-usql.asd b/clsql-usql.asd new file mode 100644 index 0000000..428fb14 --- /dev/null +++ b/clsql-usql.asd @@ -0,0 +1,54 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: usql.asd +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:58:21 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; ASDF system definition for CLSQL-USQL. +;;;; +;;;; ====================================================================== + +(asdf:defsystem #:clsql-usql + :name "CLSQL-USQL" + :author "" + :maintainer "" + :version "" + :licence "" + :description "A high level Common Lisp interface to SQL RDBMS." + :long-description "A high level Common Lisp interface to SQL RDBMS +based on the Xanalys CommonSQL interface for Lispworks. It depends on +the low-level database interfaces provided by CLSQL and includes both +a functional and an object oriented interface." + :components + ((:module usql + :components + ((:module :patches + :pathname "" + :components (#+(or cmu sbcl) (:file "pcl-patch"))) + (:module :package + :pathname "" + :components ((:file "package")) + :depends-on (:patches)) + (: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))))) + :depends-on (:clsql-base)) + diff --git a/clsql.asd b/clsql.asd index 15a3249..cef8387 100644 --- a/clsql.asd +++ b/clsql.asd @@ -33,12 +33,10 @@ ((:module :sql :components ((:file "package") - (:file "pool" :depends-on ("package")) - (:file "loop-extension") - (:file "sql" :depends-on ("pool")) - (:file "transactions" :depends-on ("sql")) + (:file "sql" :depends-on ("package")) (:file "functional" :depends-on ("sql")) - (:file "usql" :depends-on ("sql"))))) + (:file "usql" :depends-on ("sql")) + ))) :depends-on (:clsql-base) ) diff --git a/debian/changelog b/debian/changelog index e1097ac..48e3e48 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +cl-sql (2.1.0-1) unstable; urgency=low + + * New upstream + + -- Kevin M. Rosenberg Mon, 5 Apr 2004 14:30:41 -0600 + cl-sql (2.0.0-2) unstable; urgency=low * Change from libmysqlclient10 to libmysqlclient diff --git a/sql/functional.lisp b/sql/functional.lisp index 4222f8f..dd8aa04 100644 --- a/sql/functional.lisp +++ b/sql/functional.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: functional.cl +;;;; Name: functional.lisp ;;;; Purpose: Functional interface ;;;; Programmer: Pierre R. Mai ;;;; @@ -26,8 +26,7 @@ ;;;; 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA ;;;; ************************************************************************* -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) +(in-package #:clsql-sys) ;;;; This file implements the more advanced functions of the @@ -84,16 +83,3 @@ where) :database database)))) -(defmacro with-database ((db-var connection-spec &rest connect-args) &body body) - "Evaluate the body in an environment, where `db-var' is bound to the -database connection given by `connection-spec' and `connect-args'. -The connection is automatically closed or released to the pool on exit from the body." - (let ((result (gensym "result-"))) - (unless db-var (setf db-var '*default-database*)) - `(let ((,db-var (connect ,connection-spec ,@connect-args)) - (,result nil)) - (unwind-protect - (let ((,db-var ,db-var)) - (setf ,result (progn ,@body))) - (disconnect :database ,db-var)) - ,result))) \ No newline at end of file diff --git a/sql/package.lisp b/sql/package.lisp index 3f8d191..bb76d3e 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: package.cl +;;;; Name: package.lisp ;;;; Purpose: Package definition for CLSQL (high-level) interface ;;;; Programmers: Kevin M. Rosenberg based on ;;;; Original code by Pierre R. Mai @@ -10,7 +10,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -76,14 +76,6 @@ )) (:export ;; sql.cl - #:*connect-if-exists* - #:connected-databases - #:*default-database* - #:find-database - #:connect - #:disconnect - #:query - #:execute-command #:map-query #:do-query #:for-each-row @@ -94,32 +86,12 @@ #:update-records #:with-database - ;; For High-level UncommonSQL compatibility - #:sql-ident - #:list-tables - #:list-attributes - #:attribute-type - #:create-sequence - #:drop-sequence - #:sequence-next - - ;; Pooled connections - #:disconnect-pooled - #:find-or-create-connection-pool - - ;; Transactions - #:with-transaction - #:commit-transaction - #:rollback-transaction - #:add-transaction-commit-hook - #:add-transaction-rollback-hook - ;; Large objects (Marc B) #:create-large-object #:write-large-object #:read-large-object #:delete-large-object - + . #1# ) diff --git a/sql/sql.lisp b/sql/sql.lisp index e1492a5..d46bdcf 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -2,14 +2,14 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: sql.cl +;;;; Name: sql.lisp ;;;; Purpose: High-level SQL interface ;;;; Authors: Kevin M. Rosenberg based on code by Pierre R. Mai ;;;; Date Started: Feb 2002 ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and Copyright (c) 1999-2001 by Pierre R. Mai ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -17,119 +17,9 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(eval-when (:compile-toplevel) - (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))) - (in-package #:clsql-sys) -;;; Database handling - -(defvar *connect-if-exists* :error - "Default value for the if-exists parameter of connect calls.") - -(defvar *connected-databases* nil - "List of active database objects.") - -(defun connected-databases () - "Return the list of active database objects." - *connected-databases*) - -(defvar *default-database* nil - "Specifies the default database to be used.") - -(defun find-database (database &optional (errorp t)) - (etypecase database - (database - ;; Return the database object itself - database) - (string - (or (find database (connected-databases) - :key #'database-name - :test #'string=) - (when errorp - (cerror "Return nil." - 'clsql-simple-error - :format-control "There exists no database called ~A." - :format-arguments (list database))))))) - -(defun connect (connection-spec - &key (if-exists *connect-if-exists*) - (database-type *default-database-type*) - (pool nil)) - "Connects to a database of the given database-type, using the type-specific -connection-spec. -If pool is t the connection will be taken from the general pool, -if pool is a conn-pool object the connection will be taken from this pool. -" - (if pool - (acquire-from-pool connection-spec database-type pool) - (let* ((db-name (database-name-from-spec connection-spec database-type)) - (old-db (unless (eq if-exists :new) (find-database db-name nil))) - (result nil)) - (if old-db - (case if-exists -; (:new -; (setq result -; (database-connect connection-spec database-type))) - (:warn-new - (setq result - (database-connect connection-spec database-type)) - (warn 'clsql-exists-warning :old-db old-db :new-db result)) - (:error - (restart-case - (error 'clsql-exists-error :old-db old-db) - (create-new () - :report "Create a new connection." - (setq result - (database-connect connection-spec database-type))) - (use-old () - :report "Use the existing connection." - (setq result old-db)))) - (:warn-old - (setq result old-db) - (warn 'clsql-exists-warning :old-db old-db :new-db old-db)) - (:old - (setq result old-db))) - (setq result - (database-connect connection-spec database-type))) - (when result - (pushnew result *connected-databases*) - (setq *default-database* result) - result)))) - - -(defun disconnect (&key (database *default-database*)) - "Closes the connection to database. Resets *default-database* if that -database was disconnected and only one other connection exists. -if the database is from a pool it will be released to this pool." - (if (conn-pool database) - (release-to-pool database) - (when (database-disconnect database) - (setq *connected-databases* (delete database *connected-databases*)) - (when (eq database *default-database*) - (setq *default-database* (car *connected-databases*))) - (change-class database 'closed-database) - t))) - -;;; Basic operations on databases - -(defgeneric query (expression &key database types)) -(defmethod query (query-expression &key (database *default-database*) - types) - "Execute the SQL query expression query-expression on the given database. -Returns a list of lists of values of the result of that expression." - (database-query query-expression database types)) - - -(defgeneric execute-command (expression &key database)) -(defmethod execute-command (sql-expression &key (database *default-database*)) - "Execute the SQL command expression sql-expression on the given database. -Returns true on success or nil on failure." - (database-execute-command sql-expression database)) - - - (defun map-query (output-type-spec function query-expression &key (database *default-database*) (types nil)) @@ -237,24 +127,6 @@ specified in output-type-spec and returned like in MAP." ,@body)) (database-dump-result-set ,result-set ,db))))))) -;;; Marc Battyani : Large objects support - -(defun create-large-object (&key (database *default-database*)) - "Creates a new large object in the database and returns the object identifier" - (database-create-large-object database)) - -(defun write-large-object (object-id data &key (database *default-database*)) - "Writes data to the large object" - (database-write-large-object object-id data database)) - -(defun read-large-object (object-id &key (database *default-database*)) - "Reads the large object content" - (database-read-large-object object-id database)) - -(defun delete-large-object (object-id &key (database *default-database*)) - "Deletes the large object in the database" - (database-delete-large-object object-id database)) - ;;; Row processing macro @@ -326,3 +198,23 @@ specified in output-type-spec and returned like in MAP." (loop for tuple in (query ,q) collect (destructuring-bind ,bind-fields tuple ,@body)))))) + +;;; Marc Battyani : Large objects support + +(defun create-large-object (&key (database *default-database*)) + "Creates a new large object in the database and returns the object identifier" + (database-create-large-object database)) + +(defun write-large-object (object-id data &key (database *default-database*)) + "Writes data to the large object" + (database-write-large-object object-id data database)) + +(defun read-large-object (object-id &key (database *default-database*)) + "Reads the large object content" + (database-read-large-object object-id database)) + +(defun delete-large-object (object-id &key (database *default-database*)) + "Deletes the large object in the database" + (database-delete-large-object object-id database)) + + diff --git a/sql/transactions.lisp b/sql/transactions.lisp deleted file mode 100644 index 582e837..0000000 --- a/sql/transactions.lisp +++ /dev/null @@ -1,87 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: transactions.cl -;;;; Purpose: Transaction support -;;;; Programmers: Marc Battyani -;;;; Date Started: Apr 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg -;;;; -;;;; 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. -;;;; ************************************************************************* - -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) - -;; I removed the USQL transaction stuff to put a smaller, lighter one (MB) - -(defclass transaction () - ((commit-hooks :initform () :accessor commit-hooks) - (rollback-hooks :initform () :accessor rollback-hooks) - (status :initform nil :accessor status))) ;can be nil :rolled-back or :commited - -(defgeneric database-start-transaction (database)) -(defmethod database-start-transaction ((database closed-database)) - (error 'clsql-closed-database-error database)) - -(defmethod database-start-transaction (database) - (unless (transaction database) - (setf (transaction database) (make-instance 'transaction))) - (when (= (incf (transaction-level database)) 1) - (let ((transaction (transaction database))) - (setf (commit-hooks transaction) nil - (rollback-hooks transaction) nil - (status transaction) nil) - (execute-command "BEGIN" :database database)))) - -(defgeneric database-end-transaction (database)) -(defmethod database-end-transaction ((database closed-database)) - (error 'clsql-closed-database-error database)) - -(defmethod database-end-transaction (database) - (if (> (transaction-level database) 0) - (when (zerop (decf (transaction-level database))) - (let ((transaction (transaction database))) - (if (eq (status transaction) :commited) - (progn - (execute-command "COMMIT" :database database) - (map nil #'funcall (commit-hooks transaction))) - (unwind-protect ;status is not :commited - (execute-command "ROLLBACK" :database database) - (map nil #'funcall (rollback-hooks transaction)))))) - (warn "Continue without commit." - 'clsql-simple-error - :format-control "Cannot commit transaction against ~A because there is no transaction in progress." - :format-arguments (list database)))) - -(defun rollback-transaction (database) - (when (and (transaction database)(not (status (transaction database)))) - (setf (status (transaction database)) :rolled-back))) - -(defun commit-transaction (database) - (when (and (transaction database)(not (status (transaction database)))) - (setf (status (transaction database)) :commited))) - -(defun add-transaction-commit-hook (database commit-hook) - (when (transaction database) - (push commit-hook (commit-hooks (transaction database))))) - -(defun add-transaction-rollback-hook (database rollback-hook) - (when (transaction database) - (push rollback-hook (rollback-hooks (transaction database))))) - -(defmacro with-transaction ((&key (database '*default-database*)) &rest body) - (let ((db (gensym "db-"))) - `(let ((,db ,database)) - (unwind-protect - (progn - (database-start-transaction ,db) - ,@body - (commit-transaction ,db)) - (database-end-transaction ,db))))) diff --git a/sql/usql.lisp b/sql/usql.lisp index 7a7420c..472de2d 100644 --- a/sql/usql.lisp +++ b/sql/usql.lisp @@ -2,7 +2,7 @@ ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; -;;;; Name: usql.cl +;;;; Name: usql.lisp ;;;; Purpose: High-level interface to SQL driver routines needed for ;;;; UncommonSQL ;;;; Programmers: Kevin M. Rosenberg and onShore Development Inc @@ -10,7 +10,7 @@ ;;;; ;;;; $Id$ ;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; This file, part of CLSQL, is Copyright (c) 2002-2004 by Kevin M. Rosenberg ;;;; and onShore Development Inc ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software @@ -21,16 +21,14 @@ ;;; Minimal high-level routines to enable low-level interface for USQL -(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) -(in-package :clsql-sys) +(in-package #:clsql-sys) -(defun list-tables (&key (database *default-database*) - (system-tables nil)) +(defun list-tables (&key (database *default-database*)) "List all tables in *default-database*, or if the :database keyword arg is given, the specified database. If the keyword arg :system-tables is true, then it will not filter out non-user tables. Table names are given back as a list of strings." - (database-list-tables database :system-tables system-tables)) + (database-list-tables database)) (defun list-attributes (table &key (database *default-database*)) diff --git a/usql-tests/package.lisp b/usql-tests/package.lisp new file mode 100644 index 0000000..aa44d8b --- /dev/null +++ b/usql-tests/package.lisp @@ -0,0 +1,28 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: package.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 12:00:14 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Package definition for CLSQL-USQL test suite. +;;;; +;;;; ====================================================================== + + +(in-package :cl-user) + +(eval-when (:compile-toplevel :load-toplevel :execute) + +(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.")) + +); eval-when + diff --git a/usql-tests/test-connection.lisp b/usql-tests/test-connection.lisp new file mode 100644 index 0000000..7680917 --- /dev/null +++ b/usql-tests/test-connection.lisp @@ -0,0 +1,24 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-connection.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:53:49 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for CLSQL-USQL database connections. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + + +(deftest :connection/1 + (let ((database (usql:find-database + (usql:database-name usql:*default-database*) + :db-type (usql:database-type usql:*default-database*)))) + (eql (usql:database-type database) *test-database-type*)) + t) diff --git a/usql-tests/test-fddl.lisp b/usql-tests/test-fddl.lisp new file mode 100644 index 0000000..848bc84 --- /dev/null +++ b/usql-tests/test-fddl.lisp @@ -0,0 +1,211 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-fddl.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:53:29 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Functional Data Definition Language +;;;; (FDDL). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + +;; list current tables +(deftest :fddl/table/1 + (apply #'values + (sort (mapcar #'string-downcase + (usql:list-tables :owner *test-database-user*)) + #'string>)) + "usql_object_v" "employee" "company") + +;; create a table, test for its existence, drop it and test again +(deftest :fddl/table/2 + (progn (usql:create-table [foo] + '(([id] integer) + ([height] float) + ([name] (string 24)) + ([comments] longchar))) + (values + (usql:table-exists-p [foo] :owner *test-database-user*) + (progn + (usql:drop-table [foo] :if-does-not-exist :ignore) + (usql:table-exists-p [foo] :owner *test-database-user*)))) + t nil) + +;; create a table, list its attributes and drop it +(deftest :fddl/table/3 + (apply #'values + (progn (usql:create-table [foo] + '(([id] integer) + ([height] float) + ([name] (char 255)) + ([comments] longchar))) + (prog1 + (sort (mapcar #'string-downcase + (usql:list-attributes [foo])) + #'string<) + (usql:drop-table [foo] :if-does-not-exist :ignore)))) + "comments" "height" "id" "name") + +(deftest :fddl/attributes/1 + (apply #'values + (sort + (mapcar #'string-downcase + (usql:list-attributes [employee] + :owner *test-database-user*)) + #'string<)) + "birthday" "companyid" "email" "emplid" "first_name" "groupid" "height" + "last_name" "managerid" "married") + +(deftest :fddl/attributes/2 + (apply #'values + (sort + (mapcar #'(lambda (a) (string-downcase (car a))) + (usql:list-attribute-types [employee] + :owner *test-database-user*)) + #'string<)) + "birthday" "companyid" "email" "emplid" "first_name" "groupid" "height" + "last_name" "managerid" "married") + +;; create a view, test for existence, drop it and test again +(deftest :fddl/view/1 + (progn (usql:create-view [lenins-group] + ;;not in sqlite + ;;:column-list '([forename] [surname] [email]) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (values + (usql:view-exists-p [lenins-group] :owner *test-database-user*) + (progn + (usql:drop-view [lenins-group] :if-does-not-exist :ignore) + (usql:view-exists-p [lenins-group] :owner *test-database-user*)))) + t nil) + +;; create a view, list its attributes and drop it +(deftest :fddl/view/2 + (progn (usql:create-view [lenins-group] + ;;not in sqlite + ;;:column-list '([forename] [surname] [email]) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (prog1 + (sort (mapcar #'string-downcase + (usql:list-attributes [lenins-group])) + #'string<) + (usql:drop-view [lenins-group] :if-does-not-exist :ignore))) + ("email" "first_name" "last_name")) + +;; create a view, select stuff from it and drop it +(deftest :fddl/view/3 + (progn (usql:create-view [lenins-group] + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (let ((result + (list + ;; Shouldn't exist + (usql:select [first-name] [last-name] [email] + :from [lenins-group] + :where [= [last-name] "Lenin"]) + ;; Should exist + (car (usql:select [first-name] [last-name] [email] + :from [lenins-group] + :where [= [last-name] "Stalin"]))))) + (usql:drop-view [lenins-group] :if-does-not-exist :ignore) + (apply #'values result))) + nil ("Josef" "Stalin" "stalin@soviet.org")) + +;; not in sqlite +(deftest :fddl/view/4 + (if (eql *test-database-type* :sqlite) + (values nil '(("Josef" "Stalin" "stalin@soviet.org"))) + (progn (usql:create-view [lenins-group] + :column-list '([forename] [surname] [email]) + :as [select [first-name] [last-name] [email] + :from [employee] + :where [= [managerid] 1]]) + (let ((result + (list + ;; Shouldn't exist + (usql:select [forename] [surname] [email] + :from [lenins-group] + :where [= [surname] "Lenin"]) + ;; Should exist + (car (usql:select [forename] [surname] [email] + :from [lenins-group] + :where [= [surname] "Stalin"]))))) + (usql:drop-view [lenins-group] :if-does-not-exist :ignore) + (apply #'values result)))) + nil ("Josef" "Stalin" "stalin@soviet.org")) + +;; create an index, test for existence, drop it and test again +(deftest :fddl/index/1 + (progn (usql:create-index [bar] :on [employee] :attributes + '([first-name] [last-name] [email]) :unique t) + (values + (usql:index-exists-p [bar] :owner *test-database-user*) + (progn + (case *test-database-type* + (:mysql + (usql:drop-index [bar] :on [employee] + :if-does-not-exist :ignore)) + (t + (usql:drop-index [bar]:if-does-not-exist :ignore))) + (usql:view-exists-p [bar] :owner *test-database-user*)))) + t nil) + +;; create indexes with names as strings, symbols and in square brackets +(deftest :fddl/index/2 + (let ((names '("foo" foo [foo])) + (result '())) + (dolist (name names) + (usql:create-index name :on [employee] :attributes '([emplid])) + (push (usql:index-exists-p name :owner *test-database-user*) result) + (case *test-database-type* + (:mysql + (usql:drop-index name :on [employee] :if-does-not-exist :ignore)) + (t (usql:drop-index name :if-does-not-exist :ignore)))) + (apply #'values result)) + t t t) + +;; create an sequence, test for existence, drop it and test again +(deftest :fddl/sequence/1 + (progn (usql:create-sequence [foo]) + (values + (usql:sequence-exists-p [foo] :owner *test-database-user*) + (progn + (usql:drop-sequence [foo] :if-does-not-exist :ignore) + (usql:sequence-exists-p [foo] :owner *test-database-user*)))) + t nil) + +;; create and increment a sequence +(deftest :fddl/sequence/2 + (let ((val1 nil)) + (usql:create-sequence [foo]) + (setf val1 (usql:sequence-next [foo])) + (prog1 + (< val1 (usql:sequence-next [foo])) + (usql:drop-sequence [foo] :if-does-not-exist :ignore))) + t) + +;; explicitly set the value of a sequence +(deftest :fddl/sequence/3 + (progn + (usql:create-sequence [foo]) + (usql:set-sequence-position [foo] 5) + (prog1 + (usql:sequence-next [foo]) + (usql:drop-sequence [foo] :if-does-not-exist :ignore))) + 6) + +#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file diff --git a/usql-tests/test-fdml.lisp b/usql-tests/test-fdml.lisp new file mode 100644 index 0000000..e24bbc6 --- /dev/null +++ b/usql-tests/test-fdml.lisp @@ -0,0 +1,395 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-fdml.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:52:39 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Functional Data Manipulation Language +;;;; (FDML). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + +;; inserts a record using all values only and then deletes it +(deftest :fdml/insert/1 + (progn + (usql:insert-records :into [employee] + :values `(11 1 "Yuri" "Gagarin" "gagarin@soviet.org" + 1 1 1.85 t ,(usql: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) \ No newline at end of file diff --git a/usql-tests/test-init.lisp b/usql-tests/test-init.lisp new file mode 100644 index 0000000..67ad1e9 --- /dev/null +++ b/usql-tests/test-init.lisp @@ -0,0 +1,310 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-init.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 12:14:38 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Initialisation utilities for running regression tests on CLSQL-USQL. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +(defvar *test-database-type* nil) +(defvar *test-database-server* "") +(defvar *test-database-name* "") +(defvar *test-database-user* "") +(defvar *test-database-password* "") + +(defclass thing () + ((extraterrestrial :initform nil :initarg :extraterrestrial))) + +(def-view-class person (thing) + ((height :db-kind :base :accessor height :type float :nulls-ok t + :initarg :height) + (married :db-kind :base :accessor married :type boolean :nulls-ok t + :initarg :married) + (birthday :nulls-ok t :type 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 (usql: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 (usql: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 (usql: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 (usql: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 (usql: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 (usql: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 (usql: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 (usql: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 (usql: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 (usql: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)) + +(defun test-initialise-database () + ;; Delete the instance records + (ignore-errors + (usql:delete-instance-records company1) + (usql:delete-instance-records employee1) + (usql:delete-instance-records employee2) + (usql:delete-instance-records employee3) + (usql:delete-instance-records employee4) + (usql:delete-instance-records employee5) + (usql:delete-instance-records employee6) + (usql:delete-instance-records employee7) + (usql:delete-instance-records employee8) + (usql:delete-instance-records employee9) + (usql:delete-instance-records employee10) + ;; Drop the required tables if they exist + (usql:drop-view-from-class 'employee) + (usql:drop-view-from-class 'company)) + ;; Create the tables for our view classes + (usql:create-view-from-class 'employee) + (usql:create-view-from-class 'company) + ;; Lenin manages everyone + (usql:add-to-relation employee2 'manager employee1) + (usql:add-to-relation employee3 'manager employee1) + (usql:add-to-relation employee4 'manager employee1) + (usql:add-to-relation employee5 'manager employee1) + (usql:add-to-relation employee6 'manager employee1) + (usql:add-to-relation employee7 'manager employee1) + (usql:add-to-relation employee8 'manager employee1) + (usql:add-to-relation employee9 'manager employee1) + (usql:add-to-relation employee10 'manager employee1) + ;; Everyone works for Widgets Inc. + (usql:add-to-relation company1 'employees employee1) + (usql:add-to-relation company1 'employees employee2) + (usql:add-to-relation company1 'employees employee3) + (usql:add-to-relation company1 'employees employee4) + (usql:add-to-relation company1 'employees employee5) + (usql:add-to-relation company1 'employees employee6) + (usql:add-to-relation company1 'employees employee7) + (usql:add-to-relation company1 'employees employee8) + (usql:add-to-relation company1 'employees employee9) + (usql:add-to-relation company1 'employees employee10) + ;; Lenin is president of Widgets Inc. + (usql:add-to-relation company1 'president employee1) + ;; store these instances + (usql:update-records-from-instance employee1) + (usql:update-records-from-instance employee2) + (usql:update-records-from-instance employee3) + (usql:update-records-from-instance employee4) + (usql:update-records-from-instance employee5) + (usql:update-records-from-instance employee6) + (usql:update-records-from-instance employee7) + (usql:update-records-from-instance employee8) + (usql:update-records-from-instance employee9) + (usql:update-records-from-instance employee10) + (usql:update-records-from-instance company1)) + +(defun test-usql (backend) + (format t "~&Running CLSQL-USQL tests with ~A backend.~%" backend) + (test-connect-to-database backend) + (test-initialise-database) + (rtest:do-tests)) + + + diff --git a/usql-tests/test-ooddl.lisp b/usql-tests/test-ooddl.lisp new file mode 100644 index 0000000..cabf06a --- /dev/null +++ b/usql-tests/test-ooddl.lisp @@ -0,0 +1,87 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-ooddl.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:52:11 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Object Oriented Data Definition Language +;;;; (OODDL). +;;;; +;;;; ====================================================================== + + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + +;; Ensure slots inherited from standard-classes are :virtual +(deftest :ooddl/metaclass/1 + (values + (usql-sys::view-class-slot-db-kind + (usql-sys::slotdef-for-slot-with-class 'extraterrestrial + (find-class 'person))) + (usql-sys::view-class-slot-db-kind + (usql-sys::slotdef-for-slot-with-class 'hobby (find-class 'person)))) + :virtual :virtual) + +;; Ensure all slots in view-class are view-class-effective-slot-definition +(deftest :ooddl/metaclass/2 + (values + (every #'(lambda (slotd) + (typep slotd 'usql-sys::view-class-effective-slot-definition)) + (usql-sys::class-slots (find-class 'person))) + (every #'(lambda (slotd) + (typep slotd 'usql-sys::view-class-effective-slot-definition)) + (usql-sys::class-slots (find-class 'employee))) + (every #'(lambda (slotd) + (typep slotd 'usql-sys::view-class-effective-slot-definition)) + (usql-sys::class-slots (find-class 'company)))) + t t t) + +(deftest :ooddl/join/1 + (mapcar #'(lambda (e) + (slot-value e 'companyid)) + (company-employees company1)) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :ooddl/join/2 + (slot-value (president company1) 'last-name) + "Lenin") + +(deftest :ooddl/join/3 + (slot-value (employee-manager employee2) 'last-name) + "Lenin") + +(deftest :ooddl/time/1 + (let* ((now (usql: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) + (usql:time= (slot-value dbobj 'birthday) now)))) + "Lenin" t) + +(deftest :ooddl/time/2 + (let* ((now (usql: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 (usql:time= (slot-value dbobj 'birthday) now) + (setf fail-index x)) + (setf now (usql:roll now :day (* 10 x))))) + fail-index) + -1) + +#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file diff --git a/usql-tests/test-oodml.lisp b/usql-tests/test-oodml.lisp new file mode 100644 index 0000000..f0cd3b0 --- /dev/null +++ b/usql-tests/test-oodml.lisp @@ -0,0 +1,241 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-oodml.lisp +;;;; Author: Marcus Pearce +;;;; Created: 01/04/2004 +;;;; Updated: <04/04/2004 11:51:23 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Object Oriented Data Definition Language +;;;; (OODML). +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + +(deftest :oodml/select/1 + (mapcar #'(lambda (e) (slot-value e 'last-name)) + (usql:select 'employee :order-by [last-name])) + ("Andropov" "Brezhnev" "Chernenko" "Gorbachev" "Kruschev" "Lenin" "Putin" + "Stalin" "Trotsky" "Yeltsin")) + +(deftest :oodml/select/2 + (mapcar #'(lambda (e) (slot-value e 'name)) + (usql:select 'company)) + ("Widgets Inc.")) + +(deftest :oodml/select/3 + (mapcar #'(lambda (e) (slot-value e 'companyid)) + (usql:select 'employee + :where [and [= [slot-value 'employee 'companyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]])) + (1 1 1 1 1 1 1 1 1 1)) + +(deftest :oodml/select/4 + (mapcar #'(lambda (e) + (concatenate 'string (slot-value e 'first-name) + " " + (slot-value e 'last-name))) + (usql:select 'employee :where [= [slot-value 'employee 'first-name] + "Vladamir"] + :order-by [last-name])) + ("Vladamir Lenin" "Vladamir Putin")) + +;; sqlite fails this because it is typeless +(deftest :oodml/select/5 + (length (sql:select 'employee :where [married])) + 3) + +;; tests update-records-from-instance +(deftest :oodml/update-records/1 + (values + (progn + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (usql:update-records-from-instance employee1) + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Vladamir" + (slot-value employee1 'last-name) "Lenin" + (slot-value employee1 'email) "lenin@soviet.org") + (usql:update-records-from-instance employee1) + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))))) + "Vladamir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org" + "Vladamir Lenin: lenin@soviet.org") + +;; tests update-record-from-slot +(deftest :oodml/update-records/2 + (values + (employee-email + (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] 1]))) + (progn + (setf (slot-value employee1 'email) "lenin-nospam@soviet.org") + (usql:update-record-from-slot employee1 'email) + (employee-email + (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] 1])))) + (progn + (setf (slot-value employee1 'email) "lenin@soviet.org") + (usql:update-record-from-slot employee1 'email) + (employee-email + (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] 1]))))) + "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") + +;; tests update-record-from-slots +(deftest :oodml/update-records/3 + (values + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))) + (progn + (setf (slot-value employee1 'first-name) "Dimitriy" + (slot-value employee1 'last-name) "Ivanovich" + (slot-value employee1 'email) "ivanovich@soviet.org") + (usql:update-record-from-slots employee1 '(first-name last-name email)) + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin)))) + (progn + (setf (slot-value employee1 'first-name) "Vladamir" + (slot-value employee1 'last-name) "Lenin" + (slot-value employee1 'email) "lenin@soviet.org") + (usql:update-record-from-slots employee1 '(first-name last-name email)) + (let ((lenin (car (usql:select 'employee + :where [= [slot-value 'employee 'emplid] + 1])))) + (concatenate 'string + (first-name lenin) + " " + (last-name lenin) + ": " + (employee-email lenin))))) + "Vladamir Lenin: lenin@soviet.org" + "Dimitriy Ivanovich: ivanovich@soviet.org" + "Vladamir Lenin: lenin@soviet.org") + +;; tests update-instance-from-records +(deftest :oodml/update-instance/1 + (values + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email)) + (progn + (usql:update-records [employee] + :av-pairs '(([first-name] "Ivan") + ([last-name] "Petrov") + ([email] "petrov@soviet.org")) + :where [= [emplid] 1]) + (usql:update-instance-from-records employee1) + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email))) + (progn + (usql:update-records [employee] + :av-pairs '(([first-name] "Vladamir") + ([last-name] "Lenin") + ([email] "lenin@soviet.org")) + :where [= [emplid] 1]) + (usql:update-instance-from-records employee1) + (concatenate 'string + (slot-value employee1 'first-name) + " " + (slot-value employee1 'last-name) + ": " + (slot-value employee1 'email)))) + "Vladamir Lenin: lenin@soviet.org" + "Ivan Petrov: petrov@soviet.org" + "Vladamir Lenin: lenin@soviet.org") + +;; tests update-slot-from-record +(deftest :oodml/update-instance/2 + (values + (slot-value employee1 'email) + (progn + (usql:update-records [employee] + :av-pairs '(([email] "lenin-nospam@soviet.org")) + :where [= [emplid] 1]) + (usql:update-slot-from-record employee1 'email) + (slot-value employee1 'email)) + (progn + (usql:update-records [employee] + :av-pairs '(([email] "lenin@soviet.org")) + :where [= [emplid] 1]) + (usql:update-slot-from-record employee1 'email) + (slot-value employee1 'email))) + "lenin@soviet.org" "lenin-nospam@soviet.org" "lenin@soviet.org") + + +;(deftest :oodml/iteration/1 +; (usql:do-query ((e) [select 'usql-tests::employee :where [married] +; :order-by [emplid]]) +; (slot-value e last-name)) +; ("Lenin" "Stalin" "Trotsky")) + +;(deftest :oodml/iteration/2 +; (usql:map-query 'list #'last-name [select 'employee :where [married] +; :order-by [emplid]]) +; ("Lenin" "Stalin" "Trotsky")) + +;(deftest :oodml/iteration/3 +; (loop for (e) being the tuples in +; [select 'employee :where [married] :order-by [emplid]] +; collect (slot-value e 'last-name)) +; ("Lenin" "Stalin" "Trotsky")) + + +#.(usql:restore-sql-reader-syntax-state) diff --git a/usql-tests/test-syntax.lisp b/usql-tests/test-syntax.lisp new file mode 100644 index 0000000..e71d863 --- /dev/null +++ b/usql-tests/test-syntax.lisp @@ -0,0 +1,162 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: test-syntax.lisp +;;;; Author: Marcus Pearce +;;;; Created: 30/03/2004 +;;;; Updated: <04/04/2004 11:51:40 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Tests for the CLSQL-USQL Symbolic SQL syntax. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-tests) + +#.(usql:locally-enable-sql-reader-syntax) + + +(deftest :syntax/generic/1 + (usql:sql "foo") + "'foo'") + +(deftest :syntax/generic/2 + (usql:sql 23) + "23") + +(deftest :syntax/generic/3 + (usql:sql 'bar) + "BAR") + +(deftest :syntax/generic/4 + (usql:sql '("ten" 10 ten)) + "('ten',10,TEN)") + +(deftest :syntax/generic/5 + (usql:sql ["SELECT FOO,BAR FROM BAZ"]) + "SELECT FOO,BAR FROM BAZ") + + +(deftest :syntax/ident/1 + (usql:sql [foo]) + "FOO") + +(deftest :syntax/ident/2 + (usql:sql [foo bar]) + "FOO.BAR") + +;; not sure about this one +(deftest :syntax/ident/3 + (usql:sql ["foo" bar]) + "foo.BAR") + +;(deftest :syntax/ident/4 +; (usql:sql [foo "bar"]) +; "FOO \"bar\"") + +(deftest :syntax/ident/5 + (usql:sql [foo :integer]) + "FOO INTEGER") + +(deftest :syntax/ident/6 + (usql:sql [foo bar :integer]) + "FOO.BAR INTEGER") + +;; not sure about this one +(deftest :syntax/ident/7 + (usql:sql ["foo" bar :integer]) + "foo.BAR INTEGER") + + +(deftest :syntax/value/1 + (usql:sql [any '(3 4)]) + "(ANY ((3,4)))") + +(deftest :syntax/value/2 + (usql:sql [* 2 3]) + "(2 * 3)") + + +(deftest :syntax/relational/1 + (usql:sql [> [baz] [beep]]) + "(BAZ > BEEP)") + +(deftest :syntax/relational/2 + (let ((x 10)) + (usql:sql [> [foo] x])) + "(FOO > 10)") + + +(deftest :syntax/function/1 + (usql:sql [function "COS" [age]]) + "COS(AGE)") + +(deftest :syntax/function/2 + (usql:sql [function "TO_DATE" "02/06/99" "mm/DD/RR"]) + "TO_DATE('02/06/99','mm/DD/RR')") + +(deftest :syntax/query/1 + (usql:sql [select [person_id] [surname] :from [person]]) + "SELECT PERSON_ID,SURNAME FROM PERSON") + +(deftest :syntax/query/2 + (usql:sql [select [foo] [bar *] + :from '([baz] [bar]) + :where [or [= [foo] 3] + [> [baz.quux] 10]]]) + "SELECT FOO,BAR.* FROM BAZ,BAR WHERE ((FOO = 3) OR (BAZ.QUUX > 10))") + +(deftest :syntax/query/3 + (usql:sql [select [foo bar] [baz] + :from '([foo] [quux]) + :where [or [> [baz] 3] + [like [foo bar] "SU%"]]]) + "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))") + +(deftest :syntax/query/4 + (usql:sql [select [count [*]] :from [emp]]) + "SELECT COUNT(*) FROM EMP") + + +(deftest :syntax/expression1 + (usql:sql + (usql:sql-operation + 'select + (usql:sql-expression :table 'foo :attribute 'bar) + (usql:sql-expression :attribute 'baz) + :from (list + (usql:sql-expression :table 'foo) + (usql:sql-expression :table 'quux)) + :where + (usql:sql-operation 'or + (usql:sql-operation + '> + (usql:sql-expression :attribute 'baz) + 3) + (usql:sql-operation + 'like + (usql:sql-expression :table 'foo + :attribute 'bar) + "SU%")))) + "SELECT FOO.BAR,BAZ FROM FOO,QUUX WHERE ((BAZ > 3) OR (FOO.BAR LIKE 'SU%'))") + +(deftest :syntax/expression/2 + (usql:sql + (apply (usql:sql-operator 'and) + (loop for table in '(thistime nexttime sometime never) + for count from 42 + collect + [function "BETWEEN" + (usql:sql-expression :table table + :attribute 'bar) + (usql:sql-operation '* [hip] [hop]) + count] + collect + [like (usql:sql-expression :table table + :attribute 'baz) + (usql:sql table)]))) + "(BETWEEN(THISTIME.BAR,(HIP * HOP),42) AND (THISTIME.BAZ LIKE 'THISTIME') AND BETWEEN(NEXTTIME.BAR,(HIP * HOP),43) AND (NEXTTIME.BAZ LIKE 'NEXTTIME') AND BETWEEN(SOMETIME.BAR,(HIP * HOP),44) AND (SOMETIME.BAZ LIKE 'SOMETIME') AND BETWEEN(NEVER.BAR,(HIP * HOP),45) AND (NEVER.BAZ LIKE 'NEVER'))") + +#.(usql:restore-sql-reader-syntax-state) \ No newline at end of file diff --git a/usql/CONTRIBUTORS b/usql/CONTRIBUTORS new file mode 100644 index 0000000..fc0c0e9 --- /dev/null +++ b/usql/CONTRIBUTORS @@ -0,0 +1,22 @@ +This is a list of those individuals who have contributed in some way +or other to Uncommonsql. The sources of the attributions are CVS +annotation, patch submission, and original authorship, write us if +we've missed anybody. + +Jesse Bouwman + +Craig Brozefsky + +Sean Champ + +Matthew Danish + +Adam Di Carlo + +Lyn Headley + +John Krug + +Pierre Mai (original author) + +Christopher J. Vogt diff --git a/usql/COPYING b/usql/COPYING new file mode 100644 index 0000000..59644a1 --- /dev/null +++ b/usql/COPYING @@ -0,0 +1,84 @@ +This document contains the copyright notices distributed with: + + o UncommonSQL + o CLSQL + o MaiSQL + +from which this software was derived. + + +UncommonSQL ================================================================ +============================================================================ + +Copyright (c) 1999 - 2003 onShore Development, Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +CLSQL ====================================================================== +============================================================================ + +CLSQL is written and Copyright (c) 2002 by Kevin M. Rosenberg and is +based on the MaiSQL package written and Copyright (c) 1999-2001 by +Pierre R. Mai. + +CLSQL is licensed under the terms of the Lisp Lesser GNU +Public License (http://opensource.franz.com/preamble.html), known as +the LLGPL. The LLGPL consists of a preamble (see above URL) and the +LGPL. Where these conflict, the preamble takes precedence. +CLSQL is referenced in the preamble as the "LIBRARY." + +CLSQL is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + +MaiSQL ===================================================================== +============================================================================ + + Copyright (C) 1999-2001 Pierre R. Mai + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + + Except as contained in this notice, the name of the author shall + not be used in advertising or otherwise to promote the sale, use or + other dealings in this Software without prior written authorization + from the author. diff --git a/usql/README b/usql/README new file mode 100644 index 0000000..c0ea747 --- /dev/null +++ b/usql/README @@ -0,0 +1,64 @@ +INTRODUCTIION + +CLSQL-USQL is a high level SQL interface for Common Lisp which is +based on the CommonSQL package from Xanalys. It was originally +developed at Onshore Development, Inc. based on Pierre Mai's MaiSQL +package. It now incorporates some of the code developed for CLSQL. See +the files CONTRIBUTORS and COPYING for more details. + +CLSQL-USQL depends on the low-level database interfaces provided by +CLSQL and includes both a functional and an object oriented +interface to SQL RDBMS. + +DOCUMENTATION + +A CLSQL-USQL tutorial can be found in the directory doc/ + +Also see the CommonSQL documentation avaialble on the Lispworks website: + +Xanalys LispWorks User Guide - The CommonSQL Package +http://www.lispworks.com/reference/lw43/LWUG/html/lwuser-167.htm + +Xanalys LispWorks Reference Manual -- The SQL Package +http://www.lispworks.com/reference/lw43/LWRM/html/lwref-383.htm + +CommonSQL Tutorial by Nick Levine +http://www.ravenbrook.com/doc/2002/09/13/common-sql/ + + +PREREQUISITES + + o COMMON LISP: currently CMUCL, SBCL, Lispworks + o RDBMS: currently Postgresql, Mysql, Sqlite + o ASDF (from http://cvs.sourceforge.net/viewcvs.py/cclan/asdf/) + o CLSQL-2.0.0 or later (from http://clsql.b9.com) + o RT for running the test suite (from http://files.b9.com/rt/rt.tar.gz) + + +INSTALLATION + +Just load clsql-usql.asd or put it somewhere where ASDF can find it +and call: + +(asdf:oos 'asdf:load-op :clsql-usql) + +You'll then need to load a CLSQL backend before you can do anything. + +To run the regression tests load clsql-usql-tests.asd or put it +somewhere where ASDF can find it, edit the file tests/test-init.lisp +and set the following variables to appropriate values: + + *test-database-server* + *test-database-name* + *test-database-user* + *test-database-password* + +And then call: + +(asdf:oos 'asdf:load-op :clsql-usql-tests) +(usql-tests:test-usql BACKEND) + +where BACKEND is the CLSQL database interface to use (currently one of +:postgresql, :postgresql-socket, :sqlite or :mysql). + + diff --git a/usql/TODO b/usql/TODO new file mode 100644 index 0000000..cedc464 --- /dev/null +++ b/usql/TODO @@ -0,0 +1,101 @@ + +GENERAL + +* test on (and port to) sbcl, lispworks, acl, scl, mcl and openmcl; +* implement remaining functions for CLSQL AODBC backend; +* port UncommonSQL ODBC and Oracle backends to CLSQL. + + +COMMONSQL SPEC + +* Missing: + + RECONNECT + CACHE-TABLE-QUERIES + *CACHE-TABLE-QUERIES-DEFAULT* + *DEFAULT-UPDATE-OBJECTS-MAX-LEN* + UPDATE-OBJECT-JOINS + INSTANCE-REFRESHED + + +* Incompatible + + + >> Initialisation and connection + + CONNECT + o should accept string as connection spec + + DISCONNECT + o should accept string as connection spec + + INITIALIZE-DATABASE-TYPE + o should initialise appropriate backend + + STATUS + o what is the behaviour in CommonSQL (esp :full parameter)? + + + >> The functional sql interface + + SELECT + o should accept keyword arg :refresh and call INSTANCE-REFRESHED + o should return (values result-list field-names) + o should coerce values returned as strings to appropriate lisp type + + QUERY + o should return (values result-list field-names) + o should coerce values returned as strings to appropriate lisp type + + LIST-ATTRIBUTE-TYPES + o should return list of (attribute datatype precision scale nullable) + + LOOP + o the extension is currently CMUCL specific + + + >> The object-oriented sql interface + + DEF-VIEW-CLASS + o get :target-slot working + o implement :retrieval :immediate + + LIST-CLASSES + o keyword arg :root-class should do something (portable) + + DO-QUERY,MAP-QUERY,LOOP + o should work with object queries as well as functional ones + + + >> Symbolic SQL syntax + + o Complete sql expressions (see operations.lisp) + + substr + some + order-by + times + nvl + null + distinct + except + intersect + between + userenv + + o variables (e.g., table identifiers) should be instantiated at runtime + + + +NOTES ABOUT THE BACKENDS + +MYSQL + +drop-index: requires a table to be specified with the :from keyword parameter +transactions: don't seem to work +views: mysql does not support views +queries: nested subqueries do not seem to work + +SQLITE + +create-view: column-list parameter not supported diff --git a/usql/basic-cmds.lisp b/usql/basic-cmds.lisp new file mode 100644 index 0000000..a8241b9 --- /dev/null +++ b/usql/basic-cmds.lisp @@ -0,0 +1,32 @@ + +(defmethod database-query (query-expression (database closed-database) types) + (declare (ignore query-expression types)) + (signal-closed-database-error database)) + +(defmethod database-query (query-expression (database t) types) + (declare (ignore query-expression types)) + (signal-no-database-error)) + +(defmethod database-execute-command (sql-expression (database closed-database)) + (declare (ignore sql-expression)) + (signal-closed-database-error database)) + +(defmethod database-execute-command (sql-expression (database t)) + (declare (ignore sql-expression)) + (signal-no-database-error)) + +(defgeneric execute-command (expression &key database) + (:documentation + "Executes the SQL command specified by EXPRESSION for the database +specified by DATABASE, which has a default value of +*DEFAULT-DATABASE*. The argument EXPRESSION may be any SQL statement +other than a query. To run a stored procedure, pass an appropriate +string. The call to the procedure needs to be wrapped in a BEGIN END +pair.")) + +(defmethod execute-command ((sql-expression string) + &key (database *default-database*)) + (record-sql-command sql-expression database) + (let ((res (database-execute-command sql-expression database))) + (record-sql-result res database)) + (values)) diff --git a/usql/classes.lisp b/usql/classes.lisp new file mode 100644 index 0000000..7a11ddb --- /dev/null +++ b/usql/classes.lisp @@ -0,0 +1,740 @@ +;;;; -*- 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 *default-database* nil + "Specifies the default database to be used.") + +(defvar +empty-string+ "''") + +(defvar +null-string+ "NULL") + +(defvar *sql-stream* nil + "stream which accumulates SQL output") + +(defvar *default-schema* "UNCOMMONSQL") + +(defvar *object-schemas* (make-hash-table :test #'equal) + "Hash of schema name to class constituent lists.") + +(defun in-schema (schemaname) + (setf *default-schema* schemaname)) + +(defun sql-output (sql-expr &optional database) + (progv '(*sql-stream*) + `(,(make-string-output-stream)) + (output-sql sql-expr database) + (get-output-stream-string *sql-stream*))) + + +(defclass %sql-expression () + ()) + +(defmethod output-sql ((expr %sql-expression) &optional + (database *default-database*)) + (declare (ignore database)) + (write-string +null-string+ *sql-stream*)) + +(defmethod print-object ((self %sql-expression) stream) + (print-unreadable-object + (self stream :type t) + (write-string (sql-output self) stream))) + +;; For straight up strings + +(defclass sql (%sql-expression) + ((text + :initarg :string + :initform "")) + (:documentation "A literal SQL expression.")) + +(defmethod make-load-form ((sql sql) &optional environment) + (declare (ignore environment)) + (with-slots (text) + sql + `(make-instance 'sql :string ',text))) + +(defmethod output-sql ((expr sql) &optional (database *default-database*)) + (declare (ignore database)) + (write-string (slot-value expr 'text) *sql-stream*) + t) + +(defmethod print-object ((ident sql) stream) + (format stream "#<~S \"~A\">" + (type-of ident) + (sql-output ident))) + +;; For SQL Identifiers of generic type +(defclass sql-ident (%sql-expression) + ((name + :initarg :name + :initform "NULL")) + (:documentation "An SQL identifer.")) + +(defmethod make-load-form ((sql sql-ident) &optional environment) + (declare (ignore environment)) + (with-slots (name) + sql + `(make-instance 'sql-ident :name ',name))) + +(defvar *output-hash* (make-hash-table :test #'equal)) + +(defmethod output-sql-hash-key (expr &optional (database *default-database*)) + (declare (ignore expr database)) + nil) + +(defmethod output-sql :around ((sql t) &optional (database *default-database*)) + (declare (ignore database)) + (let* ((hash-key (output-sql-hash-key sql)) + (hash-value (when hash-key (gethash hash-key *output-hash*)))) + (cond ((and hash-key hash-value) + (write-string hash-value *sql-stream*)) + (hash-key + (let ((*sql-stream* (make-string-output-stream))) + (call-next-method) + (setf hash-value (get-output-stream-string *sql-stream*)) + (setf (gethash hash-key *output-hash*) hash-value)) + (write-string hash-value *sql-stream*)) + (t + (call-next-method))))) + +(defmethod output-sql ((expr sql-ident) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (name) + expr + (etypecase name + (string + (write-string name *sql-stream*)) + (symbol + (write-string (symbol-name name) *sql-stream*))) + t)) + +;; For SQL Identifiers for attributes + +(defclass sql-ident-attribute (sql-ident) + ((qualifier + :initarg :qualifier + :initform "NULL") + (type + :initarg :type + :initform "NULL") + (params + :initarg :params + :initform nil)) + (:documentation "An SQL Attribute identifier.")) + +(defmethod collect-table-refs (sql) + (declare (ignore sql)) + nil) + +(defmethod collect-table-refs ((sql sql-ident-attribute)) + (let ((qual (slot-value sql 'qualifier))) + (if (and qual (symbolp (slot-value sql 'qualifier))) + (list (make-instance 'sql-ident-table :name + (slot-value sql 'qualifier)))))) + +(defmethod make-load-form ((sql sql-ident-attribute) &optional environment) + (declare (ignore environment)) + (with-slots (qualifier type name) + sql + `(make-instance 'sql-ident-attribute :name ',name + :qualifier ',qualifier + :type ',type))) + +(defmethod output-sql ((expr sql-ident-attribute) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (qualifier name type params) + expr + (if (and name (not qualifier) (not type)) + (write-string (sql-escape (symbol-name name)) *sql-stream*) + (format *sql-stream* "~@[~A.~]~A~@[ ~A~]" + (if qualifier (sql-escape qualifier) qualifier) + (sql-escape name) + type)) + t)) + +(defmethod output-sql-hash-key ((expr sql-ident-attribute) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (qualifier name type params) + expr + (list 'sql-ident-attribute qualifier name type params))) + +;; For SQL Identifiers for tables +(defclass sql-ident-table (sql-ident) + ((alias + :initarg :table-alias :initform nil)) + (:documentation "An SQL table identifier.")) + +(defmethod make-load-form ((sql sql-ident-table) &optional environment) + (declare (ignore environment)) + (with-slots (alias name) + sql + `(make-instance 'sql-ident-table :name name :alias ',alias))) + +(defun generate-sql (expr) + (let ((*sql-stream* (make-string-output-stream))) + (output-sql expr) + (get-output-stream-string *sql-stream*))) + +(defmethod output-sql ((expr sql-ident-table) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (name alias) + expr + (if (null alias) + (write-string (sql-escape (symbol-name name)) *sql-stream*) + (progn + (write-string (sql-escape (symbol-name name)) *sql-stream*) + (write-char #\Space *sql-stream*) + (format *sql-stream* "~s" alias)))) + t) + +(defmethod output-sql-hash-key ((expr sql-ident-table) &optional + (database *default-database*)) + (declare (ignore database)) + (with-slots (name alias) + expr + (list 'sql-ident-table name alias))) + +(defclass sql-relational-exp (%sql-expression) + ((operator + :initarg :operator + :initform nil) + (sub-expressions + :initarg :sub-expressions + :initform nil)) + (:documentation "An SQL relational expression.")) + +(defmethod collect-table-refs ((sql sql-relational-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'sub-expressions)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name)))))) + + + + +;; Write SQL for relational operators (like 'AND' and 'OR'). +;; should do arity checking of subexpressions + +(defmethod output-sql ((expr sql-relational-exp) &optional + (database *default-database*)) + (with-slots (operator sub-expressions) + expr + (let ((subs (if (consp (car sub-expressions)) + (car sub-expressions) + sub-expressions))) + (write-char #\( *sql-stream*) + (do ((sub subs (cdr sub))) + ((null (cdr sub)) (output-sql (car sub) database)) + (output-sql (car sub) database) + (write-char #\Space *sql-stream*) + (output-sql operator database) + (write-char #\Space *sql-stream*)) + (write-char #\) *sql-stream*))) + t) + +(defclass sql-upcase-like (sql-relational-exp) + () + (:documentation "An SQL 'like' that upcases its arguments.")) + +;; Write SQL for relational operators (like 'AND' and 'OR'). +;; should do arity checking of subexpressions + +(defmethod output-sql ((expr sql-upcase-like) &optional + (database *default-database*)) + (flet ((write-term (term) + (write-string "upper(" *sql-stream*) + (output-sql term database) + (write-char #\) *sql-stream*))) + (with-slots (sub-expressions) + expr + (let ((subs (if (consp (car sub-expressions)) + (car sub-expressions) + sub-expressions))) + (write-char #\( *sql-stream*) + (do ((sub subs (cdr sub))) + ((null (cdr sub)) (write-term (car sub))) + (write-term (car sub)) + (write-string " LIKE " *sql-stream*)) + (write-char #\) *sql-stream*)))) + t) + +(defclass sql-assignment-exp (sql-relational-exp) + () + (:documentation "An SQL Assignment expression.")) + + +(defmethod output-sql ((expr sql-assignment-exp) &optional + (database *default-database*)) + (with-slots (operator sub-expressions) + expr + (do ((sub sub-expressions (cdr sub))) + ((null (cdr sub)) (output-sql (car sub) database)) + (output-sql (car sub) database) + (write-char #\Space *sql-stream*) + (output-sql operator database) + (write-char #\Space *sql-stream*))) + t) + +(defclass sql-value-exp (%sql-expression) + ((modifier + :initarg :modifier + :initform nil) + (components + :initarg :components + :initform nil)) + (:documentation + "An SQL value expression.") + ) + +(defmethod collect-table-refs ((sql sql-value-exp)) + (let ((tabs nil)) + (if (listp (slot-value sql 'components)) + (progn + (dolist (exp (slot-value sql 'components)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name))))) + nil))) + + + +(defmethod output-sql ((expr sql-value-exp) &optional + (database *default-database*)) + (with-slots (modifier components) + expr + (if modifier + (progn + (write-char #\( *sql-stream*) + (output-sql modifier database) + (write-char #\Space *sql-stream*) + (output-sql components database) + (write-char #\) *sql-stream*)) + (output-sql components database)))) + +(defclass sql-typecast-exp (sql-value-exp) + () + (:documentation "An SQL typecast expression.")) + +(defmethod output-sql ((expr sql-typecast-exp) &optional + (database *default-database*)) + (database-output-sql expr database)) + +(defmethod database-output-sql ((expr sql-typecast-exp) database) + (with-slots (components) + expr + (output-sql components database))) + + +(defmethod collect-table-refs ((sql sql-typecast-exp)) + (when (slot-value sql 'components) + (collect-table-refs (slot-value sql 'components)))) + +(defclass sql-function-exp (%sql-expression) + ((name + :initarg :name + :initform nil) + (args + :initarg :args + :initform nil)) + (:documentation + "An SQL function expression.")) + +(defmethod collect-table-refs ((sql sql-function-exp)) + (let ((tabs nil)) + (dolist (exp (slot-value sql 'components)) + (let ((refs (collect-table-refs exp))) + (if refs (setf tabs (append refs tabs))))) + (remove-duplicates tabs + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name)))))) + +(defmethod output-sql ((expr sql-function-exp) &optional + (database *default-database*)) + (with-slots (name args) + expr + (output-sql name database) + (when args (output-sql args database))) + t) + +(defclass sql-query (%sql-expression) + ((selections + :initarg :selections + :initform nil) + (all + :initarg :all + :initform nil) + (flatp + :initarg :flatp + :initform nil) + (set-operation + :initarg :set-operation + :initform nil) + (distinct + :initarg :distinct + :initform nil) + (from + :initarg :from + :initform nil) + (where + :initarg :where + :initform nil) + (group-by + :initarg :group-by + :initform nil) + (having + :initarg :having + :initform nil) + (limit + :initarg :limit + :initform nil) + (offset + :initarg :offset + :initform nil) + (order-by + :initarg :order-by + :initform nil) + (order-by-descending + :initarg :order-by-descending + :initform nil)) + (:documentation "An SQL SELECT query.")) + +(defmethod collect-table-refs ((sql sql-query)) + (remove-duplicates (collect-table-refs (slot-value sql 'where)) + :test (lambda (tab1 tab2) + (equal (slot-value tab1 'name) + (slot-value tab2 'name))))) + +(defvar *select-arguments* + '(:all :database :distinct :flatp :from :group-by :having :order-by + :order-by-descending :set-operation :where :offset :limit)) + +(defun query-arg-p (sym) + (member sym *select-arguments*)) + +(defun query-get-selections (select-args) + "Return two values: the list of select-args up to the first keyword, +uninclusive, and the args from that keyword to the end." + (let ((first-key-arg (position-if #'query-arg-p select-args))) + (if first-key-arg + (values (subseq select-args 0 first-key-arg) + (subseq select-args first-key-arg)) + select-args))) + +(defmethod make-query (&rest args) + (multiple-value-bind (selections arglist) + (query-get-selections args) + (destructuring-bind (&key all flatp set-operation distinct from where + group-by having order-by order-by-descending + offset limit &allow-other-keys) + arglist + (if (null selections) + (error "No target columns supplied to select statement.")) + (if (null from) + (error "No source tables supplied to select statement.")) + (make-instance 'sql-query :selections selections + :all all :flatp flatp :set-operation set-operation + :distinct distinct :from from :where where + :limit limit :offset offset + :group-by group-by :having having :order-by order-by + :order-by-descending order-by-descending)))) + +(defvar *in-subselect* nil) + +(defmethod output-sql ((query sql-query) &optional + (database *default-database*)) + (with-slots (distinct selections from where group-by having order-by + order-by-descending limit offset) + query + (when *in-subselect* + (write-string "(" *sql-stream*)) + (write-string "SELECT " *sql-stream*) + (when distinct + (write-string "DISTINCT " *sql-stream*) + (unless (eql t distinct) + (write-string "ON " *sql-stream*) + (output-sql distinct database) + (write-char #\Space *sql-stream*))) + (output-sql (apply #'vector selections) database) + (write-string " FROM " *sql-stream*) + (if (listp from) + (output-sql (apply #'vector from) database) + (output-sql from database)) + (when where + (write-string " WHERE " *sql-stream*) + (let ((*in-subselect* t)) + (output-sql where database))) + (when group-by + (write-string " GROUP BY " *sql-stream*) + (output-sql group-by database)) + (when having + (write-string " HAVING " *sql-stream*) + (output-sql having database)) + (when order-by + (write-string " ORDER BY " *sql-stream*) + (if (listp order-by) + (do ((order order-by (cdr order))) + ((null order)) + (output-sql (car order) database) + (when (cdr order) + (write-char #\, *sql-stream*))) + (output-sql order-by database))) + (when order-by-descending + (write-string " ORDER BY " *sql-stream*) + (if (listp order-by-descending) + (do ((order order-by-descending (cdr order))) + ((null order)) + (output-sql (car order) database) + (when (cdr order) + (write-char #\, *sql-stream*))) + (output-sql order-by-descending database)) + (write-string " DESC " *sql-stream*)) + (when limit + (write-string " LIMIT " *sql-stream*) + (output-sql limit database)) + (when offset + (write-string " OFFSET " *sql-stream*) + (output-sql offset database)) + (when *in-subselect* + (write-string ")" *sql-stream*))) + t) + +;; INSERT + +(defclass sql-insert (%sql-expression) + ((into + :initarg :into + :initform nil) + (attributes + :initarg :attributes + :initform nil) + (values + :initarg :values + :initform nil) + (query + :initarg :query + :initform nil)) + (:documentation + "An SQL INSERT statement.")) + +(defmethod output-sql ((ins sql-insert) &optional + (database *default-database*)) + (with-slots (into attributes values query) + ins + (write-string "INSERT INTO " *sql-stream*) + (output-sql into database) + (when attributes + (write-char #\Space *sql-stream*) + (output-sql attributes database)) + (when values + (write-string " VALUES " *sql-stream*) + (output-sql values database)) + (when query + (write-char #\Space *sql-stream*) + (output-sql query database))) + t) + +;; DELETE + +(defclass sql-delete (%sql-expression) + ((from + :initarg :from + :initform nil) + (where + :initarg :where + :initform nil)) + (:documentation + "An SQL DELETE statement.")) + +(defmethod output-sql ((stmt sql-delete) &optional + (database *default-database*)) + (with-slots (from where) + stmt + (write-string "DELETE FROM " *sql-stream*) + (typecase from + (symbol (write-string (sql-escape from) *sql-stream*)) + (t (output-sql from database))) + (when where + (write-string " WHERE " *sql-stream*) + (output-sql where database))) + t) + +;; UPDATE + +(defclass sql-update (%sql-expression) + ((table + :initarg :table + :initform nil) + (attributes + :initarg :attributes + :initform nil) + (values + :initarg :values + :initform nil) + (where + :initarg :where + :initform nil)) + (:documentation "An SQL UPDATE statement.")) + +(defmethod output-sql ((expr sql-update) &optional + (database *default-database*)) + (with-slots (table where attributes values) + expr + (flet ((update-assignments () + (mapcar #'(lambda (a b) + (make-instance 'sql-assignment-exp + :operator '= + :sub-expressions (list a b))) + attributes values))) + (write-string "UPDATE " *sql-stream*) + (output-sql table database) + (write-string " SET " *sql-stream*) + (output-sql (apply #'vector (update-assignments)) database) + (when where + (write-string " WHERE " *sql-stream*) + (output-sql where database)))) + t) + +;; CREATE TABLE + +(defclass sql-create-table (%sql-expression) + ((name + :initarg :name + :initform nil) + (columns + :initarg :columns + :initform nil) + (modifiers + :initarg :modifiers + :initform nil)) + (:documentation + "An SQL CREATE TABLE statement.")) + +;; Here's a real warhorse of a function! + +(defun listify (x) + (if (atom x) + (list x) + x)) + +(defmethod output-sql ((stmt sql-create-table) &optional + (database *default-database*)) + (flet ((output-column (column-spec) + (destructuring-bind (name type &rest constraints) + column-spec + (let ((type (listify type))) + (output-sql name database) + (write-char #\Space *sql-stream*) + (write-string + (database-get-type-specifier (car type) (cdr type) database) + *sql-stream*) + (let ((constraints + (database-constraint-statement constraints database))) + (when constraints + (write-string " " *sql-stream*) + (write-string constraints *sql-stream*))))))) + (with-slots (name columns modifiers) + stmt + (write-string "CREATE TABLE " *sql-stream*) + (output-sql name database) + (write-string " (" *sql-stream*) + (do ((column columns (cdr column))) + ((null (cdr column)) + (output-column (car column))) + (output-column (car column)) + (write-string ", " *sql-stream*)) + (when modifiers + (do ((modifier (listify modifiers) (cdr modifier))) + ((null modifier)) + (write-string ", " *sql-stream*) + (write-string (car modifier) *sql-stream*))) + (write-char #\) *sql-stream*))) + t) + + +;; CREATE VIEW + +(defclass sql-create-view (%sql-expression) + ((name :initarg :name :initform nil) + (column-list :initarg :column-list :initform nil) + (query :initarg :query :initform nil) + (with-check-option :initarg :with-check-option :initform nil)) + (:documentation "An SQL CREATE VIEW statement.")) + +(defmethod output-sql ((stmt sql-create-view) &optional database) + (with-slots (name column-list query with-check-option) stmt + (write-string "CREATE VIEW " *sql-stream*) + (output-sql name database) + (when column-list (write-string " " *sql-stream*) + (output-sql (listify column-list) database)) + (write-string " AS " *sql-stream*) + (output-sql query database) + (when with-check-option (write-string " WITH CHECK OPTION" *sql-stream*)))) + + +;; +;; Column constraint types +;; +(defparameter *constraint-types* + '(("NOT-NULL" . "NOT NULL") + ("PRIMARY-KEY" . "PRIMARY KEY"))) + +;; +;; Convert type spec to sql syntax +;; + +(defmethod database-constraint-description (constraint database) + (declare (ignore database)) + (let ((output (assoc (symbol-name constraint) *constraint-types* + :test #'equal))) + (if (null output) + (error 'clsql-sql-syntax-error + :reason (format nil "unsupported column constraint '~a'" + constraint)) + (cdr output)))) + +(defmethod database-constraint-statement (constraint-list database) + (declare (ignore database)) + (make-constraints-description constraint-list)) + +(defun make-constraints-description (constraint-list) + (if constraint-list + (let ((string "")) + (do ((constraint constraint-list (cdr constraint))) + ((null constraint) string) + (let ((output (assoc (symbol-name (car constraint)) + *constraint-types* + :test #'equal))) + (if (null output) + (error 'clsql-sql-syntax-error + :reason (format nil "unsupported column constraint '~a'" + constraint)) + (setq string (concatenate 'string string (cdr output)))) + (if (< 1 (length constraint)) + (setq string (concatenate 'string string " ")))))))) + diff --git a/usql/doc/usql-tests.txt b/usql/doc/usql-tests.txt new file mode 100644 index 0000000..c20387a --- /dev/null +++ b/usql/doc/usql-tests.txt @@ -0,0 +1,110 @@ +* REGRESSION TEST SUITE GOALS + +The intent of this test suite is to provide sufficient coverage for +the system to support the following: + +** Refactoring and Redesign of particular subsystems + +Refactoring and redesign efforts are normally restricted to a single +subsystem, or perhaps to interdependent subsystems. In such cases, a +set of regression tests which excercise the existing interface of the +rest of USQL to the changing subsystems should be in place and passing +before the coding starts. + +** Ensuring portability and Supporting new ports. + +The more coverage the test suite provides the easier portability is to +maintain, particularly if we have instances of the test suite running +against the head on the supporting lisp environment/OS/hardware/DBMS +combinations. Since no individual within the project has the ability +to run all of those combinations themselves, we are dependent upon some +informal coordination between the mintainers of the various ports. + +** Adding new RDBMS backends + +The entire USQL DBMS interface needs to be excercised by the test +suite, such that a new RDBMS backend that passes all the tests can be +reasonably assured of working with the USQL layers above that. These +tests should also serve as impromptu documentation for the details of +that interface and what it expects frothe RDBMS driver layers. + +** Bug identification and QA + +As new bugs are identified, they should have a regression test written +which excercises them. This is to ensue that we donot start +backtracking. These tests by theselves are also very valuable for +developers, so even if you cannot fix a bug yourself, providing a +testto excercise it greatly reduces the amount of timea developer must +spend finding the bug prior to fixing it. + + +* TEST DESIGN ISSUES + +** Multiple RDBMS Issues + +USQL supports several RDBMS backends, and it should be possible to run +every test against all of them. However, there are some features +which we want tests for but which are not implemented on several of +the backends. + +** Test Hygiene + +Tests should be able to be run multiple times against the same +database. It is also important that they clean up after themselves +when they create tables, sequences or other pesistent entities in the +RDBMS backends, because often there are limits to the number of those +thatcan exist at one time, and it also makes debuging thru the SQL +monitors difficult when there aretons of unused tables lying around. + +If test need to load large datasets, they should have a mechanism to +ensure the dataset is loaded just once, and not with every test run. + +Lastly, because there are various idiosyncracies with RDBMSs, please +ensure that you run the entire test suite once when you write your +tests, to ensure that your test does not leave some state behind which +causes other tests to fail. + +** Test Run Configuration + +The file test-init.lisp defines several variables which can be used to +control the connection dictionary of the database against which tests +will be run. + + +* DATABASE CONNECTIONS/LIFECYCLE + +** CreateDB + *** Without existing DB + *** With existing DB and use old + *** With existing DB and use new + *** Error if existing DB + +** Data Definition + *** Create Tables/Sequences/Indexes -- Should cover creation of + tables with all supported types of fields. + *** Delete Tables/Sequences/Indexes + *** Inspection of Tables and attributes, including types + +** Data Manipulation + *** Update + *** Insert + *** Delete + *** Query + +** Functional Interface + *** Creation/Modification of SQL expressions + *** Querying + +** Embedded SQL syntax + *** Excercise all sql operators + +** Object Interface + *** View class definition + *** Object creation/manipulation/deletion + *** Inter-object Relations + +** Editing Contexts + *** Object Create/Modification/Deletion in a context -- partly covered already + *** Interaction of multiple contexts + *** Schema manipulation within a context + *** Rollback and error handling within a context \ No newline at end of file diff --git a/usql/doc/usql-tutorial.lisp b/usql/doc/usql-tutorial.lisp new file mode 100644 index 0000000..9c9b93f --- /dev/null +++ b/usql/doc/usql-tutorial.lisp @@ -0,0 +1,190 @@ + +(in-package :cl-user) + +;; You must set these variables to appropriate values. +(defvar *tutorial-database-type* nil + "Possible values are :postgresql,:postgresql-socket :mysql or :sqlite") +(defvar *tutorial-database-name* "" + "The name of the database we will work in.") +(defvar *tutorial-database-user* "" + "The name of the database user we will work as.") +(defvar *tutorial-database-server* "" + "The name of the database server if required") +(defvar *tutorial-database-password* "" + "The password if required") + +(sql:def-view-class employee () + ((emplid + :db-kind :key + :db-constraints :not-null + :nulls-ok nil + :type integer + :initarg :emplid) + (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)) + +(sql:def-view-class company () + ((companyid + :db-type :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (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 + :foreign-key companyid + :set t))) + (:base-table company)) + +;; Connect to the database (see the CLSQL documentation for vendor +;; specific connection specs). +(sql:connect `(,*tutorial-database-server* + ,*tutorial-database-name* + ,*tutorial-database-user* + ,*tutorial-database-password*) + :database-type *tutorial-database-type*) + +;; Record the sql going out, helps us learn what is going +;; on behind the scenes +(sql:start-sql-recording) + +;; Create the tables for our view classes +;; First we drop them, ignoring any errors +(ignore-errors + (sql:drop-view-from-class 'employee) + (sql:drop-view-from-class 'company)) + +(sql:create-view-from-class 'employee) +(sql:create-view-from-class 'company) + + +;; Create some instances of our view classes +(defvar employee1 (make-instance 'employee + :emplid 1 + :first-name "Vladamir" + :last-name "Lenin" + :email "lenin@soviet.org")) + +(defvar company1 (make-instance 'company + :companyid 1 + :name "Widgets Inc.")) + + +(defvar employee2 (make-instance 'employee + :emplid 2 + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org")) + +;; Lenin manages Stalin (for now) +(sql:add-to-relation employee2 'manager employee1) + +;; Lenin and Stalin both work for Widgets Inc. +(sql:add-to-relation company1 'employees employee1) +(sql:add-to-relation company1 'employees employee2) + +;; Lenin is president of Widgets Inc. +(sql:add-to-relation company1 'president employee1) + +(sql:update-records-from-instance employee1) +(sql:update-records-from-instance employee2) +(sql:update-records-from-instance company1) + +;; lets us use the functional +;; sql interface +(sql:locally-enable-sql-reader-syntax) + + +(format t "The email address of ~A ~A is ~A" + (first-name employee1) + (last-name employee1) + (employee-email employee1)) + +(setf (employee-email employee1) "lenin-nospam@soviets.org") + +;; Update the database +(sql:update-records-from-instance employee1) + +(let ((new-lenin (car + (sql:select 'employee + :where [= [slot-value 'employee 'emplid] 1])))) + (format t "His new email is ~A" + (employee-email new-lenin))) + + +;; Some queries + +;; all employees +(sql:select 'employee) +;; all companies +(sql:select 'company) + +;; employees named Lenin +(sql:select 'employee :where [= [slot-value 'employee 'last-name] + "Lenin"]) + +(sql:select 'company :where [= [slot-value 'company 'name] + "Widgets Inc."]) + +;; Employees of Widget's Inc. +(sql:select 'employee + :where [and [= [slot-value 'employee 'companyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]]) + +;; Same thing, except that we are using the employee +;; relation in the company view class to do the join for us, +;; saving us the work of writing out the SQL! +(company-employees company1) + +;; President of Widgets Inc. +(president company1) + +;; Manager of Josef Stalin +(employee-manager employee2) diff --git a/usql/doc/usql-tutorial.txt b/usql/doc/usql-tutorial.txt new file mode 100644 index 0000000..dcdeeb2 --- /dev/null +++ b/usql/doc/usql-tutorial.txt @@ -0,0 +1,509 @@ +INTRODUCTION + +The goal of this tutorial is to guide a new developer thru the process +of creating a set of USQL classes providing a Object-Oriented +interface to persistent data stored in an SQL database. We will +assume that the reader is familiar with how SQL works, how relations +(tables) should be structured, and has created at least one SQL +application previously. We will also assume a minor level of +experience with Common Lisp. + +UncommonSQL (USQL) provides two different interfaces to SQL databases, +a Functional interface, and an Object-Oriented interface. The +Functional interface consists of a special syntax for embedded SQL +expressions in Lisp, and provides lisp functions for SQL operations +like SELECT and UPDATE. The OO interface provides a way for mapping +Common Lisp Objects System (CLOS) objects into databases and includes +functions for inserting new objects, querying objects, and removing +objects. Most applications will use a combination of the two. + +USQL is based on the CommonSQL package from Xanalys, so the +documentation that Xanalys makes available online is useful for USQL +as well. It is suggested that developers new to USQL check their +documentation out, as any differences between CommonSQL and USQL are +minor. Xanalys makes the following documents available: + +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/ + + +DATA MODELING WITH UNCOMMONSQL + +Before we can create, query and manipulate USQL objects, we need to +define our data model. To borrow from Philip Greenspun[1]: + +When data modeling, you are telling the RDBMS the following: + + * What elements of the data you will store + * How large each element can be + * What kind of information each element can contain + * What elements may be left blank + * Which elements are constrained to a fixed range + * Whether and how various tables are to be linked + +With SQL database one would do this by defining a set of relations, or +tables, followed by a set of queries for joining the tables together +in order to construct complex records. However, with USQL we do this +by defining a set of CLOS classes, specifying how they will be turned +into tables, and how they can be joined to one another via relations +between their attributes. The SQL tables, as well as the queries for +joining them together are created for us automatically, saving us from +dealing with some of the tedium of SQL. + +Let us start with a simple example of two SQL tables, and the +relations between them. + +CREATE TABLE EMPLOYEE ( + emplid NOT NULL number(38), + first_name NOT NULL varchar2(30), + last_name NOT NULL varchar2(30), + emall varchar2(100), + companyid NOT NULL number(38), + managerid number(38) +) + +CREATE TABLE COMPANY ( + companyid NOT NULL number(38), + name NOT NULL varchar2(100), + presidentid NOT NULL number(38) +) + +This is of course the canonical SQL tutorial example, "The Org Chart". + +In USQL, we would have two "view classes" (a fancy word for a class +mapped into a database). They would be defined as follows: + +(sql:def-view-class employee () + ((emplid + :db-kind :key + :db-constraints :not-null + :type integer + :initarg :emplid) + (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) + (managerid + :type integer + :nulls-ok t)) + (:base-table employee)) + +(sql:def-view-class company () + ((companyid + :db-type :key + :db-constraints :not-null + :type integer + :initarg :companyid) + (name + :type (string 100) + :initarg :name) + (presidentid + :type integer)) + (:base-table company)) + + +The DEF-VIEW-CLASS macro is just like the normal CLOS DEFCLASS macro, +except that it handles several slot options that DEFCLASS doesn't. +These slot options have to do with the mapping of the slot into the +database. We only use a few of the slot options in the above example, +but there are several others. + + :column -- The name of the SQL column this slot is stored in. + Defaults to the slot name. If the slot name is not a valid SQL + identifier, it is escaped, so foo-bar becomes foo_bar. + + :db-kind -- 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 a join slot + representing a relation to another view and :virtual indicates + that this slot is an ordinary CLOS slot. Defaults to :base. + + :db-reader -- 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 -- 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 -- A string which will be used as the type specifier for + this slots column definition in the database. + + :nulls-ok -- 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 -- A join specification. + +In our example each table as a primary key attribute, which is +required to be unique. We indicate that a slot is part of the primary +key (USQL supports multi-field primary keys) by specifying the +:db-kind :key slot option. + +The SQL type of a slot when it is mapped into the database is +determined by the :type slot option. The argument for the :type +option is a Common Lisp datatype. The USQL framework will determine +the appropriate mapping depending on the database system the table is +being created in. If we really wanted to determine what SQL type was +used for a slot, we could specify a :db-type option like "NUMBER(38)" +and we would be guaranteed that the slot would be stored n the DB as a +NUMBER(38). This is not recomended because it could makes your view +class unportable across database systems. + +DEF-VIEW-CLASS also supports some class options, like :base-table. +The :base-table option specifies what the table name for the view +class will be when it is mapped into the database. + + +CLASS RELATIONS + +In an SQL only application, the EMPLOYEE and COMPANY tables can be +queried to determine things like, "Who is Vladamir's manager?", What +company does Josef work for?", and "What employees work for Widgets +Inc.". This is done by joining tables with an SQL query. + +Who works for Widgets Inc.? + +SELECT first_name, last_name FROM employee, company + WHERE employee.companyid = company.companyid + AND company.company_name = "Widgets Inc." + +Who is Vladamir's manager + +SELECT managerid FROM employee + WHERE employee.first_name = "Vladamir" + AND employee.last_name = "Lenin" + +What company does Josef work for? + +SELECT company_name FROM company, employee + WHERE employee.first_name = "Josef" + AND employee.last-name = "Stalin" + AND employee.companyid = company.companyid + +With USQL however we do not need to write out such queries because our +view classes can maintain the relations between employees and +companies, and employees to their managers for us. We can then access +these relations like we would any other attribute of an employee or +company object. In order to do this we define some join slots for our +view classes. + +What company does an employee work for? If we add the following slot +definition to the employee class we can then ask for it's COMPANY slot +and get the appropriate result. + + ;; In the employee slot list + (company + :accessor employee-company + :db-kind :join + :db-info (:join-class company + :home-key companyid + :foreign-key companyid + :set nil)) + +Who are the employees of a given company? And who is the president of +it? We add the following slot definition to the company view class and +we can then ask for it's EMPLOYEES slot and get the right result. + + ;; In the company slot list + (employees + :reader company-employees + :db-kind :join + :db-info (:join-class employee + :home-key companyid + :foreign-key companyid + :set t)) + + (president + :reader president + :db-kind :join + :db-info (:join-class employee + :home-key presidentid + :foreign-key emplid + :set nil)) + +And lastly, to define the relation between an employee and their +manager. + + ;; In the employee slot list + (manager + :accessor employee-manager + :db-kind :join + :db-info (:join-class employee + :home-key managerid + :foreign-key emplid + :set nil)) + +USQL join slots can represent one-to-one, one-to-many, and +many-to-many relations. Above we only have one-to-one and one-to-many +relations, later we will explain how to model many-to-many relations. +First, let's go over the slot definitions and the available options. + +In order for a slot to be a join, we must specify that it's :db-kind +:join, as opposed to :base or :key. Once we do that, we still need to +tell USQL how to create the join statements for the relation. This is +what the :db-info option does. It is a list of keywords and values. +The available keywords are: + + :join-class -- The view class to which we want to join. It can be + another view class, or the same view class as our object. + + :home-key -- The slot(s) in the immediate object whose value will + be compared to the foreign-key slot(s) in the join-class in order + to join the two tables. It can be a single slot-name, or it can + be a list of slot names. + + :foreign-key -- The slot(s) in the join-class which will be compared + to the value(s) of the home-key. + + :set -- A boolean which if false, indicates that this is a + one-to-one relation, only one object will be returned. If true, + than this is a one-to-many relation, a list of objects will be + returned when we ask for this slots value. + +There are other :join-info options available in USQL, but we will save +those till we get to the many-to-many relation examples. + + +OBJECT CREATION + +Now that we have our model laid out, we should create some object. +Let us assume that we have a database connect set up already. We +first need to create our tables in the database: + +Note: the file usql-tutorial.lisp contains view class definitions +which you can load into your list at this point in order to play along +at home. + +(sql:create-view-from-class 'employee) +(sql:create-view-from-class 'company) + +Then we will create our objects. We create them just like you would +any other CLOS object: + +(defvar employee1 (make-instance 'employee + :emplid 1 + :first-name "Vladamir" + :last-name "Lenin" + :email "lenin@soviet.org")) + +(defvar company1 (make-instance 'company + :companyid 1 + :name "Widgets Inc.")) + + +(defvar employee2 (make-instance 'employee + :emplid 2 + :first-name "Josef" + :last-name "Stalin" + :email "stalin@soviet.org")) + +In order to insert an objects into the database we use the +UPDATE-RECORDS-FROM-INSTANCE function as follows: + +(sql:update-records-from-instance employee1) +(sql:update-records-from-instance employee2) +(sql:update-records-from-instance company1) + +Now we can set up some of the relations between employees and +companies, and their managers. The ADD-TO-RELATION method provides us +with an easy way of doing that. It will update both the relation +slot, as well as the home-key and foreign-key slots in both objects in +the relation. + +;; Lenin manages Stalin (for now) +(sql:add-to-relation employee2 'manager employee1) + +;; Lenin and Stalin both work for Widgets Inc. +(sql:add-to-relation company1 'employees employee1) +(sql:add-to-relation company1 'employees employee2) + +;; Lenin is president of Widgets Inc. +(sql:add-to-relation company1 'president employee1) + +After you make any changes to an object, you have to specifically tell +USQL to update the SQL database. The UPDATE-RECORDS-FROM-INSTANCE +method will write all of the changes you have made to the object into +the database. + +Since USQL objects re just normal CLOS objects, we can manipulate +their slots just like any other object. For instance, let's say that +Lenin changes his email because he was getting too much SPAM fro the +German Socialists. + +;; Print Lenin's current email address, change it and save it to the +;; database. Get a new object representing Lenin from the database +;; and print the email + +;; This lets us use the functional USQL interface with [] syntax +(sql:locally-enable-sql-reader-syntax) + +(format t "The email address of ~A ~A is ~A" + (first-name employee1) + (last-name employee1) + (employee-email employee1)) + +(setf (employee-email employee1) "lenin-nospam@soviets.org") + +;; Update the database +(sql:update-records-from-instance employee1) + +(let ((new-lenin (car (sql:select 'employee + :where [= [slot-value 'employee 'emplid] 1])))) + (format t "His new email is ~A" + (employee-email new-lenin))) + +Everything except for the last LET expression is already familiar to +us by now. To understand the call to SQL:SELECT we need to discuss +the Functional SQL interface and it's integration with the Object +Oriented interface of USQL. + + +FINDING OBJECTS + +Now that we have our objects in the database, how do we get them out +when we need to work with them? USQL provides a Functional interface +to SQL, which consists of a special Lisp reader macro and some +functions. The special syntax allows us to embed SQL in lisp +expressions, and lisp expressions in SQL, with ease. + +Once we have turned on the syntax with the expression: + +(sql:locally-enable-sql-reader-syntax) + +we can start entering fragments of SQL into our lisp reader. We will +get back objects which represent the lisp expressions. These objects +will later be compiled into SQL expressions that are optimized for the +database backed we are connected to. This means that we have a +database independent SQL syntax. Here are some examples: + +;; an attribute or table name +[foo] => # + +;; a attribute identifier with table qualifier +[foo bar] => # + +;; a attribute identifier with table qualifier +[= "Lenin" [first_name]] => + # + +[< [emplid] 3] => + # + +[and [< [emplid] 2] [= [first_name] "Lenin"]] => + # + + +;; If we want to reference a slot in an object we can us the +;; SLOT-VALUE sql extension +[= [slot-value 'employee 'emplid] 1] => + # + +[= [slot-value 'employee 'emplid] + [slot-value 'company 'presidentid]] => + # + +The SLOT-VALUE operator is important because it let's us query objects +in a way that is robust to any changes in the object->table mapping, +like column name changes, or table name changes. So when you are +querying objects, be sure to use the SLOT-VALUE SQL extension. + +Since we can now formulate SQL relational expression which can be used +as qualifiers, like we put after the WHERE keyword in SQL statements, +we can start querying our objects. USQL provides a function SELECT +which can return use complete objects from the database which conform +to a qualifier, can be sorted, and various other SQL operations. + +The first argument to SELECT is a class name. it also has a set of +keyword arguments which are covered in the documentation. For now we +will concern ourselves only with the :where keyword. Select returns a +list of objects, or nil if it can't find any. It's important to +remember that it always returns a list, so even if you are expecting +only one result, you should remember to extract it from the list you +get from SELECT. + +;; all employees +(sql:select 'employee) +;; all companies +(sql:select 'company) + +;; employees named Lenin +(sql:select 'employee :where [= [slot-value 'employee 'last-name] + "Lenin"]) + +(sql:select 'company :where [= [slot-value 'company 'name] + "Widgets Inc."]) + +;; Employees of Widget's Inc. +(sql:select 'employee + :where [and [= [slot-value 'employee 'companyid] + [slot-value 'company 'companyid]] + [= [slot-value 'company 'name] + "Widgets Inc."]]) + +;; Same thing, except that we are using the employee +;; relation in the company view class to do the join for us, +;; saving us the work of writing out the SQL! +(company-employees company1) + +;; President of Widgets Inc. +(president company1) + +;; Manager of Josef Stalin +(employee-manager employee2) + + +DELETING OBJECTS + +Now that we know how to create objects in our database, manipulate +them and query them (including using our predefined relations to save +us the trouble writing alot of SQL) we should learn how to clean up +after ourself. It's quite simple really. The function +DELETE-INSTANCE-RECORDS will remove an object from the database. +However, when we remove an object we are responsible for making sure +that the database is left in a correct state. + +For example, if we remove a company record, we need to either remove +all of it's employees or we need to move them to another company. +Likewise if we remove an employee, we should make sure to update any +other employees who had them as a manager. + + +CONCLUSION + +There are alot more nooks and crannies to USQL, some of which are +covered n the Xanalys documents we refered to earlier, some are not. +The best documentation at this time is still the source code for USQL +itself and the inline documentation for it's various function. + + + +[1] Philip Greenspun's "SQL For Web Nerds" - Data Modeling + http://www.arsdigita.com/books/sql/data-modeling.html + + diff --git a/usql/metaclasses.lisp b/usql/metaclasses.lisp new file mode 100644 index 0000000..d72985e --- /dev/null +++ b/usql/metaclasses.lisp @@ -0,0 +1,495 @@ +;;;; -*- 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) + + +;; ------------------------------------------------------------ +;; 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-class) + (superclass standard-db-class)) + t) + +(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 + (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) + #-cmu &rest + initargs) + (declare (ignore initargs)) + (find-class 'view-class-direct-slot-definition)) + +(defmethod effective-slot-definition-class ((class standard-db-class) + #-cmu &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) + #-cmu slot-name + direct-slots) + ;(declare (ignore #-cmu slot-name direct-slots)) + (declare (ignore #-cmu slot-name)) + (let ((slotd (call-next-method)) + (sd (car direct-slots))) + + (typecase sd + (view-class-slot-definition-mixin + ;; Use the specified :column argument if it is supplied, otherwise + ;; the column slot is filled in with the slot-name, but transformed + ;; to be sql safe, - to _ and such. + (setf (slot-value slotd 'column) + (column-name-from-arg + (if (slot-boundp sd 'column) + (view-class-slot-column sd) + (column-name-from-arg + (sql-escape (slot-definition-name sd)))))) + + (setf (slot-value slotd 'db-type) + (when (slot-boundp sd 'db-type) + (view-class-slot-db-type sd))) + + + (setf (slot-value slotd 'nulls-ok) + (view-class-slot-nulls-ok sd)) + + ;; :db-kind slot value defaults to :base (store slot value in + ;; database) + + (setf (slot-value slotd 'db-kind) + (if (slot-boundp sd 'db-kind) + (view-class-slot-db-kind sd) + :base)) + + (setf (slot-value slotd 'db-writer) + (when (slot-boundp sd 'db-writer) + (view-class-slot-db-writer sd))) + (setf (slot-value slotd 'db-constraints) + (when (slot-boundp sd 'db-constraints) + (view-class-slot-db-constraints sd))) + + + ;; I wonder if this slot option and the previous could be merged, + ;; so that :base and :key remain keyword options, but :db-kind + ;; :join becomes :db-kind (:join )? + + (setf (slot-value slotd 'db-info) + (when (slot-boundp sd 'db-info) + (if (listp (view-class-slot-db-info sd)) + (parse-db-info (view-class-slot-db-info sd)) + (view-class-slot-db-info sd))))) + ;; all other slots + (t + (change-class slotd 'view-class-effective-slot-definition) + (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))) + diff --git a/usql/objects.lisp b/usql/objects.lisp new file mode 100644 index 0000000..757848c --- /dev/null +++ b/usql/objects.lisp @@ -0,0 +1,1108 @@ +;;;; -*- 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) + (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." + `(defclass ,class ,supers ,slots ,@options + (:metaclass standard-db-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) + (declare (ignore database)) + (if args + (format nil "VARCHAR(~A)" (car args)) + (if (member (database-type database) '(:postgresql :postgresql-socket)) + "VARCHAR" + "VARCHAR(255)"))) + +(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database) + (declare (ignore args)) + (case (database-type database) + (:postgresql + "TIMESTAMP WITHOUT TIME ZONE") + (:postgresql-socket + "TIMESTAMP WITHOUT TIME ZONE") + (:mysql + "DATETIME") + (t "TIMESTAMP"))) + +(defmethod database-get-type-specifier ((type (eql 'duration)) args database) + (declare (ignore database args)) + "INT8") + +(deftype raw-string (&optional len) + "A string which is not trimmed when retrieved from the database" + `(string ,len)) + +(defmethod database-get-type-specifier ((type (eql 'raw-string)) args database) + (declare (ignore database)) + (if args + (format nil "VARCHAR(~A)" (car args)) + "VARCHAR")) + +(defmethod database-get-type-specifier ((type (eql 'float)) args database) + (declare (ignore database)) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + +(defmethod database-get-type-specifier ((type (eql 'long-float)) args database) + (declare (ignore database)) + (if args + (format nil "FLOAT(~A)" (car args)) + "FLOAT")) + +(defmethod database-get-type-specifier ((type (eql 'boolean)) args database) + (declare (ignore args database)) + "BOOL") + +(defmethod database-output-sql-as-type (type val database) + (declare (ignore type database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'list)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) + (declare (ignore database)) + (if (keywordp val) + (symbol-name val) + (if val + (concatenate 'string + (package-name (symbol-package val)) + "::" + (symbol-name val)) + ""))) + +(defmethod database-output-sql-as-type ((type (eql 'keyword)) val database) + (declare (ignore database)) + (if val + (symbol-name val) + "")) + +(defmethod database-output-sql-as-type ((type (eql 'vector)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'array)) val database) + (declare (ignore database)) + (progv '(*print-circle* *print-array*) '(t t) + (prin1-to-string val))) + +(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database) + (declare (ignore database)) + (if val "t" "f")) + +(defmethod database-output-sql-as-type ((type (eql 'string)) val database) + (declare (ignore database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'simple-string)) + val database) + (declare (ignore database)) + val) + +(defmethod database-output-sql-as-type ((type (eql 'simple-base-string)) + val database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val type database) + (declare (ignore type database)) + (read-from-string val)) + +(defmethod read-sql-value (val (type (eql 'string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'simple-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'simple-base-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'raw-string)) database) + (declare (ignore database)) + val) + +(defmethod read-sql-value (val (type (eql 'keyword)) database) + (declare (ignore database)) + (when (< 0 (length val)) + (intern (string-upcase val) "KEYWORD"))) + +(defmethod read-sql-value (val (type (eql 'symbol)) database) + (declare (ignore database)) + (when (< 0 (length val)) + (if (find #\: val) + (read-from-string val) + (intern (string-upcase val) "KEYWORD")))) + +(defmethod read-sql-value (val (type (eql 'integer)) database) + (declare (ignore database)) + (etypecase val + (string + (read-from-string val)) + (number val))) + +(defmethod read-sql-value (val (type (eql 'float)) database) + (declare (ignore database)) + ;; writing 1.0 writes 1, so we we *really* want a float, must do (float ...) + (float (read-from-string val))) + +(defmethod read-sql-value (val (type (eql 'boolean)) database) + (declare (ignore database)) + (equal "t" val)) + +(defmethod read-sql-value (val (type (eql 'wall-time)) database) + (declare (ignore database)) + (unless (eq 'NULL val) + (parse-timestring val))) + + +;; ------------------------------------------------------------ +;; Logic for 'faulting in' :join slots + +(defun fault-join-slot-raw (class instance slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (jc (gethash :join-class dbi))) + (let ((jq (join-qualifier class instance slot-def))) + (when jq + (select jc :where jq))))) + +(defun fault-join-slot (class instance slot-def) + (let* ((dbi (view-class-slot-db-info slot-def)) + (ts (gethash :target-slot dbi)) + (res (fault-join-slot-raw class instance slot-def))) + (when res + (cond + ((and ts (gethash :set dbi)) + (mapcar (lambda (obj) + (cons obj (slot-value obj ts))) res)) + ((and ts (not (gethash :set dbi))) + (mapcar (lambda (obj) (slot-value obj ts)) res)) + ((and (not ts) (not (gethash :set dbi))) + (car res)) + ((and (not ts) (gethash :set dbi)) + res))))) + +(defun join-qualifier (class instance slot-def) + (declare (ignore class)) + (let* ((dbi (view-class-slot-db-info slot-def)) + (jc (find-class (gethash :join-class dbi))) + ;;(ts (gethash :target-slot dbi)) + ;;(tsdef (if ts (slotdef-for-slot-with-class ts jc))) + (foreign-keys (gethash :foreign-key dbi)) + (home-keys (gethash :home-key dbi))) + (when (every #'(lambda (slt) + (and (slot-boundp instance slt) + (not (null (slot-value instance slt))))) + (if (listp home-keys) home-keys (list home-keys))) + (let ((jc + (mapcar #'(lambda (hk fk) + (let ((fksd (slotdef-for-slot-with-class fk jc))) + (sql-operation '== + (typecase fk + (symbol + (sql-expression + :attribute + (view-class-slot-column fksd) + :table (view-table jc))) + (t fk)) + (typecase hk + (symbol + (slot-value instance hk)) + (t + hk))))) + (if (listp home-keys) + home-keys + (list home-keys)) + (if (listp foreign-keys) + foreign-keys + (list foreign-keys))))) + (when jc + (if (> (length jc) 1) + (apply #'sql-and jc) + jc)))))) + + +(defun find-all (view-classes &rest args &key all set-operation distinct from + where group-by having order-by order-by-descending offset limit + (database *default-database*)) + "tweeze me apart someone pleeze" + (declare (ignore all set-operation from group-by having offset limit) + (optimize (debug 3) (speed 1))) + (let* ((*db-deserializing* t) + (*default-database* (or database (error 'clsql-nodb-error)))) + (flet ((table-sql-expr (table) + (sql-expression :table (view-table table))) + (ref-equal (ref1 ref2) + (equal (sql ref1) + (sql ref2))) + (tables-equal (table-a table-b) + (string= (string (slot-value table-a 'name)) + (string (slot-value table-b 'name))))) + + (let* ((sclasses (mapcar #'find-class view-classes)) + (sels (mapcar #'generate-selection-list sclasses)) + (fullsels (apply #'append sels)) + (sel-tables (collect-table-refs where)) + (tables + (remove-duplicates + (append (mapcar #'table-sql-expr sclasses) sel-tables) + :test #'tables-equal)) + (res nil)) + (dolist (ob (listify order-by)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (dolist (ob (listify order-by-descending)) + (when (and ob (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + (dolist (ob (listify distinct)) + (when (and (typep ob 'sql-ident) + (not (member ob (mapcar #'cdr fullsels) + :test #'ref-equal))) + (setq fullsels + (append fullsels (mapcar #'(lambda (att) (cons nil att)) + (listify ob)))))) + ;;(format t "~%fullsels is : ~A" fullsels) + (setq res (apply #'select (append (mapcar #'cdr fullsels) + (cons :from (list tables)) args))) + (flet ((build-instance (vals) + (flet ((%build-instance (vclass selects) + (let ((class-name (class-name vclass)) + (db-vals (butlast vals + (- (list-length vals) + (list-length selects)))) + cache-key) + (setf vals (nthcdr (list-length selects) vals)) + (loop for select in selects + for value in db-vals + do + (when (eql (slot-value (car select) 'db-kind) + :key) + (push + (key-value-from-db (car select) value + *default-database*) + cache-key))) + (push class-name cache-key) + (%make-fresh-object class-name + (mapcar #'car selects) + db-vals)))) + (let ((instances (mapcar #'%build-instance sclasses sels))) + (if (= (length sclasses) 1) + (car instances) + instances))))) + (remove-if #'null (mapcar #'build-instance res))))))) + +(defun %make-fresh-object (class-name slots values) + (let* ((*db-initializing* t) + (obj (make-instance class-name + :view-database *default-database*))) + (setf obj (get-slot-values-from-view obj slots values)) + (postinitialize obj) + obj)) + +(defmethod postinitialize ((self t)) + ) + +(defun select (&rest select-all-args) + "Selects data from database given the constraints specified. Returns +a list of lists of record values as specified by select-all-args. By +default, the records are each represented as lists of attribute +values. The selections argument may be either db-identifiers, literal +strings or view classes. If the argument consists solely of view +classes, the return value will be instances of objects rather than raw +tuples." + (flet ((select-objects (target-args) + (and target-args + (every #'(lambda (arg) + (and (symbolp arg) + (find-class arg nil))) + target-args)))) + (multiple-value-bind (target-args qualifier-args) + (query-get-selections select-all-args) + (if (select-objects target-args) + (apply #'find-all target-args qualifier-args) + (let ((expr (apply #'make-query select-all-args))) + (destructuring-bind (&key (flatp nil) + (database *default-database*) + &allow-other-keys) + qualifier-args + (let ((res (query expr :database database))) + (if (and flatp + (= (length (slot-value expr 'selections)) 1)) + (mapcar #'car res) + res)))))))) diff --git a/usql/operations.lisp b/usql/operations.lisp new file mode 100644 index 0000000..b07c068 --- /dev/null +++ b/usql/operations.lisp @@ -0,0 +1,201 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: operations.lisp +;;;; Updated: <04/04/2004 12:07:26 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; Definition of SQL operations used with the symbolic SQL syntax. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + + +;; Keep a hashtable for mapping symbols to sql generator functions, +;; for use by the bracketed reader syntax. + +(defvar *sql-op-table* (make-hash-table :test #'equal)) + + +;; Define an SQL operation type. + +(defmacro defsql (function definition-keys &body body) + `(progn + (defun ,function ,@body) + (let ((symbol (cadr (member :symbol ',definition-keys)))) + (setf (gethash (if symbol (string-upcase symbol) ',function) + *sql-op-table*) + ',function)))) + + +;; SQL operations + +(defsql sql-query (:symbol "select") (&rest args) + (apply #'make-query args)) + +(defsql sql-any (:symbol "any") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'any :components rest)) + +(defsql sql-all (:symbol "all") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'all :components rest)) + +(defsql sql-not (:symbol "not") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'not :components rest)) + +(defsql sql-union (:symbol "union") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'union :components rest)) + +(defsql sql-intersect (:symbol "intersect") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'intersect :components rest)) + +(defsql sql-minus (:symbol "minus") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'minus :components rest)) + +(defsql sql-group-by (:symbol "group-by") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'group-by :components rest)) + +(defsql sql-limit (:symbol "limit") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'limit :components rest)) + +(defsql sql-having (:symbol "having") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'having :components rest)) + +(defsql sql-null (:symbol "null") (&rest rest) + (if rest + (make-instance 'sql-relational-exp :operator '|IS NULL| + :sub-expressions (list (car rest))) + (make-instance 'sql-value-exp :components 'null))) + +(defsql sql-not-null (:symbol "not-null") () + (make-instance 'sql-value-exp + :components '|NOT NULL|)) + +(defsql sql-exists (:symbol "exists") (&rest rest) + (make-instance 'sql-value-exp + :modifier 'exists :components rest)) + +(defsql sql-* (:symbol "*") (&rest rest) + (if (zerop (length rest)) + (make-instance 'sql-ident :name '*) + ;(error 'clsql-sql-syntax-error :reason "'*' with arguments"))) + (make-instance 'sql-relational-exp :operator '* :sub-expressions rest))) + +(defsql sql-+ (:symbol "+") (&rest rest) + (if (cdr rest) + (make-instance 'sql-relational-exp + :operator '+ :sub-expressions rest) + (make-instance 'sql-value-exp :modifier '+ :components rest))) + +(defsql sql-/ (:symbol "/") (&rest rest) + (make-instance 'sql-relational-exp + :operator '/ :sub-expressions rest)) + +(defsql sql-- (:symbol "-") (&rest rest) + (if (cdr rest) + (make-instance 'sql-relational-exp + :operator '- :sub-expressions rest) + (make-instance 'sql-value-exp :modifier '- :components rest))) + +(defsql sql-like (:symbol "like") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'like :sub-expressions rest)) + +(defsql sql-uplike (:symbol "uplike") (&rest rest) + (make-instance 'sql-upcase-like + :sub-expressions rest)) + +(defsql sql-and (:symbol "and") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'and :sub-expressions rest)) + +(defsql sql-or (:symbol "or") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'or :sub-expressions rest)) + +(defsql sql-in (:symbol "in") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'in :sub-expressions rest)) + +(defsql sql-|| (:symbol "||") (&rest rest) + (make-instance 'sql-relational-exp + :operator '|| :sub-expressions rest)) + +(defsql sql-is (:symbol "is") (&rest rest) + (make-instance 'sql-relational-exp + :operator 'is :sub-expressions rest)) + +(defsql sql-= (:symbol "=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '= :sub-expressions rest)) + +(defsql sql-== (:symbol "==") (&rest rest) + (make-instance 'sql-assignment-exp + :operator '= :sub-expressions rest)) + +(defsql sql-< (:symbol "<") (&rest rest) + (make-instance 'sql-relational-exp + :operator '< :sub-expressions rest)) + + +(defsql sql-> (:symbol ">") (&rest rest) + (make-instance 'sql-relational-exp + :operator '> :sub-expressions rest)) + +(defsql sql-<> (:symbol "<>") (&rest rest) + (make-instance 'sql-relational-exp + :operator '<> :sub-expressions rest)) + +(defsql sql->= (:symbol ">=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '>= :sub-expressions rest)) + +(defsql sql-<= (:symbol "<=") (&rest rest) + (make-instance 'sql-relational-exp + :operator '<= :sub-expressions rest)) + +(defsql sql-count (:symbol "count") (&rest rest) + (make-instance 'sql-function-exp + :name 'count :args rest)) + +(defsql sql-max (:symbol "max") (&rest rest) + (make-instance 'sql-function-exp + :name 'max :args rest)) + +(defsql sql-min (:symbol "min") (&rest rest) + (make-instance 'sql-function-exp + :name 'min :args rest)) + +(defsql sql-avg (:symbol "avg") (&rest rest) + (make-instance 'sql-function-exp + :name 'avg :args rest)) + +(defsql sql-sum (:symbol "sum") (&rest rest) + (make-instance 'sql-function-exp + :name 'sum :args rest)) + +(defsql sql-the (:symbol "the") (&rest rest) + (make-instance 'sql-typecast-exp + :modifier (first rest) :components (second rest))) + +(defsql sql-function (:symbol "function") (&rest args) + (make-instance 'sql-function-exp + :name (make-symbol (car args)) :args (cdr args))) + +;;(defsql sql-distinct (:symbol "distinct") (&rest rest) +;; nil) + +;;(defsql sql-between (:symbol "between") (&rest rest) +;; nil) + diff --git a/usql/package.lisp b/usql/package.lisp new file mode 100644 index 0000000..17bb441 --- /dev/null +++ b/usql/package.lisp @@ -0,0 +1,327 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: package.lisp +;;;; Author: Marcus Pearce +;;;; 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) + +(defpackage #:clsql-usql-sys + (:nicknames #:usql-sys #:sql-sys) + (:use #:common-lisp #:clsql-base-sys #+lispworks #:clos) + ;; This is for working with the CMUCL/SBCL PCL MOP, which is kinda whacky + #+(or cmu sbcl) + (:shadowing-import-from #+cmu :pcl #+sbcl :sb-pcl + :built-in-class + :class-direct-slots + :class-name + :class-of + :class-slots + :compute-effective-slot-definition + :direct-slot-definition-class + :effective-slot-definition-class + :find-class + :slot-boundp + :slot-definition-name + :slot-definition-type + :slot-value-using-class + :standard-direct-slot-definition + :standard-effective-slot-definition + :validate-superclass + :class-direct-superclasses + :name + :standard-class) + (:import-from :clsql-base-sys + ;; 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) + (: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 + ;;==================================================== + #1=(;;------------------------------------------------ + ;; CommonSQL API + ;;------------------------------------------------ + ;;FDML + :select ; objects xx + :cache-table-queries ; + :*cache-table-queries-default* ; + :delete-records ; sql xx + :insert-records ; sql xx + :update-records ; sql xx + :execute-command ; sql xx + :query ; sql xx + :print-query ; sql xx + :do-query ; sql xx + :map-query ; sql xx + :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 + + ;;----------------------------------------------- + ;; Conditions/Warnings/Errors + ;;----------------------------------------------- + :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-type-error + :clsql-sql-error-database + :clsql-sql-error-expression + :clsql-sql-error-errno + :clsql-sql-error-error + :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 + + ;;----------------------------------------------- + ;; 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 + +)) + (: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 . #1#) + (:export . #1#) + (:documentation "This is the SQL-Interface package of USQL.")) + +);eval-when + + diff --git a/usql/pcl-patch.lisp b/usql/pcl-patch.lisp new file mode 100644 index 0000000..fd246f8 --- /dev/null +++ b/usql/pcl-patch.lisp @@ -0,0 +1,12 @@ + +;; 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))) diff --git a/usql/sql.lisp b/usql/sql.lisp new file mode 100644 index 0000000..f700c17 --- /dev/null +++ b/usql/sql.lisp @@ -0,0 +1,355 @@ +;;;; -*- 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 + +(defun map-query (output-type-spec function query-expression + &key (database *default-database*) + (types nil)) + "Map the function over all tuples that are returned by the query in +query-expression. The results of the function are collected as +specified in output-type-spec and returned like in MAP." + ;; DANGER Will Robinson: Parts of the code for implementing + ;; map-query (including the code below and the helper functions + ;; called) are highly CMU CL specific. + ;; KMR -- these have been replaced with cross-platform instructions above + (macrolet ((type-specifier-atom (type) + `(if (atom ,type) ,type (car ,type)))) + (case (type-specifier-atom output-type-spec) + ((nil) + (map-query-for-effect function query-expression database types)) + (list + (map-query-to-list function query-expression database types)) + ((simple-vector simple-string vector string array simple-array + bit-vector simple-bit-vector base-string + simple-base-string) + (map-query-to-simple output-type-spec function query-expression + database types)) + (t + (funcall #'map-query + (cmucl-compat:result-type-or-lose output-type-spec t) + function query-expression :database database :types types))))) + +(defun map-query-for-effect (function query-expression database types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :types types) + (when result-set + (unwind-protect + (do ((row (make-list columns))) + ((not (database-store-next-row result-set database row)) + nil) + (apply function row)) + (database-dump-result-set result-set database))))) + +(defun map-query-to-list (function query-expression database types) + (multiple-value-bind (result-set columns) + (database-query-result-set query-expression database :full-set nil + :types types) + (when result-set + (unwind-protect + (let ((result (list nil))) + (do ((row (make-list columns)) + (current-cons result (cdr current-cons))) + ((not (database-store-next-row result-set database row)) + (cdr result)) + (rplacd current-cons (list (apply function row))))) + (database-dump-result-set result-set database))))) + +(defun map-query-to-simple (output-type-spec function query-expression + database types) + (multiple-value-bind (result-set columns rows) + (database-query-result-set query-expression database :full-set t + :types types) + (when result-set + (unwind-protect + (if rows + ;; We know the row count in advance, so we allocate once + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec rows)) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + result) + (declare (fixnum index)) + (setf (aref result index) + (apply function row))) + ;; Database can't report row count in advance, so we have + ;; to grow and shrink our vector dynamically + (do ((result + (cmucl-compat:make-sequence-of-type output-type-spec 100)) + (allocated-length 100) + (row (make-list columns)) + (index 0 (1+ index))) + ((not (database-store-next-row result-set database row)) + (cmucl-compat:shrink-vector result index)) + (declare (fixnum allocated-length index)) + (when (>= index allocated-length) + (setf allocated-length (* allocated-length 2) + result (adjust-array result allocated-length))) + (setf (aref result index) + (apply function row)))) + (database-dump-result-set result-set database))))) + +(defmacro do-query (((&rest args) query-expression + &key (database '*default-database*) (types nil)) + &body body) + "Repeatedly executes BODY within a binding of ARGS on the attributes +of each record resulting from QUERY. The return value is determined by +the result of executing BODY. The default value of DATABASE is +*DEFAULT-DATABASE*." + (let ((result-set (gensym)) + (columns (gensym)) + (row (gensym)) + (db (gensym))) + `(let ((,db ,database)) + (multiple-value-bind (,result-set ,columns) + (database-query-result-set ,query-expression ,db + :full-set nil :types ,types) + (when ,result-set + (unwind-protect + (do ((,row (make-list ,columns))) + ((not (database-store-next-row ,result-set ,db ,row)) + nil) + (destructuring-bind ,args ,row + ,@body)) + (database-dump-result-set ,result-set ,db))))))) + + +;; output-sql + +(defmethod database-output-sql ((str string) database) + (declare (ignore database) + (optimize (speed 3) (safety 1) #+cmu (extensions:inhibit-warnings 3)) + (type (simple-array * (*)) str)) + (let ((len (length str))) + (declare (type fixnum len)) + (cond ((= len 0) + +empty-string+) + ((and (null (position #\' str)) + (null (position #\\ str))) + (concatenate 'string "'" str "'")) + (t + (let ((buf (make-string (+ (* len 2) 2) :initial-element #\'))) + (do* ((i 0 (incf i)) + (j 1 (incf j))) + ((= i len) (subseq buf 0 (1+ j))) + (declare (type integer i j)) + (let ((char (aref str i))) + (cond ((eql char #\') + (setf (aref buf j) #\\) + (incf j) + (setf (aref buf j) #\')) + ((eql char #\\) + (setf (aref buf j) #\\) + (incf j) + (setf (aref buf j) #\\)) + (t + (setf (aref buf j) char)))))))))) + +(let ((keyword-package (symbol-package :foo))) + (defmethod database-output-sql ((sym symbol) database) + (declare (ignore database)) + (if (equal (symbol-package sym) keyword-package) + (concatenate 'string "'" (string sym) "'") + (symbol-name sym)))) + +(defmethod database-output-sql ((tee (eql t)) database) + (declare (ignore database)) + "'Y'") + +(defmethod database-output-sql ((num number) database) + (declare (ignore database)) + (princ-to-string num)) + +(defmethod database-output-sql ((arg list) database) + (if (null arg) + "NULL" + (format nil "(~{~A~^,~})" (mapcar #'(lambda (val) + (sql-output val database)) + arg)))) + +(defmethod database-output-sql ((arg vector) database) + (format nil "~{~A~^,~}" (map 'list #'(lambda (val) + (sql-output val database)) + arg))) + +(defmethod database-output-sql ((self wall-time) database) + (declare (ignore database)) + (db-timestring self)) + +(defmethod database-output-sql (thing database) + (if (or (null thing) + (eq 'null thing)) + "NULL" + (error 'clsql-simple-error + :format-control + "No type conversion to SQL for ~A is defined for DB ~A." + :format-arguments (list (type-of thing) (type-of database))))) + +(defmethod output-sql-hash-key ((arg vector) &optional database) + (list 'vector (map 'list (lambda (arg) + (or (output-sql-hash-key arg database) + (return-from output-sql-hash-key nil))) + arg))) + +(defmethod output-sql (expr &optional (database *default-database*)) + (write-string (database-output-sql expr database) *sql-stream*) + t) + +(defmethod output-sql ((expr list) &optional (database *default-database*)) + (if (null expr) + (write-string +null-string+ *sql-stream*) + (progn + (write-char #\( *sql-stream*) + (do ((item expr (cdr item))) + ((null (cdr item)) + (output-sql (car item) database)) + (output-sql (car item) database) + (write-char #\, *sql-stream*)) + (write-char #\) *sql-stream*))) + t) + + diff --git a/usql/syntax.lisp b/usql/syntax.lisp new file mode 100644 index 0000000..f3f8372 --- /dev/null +++ b/usql/syntax.lisp @@ -0,0 +1,168 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: package.lisp +;;;; Updated: <04/04/2004 12:05:16 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; CLSQL-USQL square bracket symbolic query syntax. Functions for +;;;; enabling and disabling the syntax and for building SQL +;;;; expressions using the syntax. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + +(defvar *original-reader-enter* nil) + +(defvar *original-reader-exit* nil) + +(defvar *sql-macro-open-char* #\[) + +(defvar *sql-macro-close-char* #\]) + +(defvar *restore-sql-reader-syntax* nil) + + +;; Exported functions for disabling SQL syntax. + +(defmacro disable-sql-reader-syntax () + "Turn off SQL square bracket syntax changing syntax state. Set state +such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax +disabled if it is consequently locally enabled." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *restore-sql-reader-syntax* nil) + (%disable-sql-reader-syntax))) + +(defmacro locally-disable-sql-reader-syntax () + "Turn off SQL square bracket syntax and do not change syntax state." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (%disable-sql-reader-syntax))) + +(defun %disable-sql-reader-syntax () + (when *original-reader-enter* + (set-macro-character *sql-macro-open-char* *original-reader-enter*)) + (setf *original-reader-enter* nil) + (values)) + + +;; Exported functions for enabling SQL syntax. + +(defmacro enable-sql-reader-syntax () + "Turn on SQL square bracket syntax changing syntax state. Set state +such that RESTORE-SQL-READER-SYNTAX-STATE will make the syntax enabled +if it is consequently locally disabled." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (setf *restore-sql-reader-syntax* t) + (%enable-sql-reader-syntax))) + +(defmacro locally-enable-sql-reader-syntax () + "Turn on SQL square bracket syntax and do not change syntax state." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (%enable-sql-reader-syntax))) + +(defun %enable-sql-reader-syntax () + (unless *original-reader-enter* + (setf *original-reader-enter* (get-macro-character *sql-macro-open-char*))) + (set-macro-character *sql-macro-open-char* #'sql-reader-open) + (enable-sql-close-syntax) + (values)) + +(defmacro restore-sql-reader-syntax-state () + "Sets the enable/disable square bracket syntax state to reflect the +last call to either DISABLE-SQL-READER-SYNTAX or +ENABLE-SQL-READER-SYNTAX. The default state of the square bracket +syntax is disabled." + '(eval-when (:compile-toplevel :load-toplevel :execute) + (if *restore-sql-reader-syntax* + (%enable-sql-reader-syntax) + (%disable-sql-reader-syntax)))) + +(defun sql-reader-open (stream char) + (declare (ignore char)) + (let ((sqllist (read-delimited-list #\] stream t))) + (if (sql-operator (car sqllist)) + (cons (sql-operator (car sqllist)) (cdr sqllist)) + (apply #'generate-sql-reference sqllist)))) + +;; Internal function that disables the close syntax when leaving sql context. +(defun disable-sql-close-syntax () + (set-macro-character *sql-macro-close-char* *original-reader-exit*) + (setf *original-reader-exit* nil)) + +;; Internal function that enables close syntax when entering SQL context. +(defun enable-sql-close-syntax () + (setf *original-reader-exit* (get-macro-character *sql-macro-close-char*)) + (set-macro-character *sql-macro-close-char* (get-macro-character #\)))) + +(defun generate-sql-reference (&rest arglist) + (cond ((= (length arglist) 1) ; string, table or attribute + (if (stringp (car arglist)) + (sql-expression :string (car arglist)) + (sql-expression :attribute (car arglist)))) + ((<= 2 (length arglist)) + (let ((sqltype (if (keywordp (caddr arglist)) + (caddr arglist) nil)) + (sqlparam (if (keywordp (caddr arglist)) + (caddr arglist)))) + (cond + ((stringp (cadr arglist)) + (sql-expression :table (car arglist) + :alias (cadr arglist) + :type sqltype)) + ((keywordp (cadr arglist)) + (sql-expression :attribute (car arglist) + :type (cadr arglist) + :params sqlparam)) + (t + (sql-expression :attribute (cadr arglist) + :table (car arglist) + :params sqlparam + :type sqltype))))) + (t + (error 'clsql-sql-syntax-error :reason "bad expression syntax")))) + + +;; Exported functions for dealing with SQL syntax + +(defun sql (&rest args) + "Generates SQL from a set of expressions given by ARGS. Each +argument is translated into SQL and then the args are concatenated +with a single space between each pair." + (format nil "~{~A~^ ~}" (mapcar #'sql-output args))) + +(defun sql-expression (&key string table alias attribute type params) + "Generates an SQL expression from the given keywords. Valid +combinations of the arguments are: string; table; table and alias; +table and attribute; table, attribute, and type; table or alias, and +attribute; table or alias, and attribute and type; attribute; and +attribute and type." + (cond + (string + (make-instance 'sql :string string)) + (attribute + (make-instance 'sql-ident-attribute :name attribute + :qualifier (or table alias) + :type type + :params params)) + ((and table (not attribute)) + (make-instance 'sql-ident-table :name table + :table-alias alias)))) + +(defun sql-operator (operation) + "Takes an SQL operator as an argument and returns the Lisp symbol +for the operator." + (typecase operation + (string nil) + (symbol (gethash (string-upcase (symbol-name operation)) + *sql-op-table*)))) + +(defun sql-operation (operation &rest rest) + "Generates an SQL statement from an operator and arguments." + (if (sql-operator operation) + (apply (symbol-function (sql-operator operation)) rest) + (error "~A is not a recognized SQL operator." operation))) + + diff --git a/usql/table.lisp b/usql/table.lisp new file mode 100644 index 0000000..715cef0 --- /dev/null +++ b/usql/table.lisp @@ -0,0 +1,320 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ====================================================================== +;;;; File: table.lisp +;;;; Updated: <04/04/2004 12:05:03 marcusp> +;;;; ====================================================================== +;;;; +;;;; Description ========================================================== +;;;; ====================================================================== +;;;; +;;;; The CLSQL-USQL Functional Data Definition Language (FDDL) +;;;; including functions for schema manipulation. Currently supported +;;;; SQL objects include tables, views, indexes, attributes and +;;;; sequences. +;;;; +;;;; ====================================================================== + +(in-package :clsql-usql-sys) + + +;; Utilities + +(defun database-identifier (name) + (sql-escape (etypecase name + (string + (string-upcase name)) + (sql-ident + (sql-output name)) + (symbol + (sql-output name))))) + + +;; Tables + +(defvar *table-schemas* (make-hash-table :test #'equal) + "Hash of schema name to table lists.") + +(defun create-table (name description &key (database *default-database*) + (constraints nil)) + "Create a table called NAME, in DATABASE which defaults to +*DEFAULT-DATABASE*, containing the attributes in DESCRIPTION which is +a list containing lists of attribute-name and type information pairs." + (let* ((table-name (etypecase name + (symbol (sql-expression :attribute name)) + (string (sql-expression :attribute (make-symbol name))) + (sql-ident name))) + (stmt (make-instance 'sql-create-table + :name table-name + :columns description + :modifiers constraints))) + (pushnew table-name (gethash *default-schema* *table-schemas*) + :test #'equal) + (execute-command stmt :database database))) + +(defun drop-table (name &key (if-does-not-exist :error) + (database *default-database*)) + "Drops table NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the table does not exist and IF-DOES-NOT-EXIST +is :ignore then DROP-TABLE returns nil whereas an error is signalled +if IF-DOES-NOT-EXIST is :error." + (let ((table-name (database-identifier name))) + (ecase if-does-not-exist + (:ignore + (unless (table-exists-p table-name :database database) + (return-from drop-table nil))) + (:error + t)) + (let ((expr (concatenate 'string "DROP TABLE " table-name))) + (execute-command expr :database database)))) + +(defun list-tables (&key (owner nil) (database *default-database*)) + "List all tables in DATABASE which defaults to +*DEFAULT-DATABASE*. If OWNER is nil, only user-owned tables are +considered. This is the default. If OWNER is :all , all tables are +considered. If OWNER is a string, this denotes a username and only +tables owned by OWNER are considered. Table names are returned as a +list of strings." + (database-list-tables database :owner owner)) + +(defun table-exists-p (name &key (owner nil) (database *default-database*)) + "Test for existence of an SQL table called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned +tables are considered. This is the default. If OWNER is :all , all +tables are considered. If OWNER is a string, this denotes a username +and only tables owned by OWNER are considered. Table names are +returned as a list of strings." + (when (member (database-identifier name) + (list-tables :owner owner :database database) + :test #'string-equal) + t)) + + +;; Views + +(defvar *view-schemas* (make-hash-table :test #'equal) + "Hash of schema name to view lists.") + +(defun create-view (name &key as column-list (with-check-option nil) + (database *default-database*)) + "Creates a view called NAME using the AS query and the optional +COLUMN-LIST and WITH-CHECK-OPTION. The COLUMN-LIST argument is a list +of columns to add to the view. The WITH-CHECK-OPTION adds 'WITH CHECK +OPTION' to the resulting SQL. The default value of WITH-CHECK-OPTION +is NIL. The default value of DATABASE is *DEFAULT-DATABASE*." + (let* ((view-name (etypecase name + (symbol (sql-expression :attribute name)) + (string (sql-expression :attribute (make-symbol name))) + (sql-ident name))) + (stmt (make-instance 'sql-create-view + :name view-name + :column-list column-list + :query as + :with-check-option with-check-option))) + (pushnew view-name (gethash *default-schema* *view-schemas*) :test #'equal) + (execute-command stmt :database database))) + +(defun drop-view (name &key (if-does-not-exist :error) + (database *default-database*)) + "Deletes view NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the view does not exist and IF-DOES-NOT-EXIST +is :ignore then DROP-VIEW returns nil whereas an error is signalled if +IF-DOES-NOT-EXIST is :error." + (let ((view-name (database-identifier name))) + (ecase if-does-not-exist + (:ignore + (unless (view-exists-p view-name :database database) + (return-from drop-view))) + (:error + t)) + (let ((expr (concatenate 'string "DROP VIEW " view-name))) + (execute-command expr :database database)))) + +(defun list-views (&key (owner nil) (database *default-database*)) + "List all views in DATABASE which defaults to *DEFAULT-DATABASE*. If +OWNER is nil, only user-owned views are considered. This is the +default. If OWNER is :all , all views are considered. If OWNER is a +string, this denotes a username and only views owned by OWNER are +considered. View names are returned as a list of strings." + (database-list-views database :owner owner)) + +(defun view-exists-p (name &key (owner nil) (database *default-database*)) + "Test for existence of an SQL view called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned views +are considered. This is the default. If OWNER is :all , all views are +considered. If OWNER is a string, this denotes a username and only +views owned by OWNER are considered. View names are returned as a list +of strings." + (when (member (database-identifier name) + (list-views :owner owner :database database) + :test #'string-equal) + t)) + + +;; Indexes + +(defvar *index-schemas* (make-hash-table :test #'equal) + "Hash of schema name to index lists.") + +(defun create-index (name &key on (unique nil) attributes + (database *default-database*)) + "Creates an index called NAME on the table specified by ON. The +attributes of the table to index are given by ATTRIBUTES. Setting +UNIQUE to T includes UNIQUE in the SQL index command, specifying that +the columns indexed must contain unique values. The default value of +UNIQUE is nil. The default value of DATABASE is *DEFAULT-DATABASE*." + (let* ((index-name (database-identifier name)) + (table-name (database-identifier on)) + (attributes (mapcar #'database-identifier (listify attributes))) + (stmt (format nil "CREATE ~A INDEX ~A ON ~A (~{~A~^, ~})" + (if unique "UNIQUE" "") + index-name table-name attributes))) + (pushnew index-name (gethash *default-schema* *index-schemas*)) + (execute-command stmt :database database))) + +(defun drop-index (name &key (if-does-not-exist :error) + (on nil) + (database *default-database*)) + "Deletes index NAME from table FROM in DATABASE which defaults to +*DEFAULT-DATABASE*. If the index does not exist and IF-DOES-NOT-EXIST +is :ignore then DROP-INDEX returns nil whereas an error is signalled +if IF-DOES-NOT-EXIST is :error. The argument ON allows the optional +specification of a table to drop the index from." + (let ((index-name (database-identifier name))) + (ecase if-does-not-exist + (:ignore + (unless (index-exists-p index-name :database database) + (return-from drop-index))) + (:error t)) + (execute-command (format nil "DROP INDEX ~A~A" index-name + (if (null on) "" + (concatenate 'string " ON " + (database-identifier on)))) + :database database))) + +(defun list-indexes (&key (owner nil) (database *default-database*)) + "List all indexes in DATABASE, which defaults to +*default-database*. If OWNER is :all , all indexs are considered. If +OWNER is a string, this denotes a username and only indexs owned by +OWNER are considered. Index names are returned as a list of strings." + (database-list-indexes database :owner owner)) + +(defun index-exists-p (name &key (owner nil) (database *default-database*)) + "Test for existence of an index called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*. If OWNER is :all , all indexs are +considered. If OWNER is a string, this denotes a username and only +indexs owned by OWNER are considered. Index names are returned as a +list of strings." + (when (member (database-identifier name) + (list-indexes :owner owner :database database) + :test #'string-equal) + t)) + +;; Attributes + +(defun list-attributes (name &key (owner nil) (database *default-database*)) + "List the attributes of a attribute called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned +attributes are considered. This is the default. If OWNER is :all , all +attributes are considered. If OWNER is a string, this denotes a +username and only attributes owned by OWNER are considered. Attribute +names are returned as a list of strings. Attributes are returned as a +list of strings." + (database-list-attributes (database-identifier name) database :owner owner)) + +(defun attribute-type (attribute table &key (owner nil) + (database *default-database*)) + "Return the field type of the ATTRIBUTE in TABLE. The optional +keyword argument DATABASE specifies the database to query, defaulting +to *DEFAULT-DATABASE*. If OWNER is nil, only user-owned attributes are +considered. This is the default. If OWNER is :all , all attributes are +considered. If OWNER is a string, this denotes a username and only +attributes owned by OWNER are considered. Attribute names are returned +as a list of strings. Attributes are returned as a list of strings." + (database-attribute-type (database-identifier attribute) + (database-identifier table) + database + :owner owner)) + +(defun list-attribute-types (table &key (owner nil) + (database *default-database*)) + "Returns type information for the attributes in TABLE from DATABASE +which has a default value of *default-database*. If OWNER is nil, only +user-owned attributes are considered. This is the default. If OWNER is +:all, all attributes are considered. If OWNER is a string, this +denotes a username and only attributes owned by OWNER are +considered. Returns a list in which each element is a list (attribute +datatype). Attribute is a string denoting the atribute name. Datatype +is the vendor-specific type returned by ATTRIBUTE-TYPE." + (mapcar #'(lambda (type) + (list type (attribute-type type table :database database + :owner owner))) + (list-attributes table :database database :owner owner))) + +;(defun add-attribute (table attribute &key (database *default-database*)) +; (database-add-attribute table attribute database)) + +;(defun rename-attribute (table oldatt newname +; &key (database *default-database*)) +; (error "(rename-attribute ~a ~a ~a ~a) is not implemented" +; table oldatt newname database)) + + +;; Sequences + +(defvar *sequence-schemas* (make-hash-table :test #'equal) + "Hash of schema name to sequence lists.") + +(defun create-sequence (name &key (database *default-database*)) + "Create a sequence called NAME in DATABASE which defaults to +*DEFAULT-DATABASE*." + (let ((sequence-name (database-identifier name))) + (database-create-sequence sequence-name database) + (pushnew sequence-name (gethash *default-schema* *sequence-schemas*) + :test #'equal)) + (values)) + +(defun drop-sequence (name &key (if-does-not-exist :error) + (database *default-database*)) + "Drops sequence NAME from DATABASE which defaults to +*DEFAULT-DATABASE*. If the sequence does not exist and +IF-DOES-NOT-EXIST is :ignore then DROP-SEQUENCE returns nil whereas an +error is signalled if IF-DOES-NOT-EXIST is :error." + (let ((sequence-name (database-identifier name))) + (ecase if-does-not-exist + (:ignore + (unless (sequence-exists-p sequence-name :database database) + (return-from drop-sequence))) + (:error t)) + (database-drop-sequence sequence-name database)) + (values)) + +(defun list-sequences (&key (owner nil) (database *default-database*)) + "List all sequences in DATABASE, which defaults to +*default-database*. If OWNER is nil, only user-owned sequences are +considered. This is the default. If OWNER is :all , all sequences are +considered. If OWNER is a string, this denotes a username and only +sequences owned by OWNER are considered. Sequence names are returned +as a list of strings." + (database-list-sequences database :owner owner)) + +(defun sequence-exists-p (name &key (owner nil) + (database *default-database*)) + "Test for existence of a sequence called NAME in DATABASE which +defaults to *DEFAULT-DATABASE*." + (when (member (database-identifier name) + (list-sequences :owner owner :database database) + :test #'string-equal) + t)) + +(defun sequence-next (name &key (database *default-database*)) + "Return the next value in the sequence NAME in DATABASE." + (database-sequence-next (database-identifier name) database)) + +(defun set-sequence-position (name position &key (database *default-database*)) + "Explicitly set the the position of the sequence NAME in DATABASE to +POSITION." + (database-set-sequence-position (database-identifier name) position database)) + +(defun sequence-last (name &key (database *default-database*)) + "Return the last value of the sequence NAME in DATABASE." + (database-sequence-last (database-identifier name) database)) \ No newline at end of file -- 2.34.1