From: Kevin M. Rosenberg Date: Thu, 13 May 2004 06:55:48 +0000 (+0000) Subject: r9336: 12 May 2004 Kevin Rosenberg (kevin@rosenberg.net) X-Git-Tag: v3.8.6~471 X-Git-Url: http://git.kpe.io/?p=clsql.git;a=commitdiff_plain;h=8a8ee2d7d791b7a3efaed06420802a925d16fca3 r9336: 12 May 2004 Kevin Rosenberg (kevin@rosenberg.net) * sql/sql.lisp: Add FOR-EACH-ROW macro from clsql-classic/sql.lisp * clsql-classic: Remove system and subdirectory * clsql-base: Remove system and subdirectory and fold into clsql system --- diff --git a/ChangeLog b/ChangeLog index 4a655b3..5e40734 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +12 May 2004 Kevin Rosenberg (kevin@rosenberg.net) + * sql/sql.lisp: Add FOR-EACH-ROW macro from clsql-classic/sql.lisp + * clsql-classic: Remove system and subdirectory + * clsql-base: Remove system and subdirectory and + fold into clsql system + 12 May 2004 Kevin Rosenberg (kevin@rosenberg.net) * Version 2.10.16: CLSQL now fully supports AllegroCL AMD64 * db-odbc/odbc-api.lisp: work around return-type bug [spr28889] in diff --git a/Makefile b/Makefile index 32b9722..9c3ef23 100644 --- a/Makefile +++ b/Makefile @@ -15,7 +15,7 @@ PKG := clsql DEBPKG := cl-sql -SUBDIRS := sql tests uffi base classic db-mysql db-aodbc db-odbc \ +SUBDIRS := sql tests uffi db-mysql db-aodbc db-odbc \ db-postgresql db-postgresql-socket db-sqlite DOCSUBDIRS:=doc diff --git a/TODO b/TODO index d7e470a..0beae4c 100644 --- a/TODO +++ b/TODO @@ -8,6 +8,7 @@ TESTS TO ADD * :db-constraint tests * test *db-auto-sync* * test SELECT caching +* for-each-row macro COMMONSQL SPEC diff --git a/base/.gitignore b/base/.gitignore deleted file mode 100644 index 1d27afc..0000000 --- a/base/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -clsql-uffi.so -clsql-uffi.dll -clsql-uffi.lib -clsql-uffi.dylib -.bin -*.fasl -*.pfsl -*.dfsl -*.cfsl -*.fasla16 -*.fasla8 -*.faslm16 -*.faslm8 -*.fsl diff --git a/base/Makefile b/base/Makefile deleted file mode 100644 index 31dc910..0000000 --- a/base/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := - -include ../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/base/basic-sql.lisp b/base/basic-sql.lisp deleted file mode 100644 index a7d32cf..0000000 --- a/base/basic-sql.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; -;;;; $Id$ -;;;; -;;;; Base SQL functions -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - -;;; 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 :auto) (flatp nil) (field-names t)) - (record-sql-command query-expression database) - (multiple-value-bind (rows names) (database-query query-expression database result-types - field-names) - (let ((result (if (and flatp (= 1 (length (car rows)))) - (mapcar #'car rows) - rows))) - (record-sql-result result database) - (if field-names - (values result names) - result)))) - -;;; Execute - -(defgeneric execute-command (expression &key database) - (:documentation - "Executes the SQL command 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)) - -;;; 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/base/classes.lisp b/base/classes.lisp deleted file mode 100644 index acae96b..0000000 --- a/base/classes.lisp +++ /dev/null @@ -1,55 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: classes.lisp -;;;; Purpose: Classes for High-level SQL interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id$ -;;;; -;;;; 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 -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - - -(defclass database () - ((name :initform nil :initarg :name :reader database-name) - (connection-spec :initform nil :initarg :connection-spec - :reader connection-spec - :documentation "Require to use connection pool") - (database-type :initarg :database-type :initform :unknown - :reader database-type) - (state :initform :closed :reader database-state) - (command-recording-stream :accessor command-recording-stream :initform nil) - (result-recording-stream :accessor result-recording-stream :initform nil) - (record-caches :accessor record-caches :initform nil) - (view-classes :accessor database-view-classes :initform nil) - (schema :accessor database-schema :initform nil) - (transaction-level :initform 0 :accessor transaction-level) - (transaction :initform nil :accessor transaction) - (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool) - (attribute-cache :initform (make-hash-table :size 100 :test 'equal) - :accessor attribute-cache - :documentation "Internal cache of table attributes. It is keyed by table-name. Values -are a list of ACTION specified for table and any cached value of list-attributes-types.")) - (:documentation - "This class is the supertype of all databases handled by CLSQL.")) - -(defmethod print-object ((object database) stream) - (print-unreadable-object (object stream :type t :identity t) - (format stream "~A ~A" - (if (slot-boundp object 'name) - (database-name object) - "") - (database-state object)))) - - diff --git a/base/cmucl-compat.lisp b/base/cmucl-compat.lisp deleted file mode 100644 index d285788..0000000 --- a/base/cmucl-compat.lisp +++ /dev/null @@ -1,103 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; 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-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) - -(defpackage #:cmucl-compat - (:use #:common-lisp) - (:export - #:shrink-vector - #:make-sequence-of-type - #:result-type-or-lose - #:required-argument - )) -(in-package #:cmucl-compat) - -#+(or cmu scl) -(defmacro required-argument () - `(ext:required-argument)) - -#-(or cmu scl) -(defun required-argument () - (error "~&A required keyword argument was not supplied")) - -#+(or cmu scl) -(defmacro shrink-vector (vec len) - `(lisp::shrink-vector ,vec ,len)) - -#+sbcl -(defmacro shrink-vector (vec len) - `(sb-kernel::shrink-vector ,vec ,len)) - -#-(or cmu sbcl scl) -(defmacro shrink-vector (vec len) - "Shrinks a vector. Optimized if vector has a fill pointer. -Needs to be a macro to overwrite value of VEC." - (let ((new-vec (gensym))) - `(cond - ((adjustable-array-p ,vec) - (adjust-array ,vec ,len)) - ((typep ,vec 'simple-array) - (let ((,new-vec (make-array ,len :element-type - (array-element-type ,vec)))) - (check-type ,len fixnum) - (locally (declare (optimize (speed 3) (safety 0) (space 0)) ) - (dotimes (i ,len) - (declare (fixnum i)) - (setf (aref ,new-vec i) (aref ,vec i)))) - (setq ,vec ,new-vec))) - ((typep ,vec 'vector) - (setf (fill-pointer ,vec) ,len) - ,vec) - (t - (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) - ))) - - -#-(or cmu scl) -(defun make-sequence-of-type (type length) - "Returns a sequence of the given TYPE and LENGTH." - (make-sequence type length)) - -#+(or cmu scl) -(if (fboundp 'lisp::make-sequence-of-type) - (defun make-sequence-of-type (type len) - (lisp::make-sequence-of-type type len)) - (defun 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) - (unless (or type nil-ok) - (error "NIL output type invalid for this sequence function")) - (case type - ((list cons) - 'list) - ((string simple-string base-string simple-base-string) - 'string) - (simple-vector - 'simple-vector) - (vector - 'vector) - (t - (error "~S is a bad type specifier for sequence functions." type)) - )) - -#+(or cmu scl) -(defun result-type-or-lose (type nil-ok) - (lisp::result-type-or-lose type nil-ok)) diff --git a/base/conditions.lisp b/base/conditions.lisp deleted file mode 100644 index 6b7d971..0000000 --- a/base/conditions.lisp +++ /dev/null @@ -1,210 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: conditions.lisp -;;;; Purpose: Error conditions for high-level SQL interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id$ -;;;; -;;;; 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 -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - -(defvar *backend-warning-behavior* :warn - "Action to perform on warning messages from backend. Default is to :warn. May also be -set to :error to signal an error or :ignore/nil to silently ignore the warning.") - -;;; Conditions -(define-condition clsql-condition () - ()) - -(define-condition clsql-error (error clsql-condition) - ()) - -(define-condition clsql-simple-error (simple-condition clsql-error) - ()) - -(define-condition clsql-warning (warning clsql-condition) - ()) - -(define-condition clsql-simple-warning (simple-condition clsql-warning) - ()) - -(define-condition clsql-generic-error (clsql-error) - ((message :initarg :message - :reader clsql-generic-error-message)) - (:report (lambda (c stream) - (format stream (clsql-generic-error-message c))))) - -(define-condition clsql-invalid-spec-error (clsql-error) - ((connection-spec :initarg :connection-spec - :reader clsql-invalid-spec-error-connection-spec) - (database-type :initarg :database-type - :reader clsql-invalid-spec-error-database-type) - (template :initarg :template - :reader clsql-invalid-spec-error-template)) - (:report (lambda (c stream) - (format stream "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A" - (clsql-invalid-spec-error-connection-spec c) - (clsql-invalid-spec-error-database-type c) - (clsql-invalid-spec-error-template c))))) - -(defmacro check-connection-spec (connection-spec database-type template) - "Check the connection specification against the provided template, -and signal an clsql-invalid-spec-error if they don't match." - `(handler-case - (destructuring-bind ,template ,connection-spec - (declare (ignore ,@(remove '&optional template))) - t) - (error () (error 'clsql-invalid-spec-error - :connection-spec ,connection-spec - :database-type ,database-type - :template (quote ,template))))) - -(define-condition clsql-access-error (clsql-error) - ((database-type :initarg :database-type - :reader clsql-access-error-database-type) - (connection-spec :initarg :connection-spec - :reader clsql-access-error-connection-spec) - (error :initarg :error :reader clsql-access-error-error)) - (:report (lambda (c stream) - (format stream "While trying to access database ~A~% using database-type ~A:~% Error ~A~% has occurred." - (database-name-from-spec - (clsql-access-error-connection-spec c) - (clsql-access-error-database-type c)) - (clsql-access-error-database-type c) - (clsql-access-error-error c))))) - -(define-condition clsql-connect-error (clsql-access-error) - ((errno :initarg :errno :reader clsql-connect-error-errno)) - (:report (lambda (c stream) - (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred." - (database-name-from-spec - (clsql-access-error-connection-spec c) - (clsql-access-error-database-type c)) - (clsql-access-error-database-type c) - (clsql-connect-error-errno c) - (clsql-access-error-error c))))) - -(define-condition clsql-sql-error (clsql-error) - ((database :initarg :database :reader clsql-sql-error-database) - (message :initarg :message :initform nil :reader clsql-sql-error-message) - (expression :initarg :expression :initarg nil :reader clsql-sql-error-expression) - (errno :initarg :errno :initarg nil :reader clsql-sql-error-errno) - (error :initarg :error :initarg nil :reader clsql-sql-error-error)) - (:report (lambda (c stream) - (if (clsql-sql-error-message c) - (format stream "While accessing database ~A~%, Error~% ~A~% has occurred." - (clsql-sql-error-database c) - (clsql-sql-error-message c)) - (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred." - (clsql-sql-error-database c) - (clsql-sql-error-expression c) - (clsql-sql-error-errno c) - (clsql-sql-error-error c)))))) - -(define-condition clsql-database-warning (clsql-warning) - ((database :initarg :database :reader clsql-database-warning-database) - (message :initarg :message :reader clsql-database-warning-message)) - (:report (lambda (c stream) - (format stream "While accessing database ~A~% Warning: ~A~% has occurred." - (clsql-database-warning-database c) - (clsql-database-warning-message c))))) - -(define-condition clsql-exists-condition (clsql-condition) - ((old-db :initarg :old-db :reader clsql-exists-condition-old-db) - (new-db :initarg :new-db :reader clsql-exists-condition-new-db - :initform nil)) - (:report (lambda (c stream) - (format stream "In call to ~S:~%" 'connect) - (cond - ((null (clsql-exists-condition-new-db c)) - (format stream - " There is an existing connection ~A to database ~A." - (clsql-exists-condition-old-db c) - (database-name (clsql-exists-condition-old-db c)))) - ((eq (clsql-exists-condition-new-db c) - (clsql-exists-condition-old-db c)) - (format stream - " Using existing connection ~A to database ~A." - (clsql-exists-condition-old-db c) - (database-name (clsql-exists-condition-old-db c)))) - (t - (format stream - " Created new connection ~A to database ~A~%, although there is an existing connection (~A)." - (clsql-exists-condition-new-db c) - (database-name (clsql-exists-condition-new-db c)) - (clsql-exists-condition-old-db c))))))) - -(define-condition clsql-exists-warning (clsql-exists-condition - clsql-warning) - ()) - -(define-condition clsql-exists-error (clsql-exists-condition - clsql-error) - ()) - -(define-condition clsql-closed-error (clsql-error) - ((database :initarg :database :reader clsql-closed-error-database)) - (:report (lambda (c stream) - (format stream "The database ~A has already been closed." - (clsql-closed-error-database c))))) - -(define-condition clsql-no-database-error (clsql-error) - ((database :initarg :database :reader clsql-no-database-error-database)) - (:report (lambda (c stream) - (format stream "~S is not a CLSQL database." - (clsql-no-database-error-database c))))) - -(define-condition clsql-odbc-error (clsql-error) - ((odbc-message :initarg :odbc-message - :reader clsql-odbc-error-message) - (sql-state :initarg :sql-state :initform nil - :reader clsql-odbc-error-sql-state)) - (:report (lambda (c stream) - (format stream "[ODBC error] ~A; state: ~A" - (clsql-odbc-error-message c) - (clsql-odbc-error-sql-state c))))) - -;; Signal conditions - - -(defun signal-closed-database-error (database) - (cerror "Ignore this error and return nil." - 'clsql-closed-error - :database database)) - -(defun signal-no-database-error (database) - (error 'clsql-no-database-error :database database)) - -(define-condition clsql-type-error (clsql-error clsql-condition) - ((slotname :initarg :slotname - :reader clsql-type-error-slotname) - (typespec :initarg :typespec - :reader clsql-type-error-typespec) - (value :initarg :value - :reader clsql-type-error-value)) - (:report (lambda (c stream) - (format stream - "Invalid value ~A in slot ~A, not of type ~A." - (clsql-type-error-value c) - (clsql-type-error-slotname c) - (clsql-type-error-typespec c))))) - -(define-condition clsql-sql-syntax-error (clsql-error) - ((reason :initarg :reason - :reader clsql-sql-syntax-error-reason)) - (:report (lambda (c stream) - (format stream "Invalid SQL syntax: ~A" - (clsql-sql-syntax-error-reason c))))) - diff --git a/base/database.lisp b/base/database.lisp deleted file mode 100644 index f5a682e..0000000 --- a/base/database.lisp +++ /dev/null @@ -1,289 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; -;;;; $Id$ -;;;; -;;;; Base database functions -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - -(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.") - -(defun is-database-open (database) - (eql (database-state database) :open)) - -(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." - - (unless database-type - (error "Must specify a database-type.")) - - (when (stringp connection-spec) - (setq connection-spec (string-to-list-connection-spec connection-spec))) - - (unless (member database-type *loaded-database-types*) - (asdf:operate 'asdf:load-op (ensure-keyword - (concatenate 'string - (symbol-name '#:clsql-) - (symbol-name database-type))))) - - (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 - (setf (slot-value result 'state) :open) - (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*))) - (setf (slot-value database 'state) :closed) - 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." - (let ((db (etypecase database - (database database) - ((or string list) - (let ((db (find-database database :errorp nil))) - (when (null db) - (if (and database error) - (error 'clsql-generic-error - :message - (format nil "Unable to find database with connection-spec ~A." database)) - (return-from reconnect nil))) - db))))) - - (when (is-database-open db) - (if force - (ignore-errors (disconnect :database db)) - (disconnect :database db :error nil))) - - (connect (connection-spec db)))) - - -(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." - (flet ((get-data () - (let ((data '())) - (dolist (db (connected-databases) data) - (push - (append - (list (if (equal db *default-database*) "*" "") - (database-name db) - (string-downcase (string (database-type db))) - (cond ((and (command-recording-stream db) - (result-recording-stream db)) - "Both") - ((command-recording-stream db) "Commands") - ((result-recording-stream db) "Results") - (t "nil"))) - (when full - (list - (if (conn-pool db) "t" "nil") - (format nil "~A" (length (database-list-tables db))) - (format nil "~A" (length (database-list-views db)))))) - 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 #\-)))) - (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time))) - (let ((data (get-data))) - (when data - (let* ((titles (if full - (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" - "TABLES" "VIEWS") - (list "" "DATABASE" "TYPE" "RECORDING"))) - (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))) - -(defun create-database (connection-spec &key database-type) - (when (stringp connection-spec) - (setq connection-spec (string-to-list-connection-spec connection-spec))) - (database-create connection-spec database-type)) - -(defun probe-database (connection-spec &key database-type) - (when (stringp connection-spec) - (setq connection-spec (string-to-list-connection-spec connection-spec))) - (database-probe connection-spec database-type)) - -(defun destroy-database (connection-spec &key database-type) - (when (stringp connection-spec) - (setq connection-spec (string-to-list-connection-spec connection-spec))) - (database-destroy connection-spec database-type)) - -(defun list-databases (connection-spec &key database-type) - (when (stringp connection-spec) - (setq connection-spec (string-to-list-connection-spec connection-spec))) - (database-list connection-spec database-type)) - -(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 deleted file mode 100644 index 3ddfd89..0000000 --- a/base/db-interface.lisp +++ /dev/null @@ -1,321 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; 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 -;;;; onShoreD to support UncommonSQL front-end -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id$ -;;;; -;;;; 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 -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - -(defgeneric database-type-load-foreign (database-type) - (:documentation - "The internal generic implementation of reload-database-types.")) - -(defgeneric database-type-library-loaded (database-type) - (:documentation - "The internal generic implementation for checking if -database type library loaded successfully.")) - -(defgeneric database-initialize-database-type (database-type) - (:documentation - "The internal generic implementation of initialize-database-type.")) - -(defgeneric database-name-from-spec (connection-spec database-type) - (:documentation - "Returns the name of the database that would be created if connect -was called with the connection-spec.")) - -(defgeneric database-connect (connection-spec database-type) - (:documentation "Internal generic implementation of connect.")) - -(defgeneric database-reconnect (database) - (:method ((database t)) - (signal-no-database-error database)) - (:documentation "Internal generic implementation of reconnect.")) - -(defgeneric database-disconnect (database) - (:method ((database t)) - (signal-no-database-error database)) - (:documentation "Internal generic implementation of disconnect.")) - -(defgeneric database-query (query-expression database result-types field-names) - (:method (query-expression (database t) result-types field-names) - (declare (ignore query-expression result-types field-names)) - (signal-no-database-error database)) - (:documentation "Internal generic implementation of query.")) - - -(defgeneric database-execute-command (sql-expression database) - (:method (sql-expression (database t)) - (declare (ignore sql-expression)) - (signal-no-database-error database)) - (:documentation "Internal generic implementation of execute-command.")) - -;;; Mapping and iteration -(defgeneric database-query-result-set - (query-expression database &key full-set result-types) - (:method (query-expression (database t) &key full-set result-types) - (declare (ignore query-expression full-set result-types)) - (signal-no-database-error database) - (values nil nil nil)) - (:documentation - "Internal generic implementation of query mapping. Starts the -query specified by query-expression on the given database and returns -a result-set to be used with database-store-next-row and -database-dump-result-set to access the returned data. The second -value is the number of columns in the result-set, if there are any. -If full-set is true, the number of rows in the result-set is returned -as a third value, if this is possible (otherwise nil is returned for -the third value). This might have memory and resource usage -implications, since many databases will require the query to be -executed in full to answer this question. If the query produced no -results then nil is returned for all values that would have been -returned otherwise. If an error occurs during query execution, the -function should signal a clsql-sql-error.")) - -(defgeneric database-dump-result-set (result-set database) - (:method (result-set (database t)) - (declare (ignore result-set)) - (signal-no-database-error database)) - (:documentation "Dumps the received result-set.")) - -(defgeneric database-store-next-row (result-set database list) - (:method (result-set (database t) list) - (declare (ignore result-set list)) - (signal-no-database-error database)) - (:documentation - "Returns t and stores the next row in the result set in list or -returns nil when result-set is finished.")) - -(defgeneric database-create (connection-spec type) - (:documentation - "Creates a database, returns T if successfull or signals an error.")) - -(defgeneric database-probe (connection-spec type) - (:method (spec type) - (declare (ignore spec)) - (warn "database-proe not support for database-type ~A." type)) - (:documentation - "Probes for the existence of a database, returns T if database found or NIL -if not found. May signal an error if unable to communicate with database server.")) - -(defgeneric database-list (connection-spec type) - (:method (spec type) - (declare (ignore spec)) - (warn "database-list not support for database-type ~A." type)) - (:documentation - "Lists all databases found for TYPE. May signal an error if unable to communicate with database server.")) - -(defgeneric database-destroy (connection-spec database) - (:documentation "Destroys (drops) a database.")) - -(defgeneric database-truncate (database) - (:method ((database t)) - (signal-no-database-error database)) - (:documentation "Remove all data from database.")) - -(defgeneric database-describe-table (database table) - (:method ((database t) table) - (declare (ignore table)) - (signal-no-database-error database)) - (:documentation "Return a list of name/type for columns in table")) - -(defgeneric database-destory (connection-spec type) - (:documentation - "Destroys a database, returns T if successfull or signals an error -if unable to destory.")) - -(defgeneric database-create-sequence (name database) - (:documentation "Create a sequence in DATABASE.")) - -(defgeneric database-drop-sequence (name database) - (:documentation "Drop a sequence from DATABASE.")) - -(defgeneric database-sequence-next (name database) - (:documentation "Increment a sequence in DATABASE.")) - -(defgeneric database-list-sequences (database &key owner) - (:documentation "List all sequences in DATABASE.")) - -(defgeneric database-set-sequence-position (name position database) - (:documentation "Set the position of the sequence called NAME in DATABASE.")) - -(defgeneric database-sequence-last (name database) - (:documentation "Select the last value in sequence NAME in DATABASE.")) - -(defgeneric database-start-transaction (database) - (:documentation "Start a transaction in DATABASE.")) - -(defgeneric database-commit-transaction (database) - (:documentation "Commit current transaction in DATABASE.")) - -(defgeneric database-abort-transaction (database) - (:documentation "Abort current transaction in DATABASE.")) - -(defgeneric database-get-type-specifier (type args database) - (:documentation "Return the type SQL type specifier as a string, for -the given lisp type and parameters.")) - -(defgeneric database-list-tables (database &key owner) - (:documentation "List all tables in the given database")) - -(defgeneric database-list-views (database &key owner) - (:documentation "List all views in the DATABASE.")) - -(defgeneric database-list-indexes (database &key owner) - (:documentation "List all indexes in the DATABASE.")) - -(defgeneric database-list-table-indexes (table database &key owner) - (:documentation "List all indexes for a table in the DATABASE.")) - -(defgeneric database-list-attributes (table database &key owner) - (:documentation "List all attributes in TABLE.")) - -(defgeneric database-attribute-type (attribute table database &key owner) - (:documentation "Return the type of ATTRIBUTE in TABLE. Returns multiple values -of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.")) - -(defgeneric database-add-attribute (table attribute database) - (:documentation "Add the attribute to the table.")) - -(defgeneric database-rename-attribute (table oldatt newname database) - (:documentation "Rename the attribute in the table to NEWNAME.")) - -(defgeneric oid (object) - (:documentation "Return the unique ID of a database object.")) - -;;; Database backend capabilities - -(defgeneric database-underlying-type (database) - (:method (database) - (database-type database)) - (:documentation "Returns the type of the underlying database. For ODBC, needs to query ODBC driver.")) - -(defgeneric db-type-use-column-on-drop-index? (db-type) - (:method (db-type) - (declare (ignore db-type)) - nil) - (:documentation "NIL [default] if database-type does not use column name on DROP INDEX.")) - -(defgeneric db-type-has-views? (db-type) - (:method (db-type) - (declare (ignore db-type)) - ;; SQL92 has views - t) - (:documentation "T [default] if database-type supports views.")) - -(defgeneric db-type-default-case (db-type) - (:method (db-type) - (declare (ignore db-type)) - ;; By default, CommonSQL converts identifiers to UPPER case. - :upper) - (:documentation ":upper [default] if means identifiers mapped to UPPER case SQL like CommonSQL API. However, Postgresql maps identifiers to lower case, so PostgreSQL uses a value of :lower for this result.")) - -(defgeneric db-type-has-fancy-math? (db-type) - (:method (db-type) - (declare (ignore db-type)) - nil) - (:documentation "NIL [default] if database-type does not have fancy math.")) - -(defgeneric db-type-has-subqueries? (db-type) - (:method (db-type) - (declare (ignore db-type)) - t) - (:documentation "T [default] if database-type supports views.")) - -(defgeneric db-type-has-boolean-where? (db-type) - (:method (db-type) - (declare (ignore db-type)) - ;; SQL99 has boolean where - t) - (:documentation "T [default] if database-type supports boolean WHERE clause, such as 'WHERE MARRIED'.")) - -(defgeneric db-backend-has-create/destroy-db? (db-type) - (:method (db-type) - (declare (ignore db-type)) - t) - (:documentation "T [default] if backend can destroy and create databases.")) - -(defgeneric db-type-transaction-capable? (db database) - (:method (db database) - (declare (ignore db database)) - t) - (:documentation "T [default] if database can supports transactions.")) - -;;; Large objects support (Marc Battyani) - -(defgeneric database-create-large-object (database) - (:documentation "Creates a new large object in the database and returns the object identifier")) - -(defgeneric database-write-large-object (object-id data database) - (:documentation "Writes data to the large object")) - -(defgeneric database-read-large-object (object-id database) - (:documentation "Reads the large object content")) - -(defgeneric database-delete-large-object (object-id database) - (:documentation "Deletes the large object in the database")) - - -;; Checks for closed database - -(defmethod database-disconnect :before ((database database)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defmethod database-query :before (query-expression (database database) - result-set field-names) - (declare (ignore query-expression result-set field-names)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defmethod database-execute-command :before (sql-expression (database database)) - (declare (ignore sql-expression)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defmethod database-query-result-set :before (expr (database database) - &key full-set result-types) - (declare (ignore expr full-set result-types)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defmethod database-dump-result-set :before (result-set (database database)) - (declare (ignore result-set)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defmethod database-store-next-row :before (result-set (database database) list) - (declare (ignore result-set list)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defmethod database-commit-transaction :before ((database database)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defmethod database-start-transaction :before ((database database)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defmethod database-abort-transaction :before ((database database)) - (unless (is-database-open database) - (signal-closed-database-error database))) - -(defgeneric describe-table (table &key database) - (:documentation "Describes a table, returns a list of name/type for columns in table")) - diff --git a/base/initialize.lisp b/base/initialize.lisp deleted file mode 100644 index 3211512..0000000 --- a/base/initialize.lisp +++ /dev/null @@ -1,58 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; 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-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 -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - -(defvar *loaded-database-types* nil - "Contains a list of database types which have been defined/loaded.") - -(defmethod database-type-load-foreign (x) - (error "No generic function defined for database-type-load-foreign with parameters of ~S" x)) - -(defmethod database-type-load-foreign :after (database-type) - (when (database-type-library-loaded database-type) - (pushnew database-type *loaded-database-types*))) - -(defun reload-database-types () - "Reloads any foreign code for the loaded database types after a dump." - (mapc #'database-type-load-foreign *loaded-database-types*)) - -(defvar *default-database-type* nil - "Specifies the default type of database.") - -(defvar *initialized-database-types* nil - "Contains a list of database types which have been initialized by calls -to initialize-database-type.") - -(defun initialize-database-type (&key (database-type *default-database-type*)) - "Initialize the given database-type, if it is not already -initialized, as indicated by `*initialized-database-types*'." - (when (member database-type *initialized-database-types*) - (return-from initialize-database-type database-type)) - - (let ((system (intern (concatenate 'string - (symbol-name '#:clsql-) - (symbol-name database-type))))) - (when (not (find-package system)) - (asdf:operate 'asdf:load-op system))) - - (when (database-initialize-database-type database-type) - (push database-type *initialized-database-types*) - database-type)) - diff --git a/base/loop-extension.lisp b/base/loop-extension.lisp deleted file mode 100644 index 1746832..0000000 --- a/base/loop-extension.lisp +++ /dev/null @@ -1,229 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: loop-extension.lisp -;;;; Purpose: Extensions to the Loop macro for CLSQL -;;;; -;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai -;;;; -;;;; $Id$ -;;;; ************************************************************************* - -(in-package #:cl-user) - -#+(or allegro sbcl) -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage #:ansi-loop - (:import-from #+sbcl #:sb-loop #+allegro #:excl - #:loop-error - #:*loop-epilogue* - #:*loop-ansi-universe* - #:add-loop-path))) - -#+(or allegro sbcl) -(defun ansi-loop::loop-gentemp (&optional (pref 'loopva-)) - (gensym (string pref))) - -#+(or cmu scl sbcl openmcl allegro) -(defun loop-record-iteration-path (variable data-type prep-phrases) - (let ((in-phrase nil) - (from-phrase nil)) - (loop for (prep . rest) in prep-phrases - do - (case prep - ((:in :of) - (when in-phrase - (ansi-loop::loop-error - "Duplicate OF or IN iteration path: ~S." (cons prep rest))) - (setq in-phrase rest)) - ((:from) - (when from-phrase - (ansi-loop::loop-error - "Duplicate FROM iteration path: ~S." (cons prep rest))) - (setq from-phrase rest)) - (t - (ansi-loop::loop-error - "Unknown preposition: ~S." prep)))) - (unless in-phrase - (ansi-loop::loop-error "Missing OF or IN iteration path.")) - (unless from-phrase - (setq from-phrase '(clsql-base:*default-database*))) - - (unless (consp variable) - (setq variable (list variable))) - - (cond - ;; object query - ((and (consp (first in-phrase)) - (string-equal "sql-query" (symbol-name (caar in-phrase))) - (consp (second (first in-phrase))) - (eq 'quote (first (second (first in-phrase)))) - (symbolp (second (second (first in-phrase))))) - - (let ((result-var (ansi-loop::loop-gentemp - 'loop-record-result-)) - (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) - `(((,variable nil ,@(and data-type (list data-type))) - (,result-var (clsql-base:query ,(first in-phrase))) - (,step-var nil)) - () - () - () - (if (null ,result-var) - t - (progn - (setq ,step-var (first ,result-var)) - (setq ,result-var (rest ,result-var)) - nil)) - (,variable ,step-var) - (null ,result-var) - () - (if (null ,result-var) - t - (progn - (setq ,step-var (first ,result-var)) - (setq ,result-var (rest ,result-var)) - nil)) - (,variable ,step-var)))) - - ((consp variable) - (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) - (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) - (result-set-var (ansi-loop::loop-gentemp - 'loop-record-result-set-)) - (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) - (push `(when ,result-set-var - (clsql-base:database-dump-result-set ,result-set-var ,db-var)) - ansi-loop::*loop-epilogue*) - `(((,variable nil ,@(and data-type (list data-type))) - (,query-var ,(first in-phrase)) - (,db-var ,(first from-phrase)) - (,result-set-var nil) - (,step-var nil)) - ((multiple-value-bind (%rs %cols) - (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto) - (setq ,result-set-var %rs ,step-var (make-list %cols)))) - () - () - (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var) - (not ,result-set-var) - () - (not (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var)) - (,variable ,step-var))))))) - -#+(or cmu scl sbcl openmcl allegro) -(ansi-loop::add-loop-path '(record records tuple tuples) - 'loop-record-iteration-path - ansi-loop::*loop-ansi-universe* - :preposition-groups '((:of :in) (:from)) - :inclusive-permitted nil) - -#+lispworks -(eval-when (:compile-toplevel :load-toplevel :execute) - (in-package loop)) - -#+lispworks -(cl-user::define-loop-method (record records tuple tuples) clsql-loop-method - (in of from)) - -#+lispworks -(defun clsql-loop-method (method-name iter-var iter-var-data-type - prep-phrases inclusive? allowed-preps - method-specific-data) - (declare (ignore method-name inclusive? allowed-preps method-specific-data)) - (let ((in-phrase nil) - (from-phrase nil)) - (loop for (prep . rest) in prep-phrases - do - (cond - ((or (eq prep 'in) (eq prep 'of)) - (when in-phrase - (error - "Duplicate OF or IN iteration path: ~S." (cons prep rest))) - (setq in-phrase rest)) - ((eq prep 'from) - (when from-phrase - (error - "Duplicate FROM iteration path: ~S." (cons prep rest))) - (setq from-phrase rest)) - (t - (error - "Unknown preposition: ~S." prep)))) - (unless in-phrase - (error "Missing OF or IN iteration path.")) - (unless from-phrase - (setq from-phrase '(clsql-base:*default-database*))) - - (unless (consp iter-var) - (setq iter-var (list iter-var))) - - (cond - ;; object query - ((and (consp in-phrase) - (string-equal "sql-query" (symbol-name (car in-phrase))) - (consp (second in-phrase)) - (eq 'quote (first (second in-phrase))) - (symbolp (second (second in-phrase)))) - - (let ((result-var (gensym "LOOP-RECORD-RESULT-")) - (step-var (gensym "LOOP-RECORD-STEP-"))) - (values - t - nil - `(,@(mapcar (lambda (v) `(,v nil)) iter-var) - (,result-var (clsql-base:query ,in-phrase)) - (,step-var nil)) - () - () - () - `((if (null ,result-var) - t - (progn - (setq ,step-var (first ,result-var)) - (setq ,result-var (rest ,result-var)) - nil))) - `(,iter-var ,step-var) - `((if (null ,result-var) - t - (progn - (setq ,step-var (first ,result-var)) - (setq ,result-var (rest ,result-var)) - nil))) - `(,iter-var ,step-var) - () - () - ))) - - ((consp iter-var) - (let ((query-var (gensym "LOOP-RECORD-")) - (db-var (gensym "LOOP-RECORD-DATABASE-")) - (result-set-var (gensym "LOOP-RECORD-RESULT-SET-")) - (step-var (gensym "LOOP-RECORD-STEP-"))) - (values - t - nil - `(,@(mapcar (lambda (v) `(,v nil)) iter-var) - (,query-var ,in-phrase) - (,db-var ,(first from-phrase)) - (,result-set-var nil) - (,step-var nil)) - `((multiple-value-bind (%rs %cols) - (clsql-base:database-query-result-set ,query-var ,db-var :result-types :auto) - (setq ,result-set-var %rs ,step-var (make-list %cols)))) - () - () - `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var) - (when ,result-set-var - (clsql-base:database-dump-result-set ,result-set-var ,db-var)) - t)) - `(,iter-var ,step-var) - `((unless (clsql-base:database-store-next-row ,result-set-var ,db-var ,step-var) - (when ,result-set-var - (clsql-base:database-dump-result-set ,result-set-var ,db-var)) - t)) - `(,iter-var ,step-var) - () - ())))))) - diff --git a/base/package.lisp b/base/package.lisp deleted file mode 100644 index cfed6e8..0000000 --- a/base/package.lisp +++ /dev/null @@ -1,305 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.lisp -;;;; Purpose: Package definition for base (low-level) SQL interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id$ -;;;; -;;;; 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 -;;;; 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) - -;;;; This file makes the required package definitions for CLSQL's -;;;; core packages. - -(defpackage #:clsql-base - (:use #:cl) - (:export - #:check-connection-spec - #:database-type-load-foreign - #:database-type-library-loaded ;; KMR - Tests if foreign library okay - #:database-initialize-database-type - #:database-connect - #:database-disconnect - #:database-reconnect - #:database-query - #:database-execute-command - #:database-query-result-set - #:database-dump-result-set - #:database-store-next-row - #:database-create - #:database-destroy - #:database-probe - #:database-list - #:database-describe-table - #:database-underlying-type - - #:database-list-tables - #:database-list-attributes - #:database-attribute-type - #:database-create-sequence - #:database-drop-sequence - #:database-sequence-next - #:sql-escape - #:database-sequence-last - #:database-set-sequence-position - #:database-list-attributes - #:database-list-sequences - #:database-list-indexes - #:database-list-table-indexes - #:database-list-views - - ;; Large objects - #:database-create-large-object - #:database-write-large-object - #:database-read-large-object - #:database-delete-large-object - #:create-large-object - #:write-large-object - #:read-large-object - #:delete-large-object - - #:command-output - #:make-process-lock - #:with-process-lock - #:connection-spec - #:ensure-keyword - - ;; utils.lisp - #:without-interrupts - #:make-process-lock - #:with-process-lock - #:command-output - #:symbol-name-default-case - #:convert-to-db-default-case - #:ensure-keyword - - #: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-access-error - #:clsql-access-error-database-type - #:clsql-access-error-connection-spec - #:clsql-access-error-error - #:clsql-connect-error - #:clsql-connect-error-errno - #: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-sql-syntax-error - #:clsql-type-error - #:clsql-odbc-error - #:clsql-odbc-error-message - #:*backend-warning-behavior* - - #:*loaded-database-types* - #:reload-database-types - #:*default-database-type* - #:*initialized-database-types* - #:initialize-database-type - #:*connect-if-exists* - #:*default-database* - #:connected-databases - #:database - #:database-name - #:find-database - #:database-name-from-spec - #:is-database-open - - ;; accessors for database class - #:name - #:connection-spec - #:transaction - #:transaction-level - #:conn-pool - #:command-recording-stream - #:result-recording-stream - #:record-caches - #:view-classes - #:database-type - #:database-state - #:attribute-cache - - ;; 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 - #:duration-timestring - #:extract-roman - #:format-duration - #:format-time - #:get-time - #:utime->time - #:interval-clear - #:interval-contained - #:interval-data - #:interval-edit - #:interval-end - #:interval-match - #:interval-push - #:interval-relation - #:interval-start - #:interval-type - #:make-duration - #:make-interval - #:make-time - #:merged-time - #:midnight - #:month-name - #:parse-date-time - #:parse-timestring - #:parse-yearstring - #:print-date - #:roll - #:roll-to - #:time - #:time+ - #:time- - #:time-by-adding-duration - #:time-compare - #:time-difference - #:time-dow - #:time-element - #:time-max - #:time-min - #:time-mjd - #:time-msec - #:time-p - #:time-sec - #:time-well-formed - #:time-ymd - #:time< - #:time<= - #:time= - #:time> - #:time>= - #:timezone - #:universal-time - #:wall-time - #:wall-timestring - #:week-containing - #:gregorian-to-mjd - #:mjd-to-gregorian - - ;; recording.lisp -- SQL I/O Recording - #:record-sql-command - #:record-sql-result - #:add-sql-stream ; recording xx - #:delete-sql-stream ; recording xx - #:list-sql-streams ; recording xx - #:sql-recording-p ; recording xx - #:sql-stream ; recording xx - #:start-sql-recording ; recording xx - #:stop-sql-recording ; recording xx - - ;; 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 - #:disconnect-pooled - #:create-database - #:destroy-database - #:probe-database - #:list-databases - - ;; basic-sql.lisp - #:query - #:execute-command - #:write-large-object - #:read-large-object - #:delete-large-object - #:describe-table - - ;; 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 - - ;; Database features specialized by backend - #:db-type-use-column-on-drop-index? - #:db-type-has-views? - #:db-type-has-subqueries? - #:db-type-has-boolean-where? - #:db-type-has-fancy-math? - #:db-type-default-case - #:db-backend-has-create/destroy-db? - #:db-type-transaction-capable? - ) - (:documentation "This is the INTERNAL SQL-Interface package of CLSQL-BASE.")) - - diff --git a/base/pool.lisp b/base/pool.lisp deleted file mode 100644 index 0564eb0..0000000 --- a/base/pool.lisp +++ /dev/null @@ -1,111 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: pool.lisp -;;;; Purpose: Support function for connection pool -;;;; Programmers: Kevin M. Rosenberg, Marc Battyani -;;;; Date Started: Apr 2002 -;;;; -;;;; $Id$ -;;;; -;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 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 #:clsql-base) - -(defvar *db-pool* (make-hash-table :test #'equal)) -(defvar *db-pool-lock* (make-process-lock "DB Pool lock")) - -(defclass conn-pool () - ((connection-spec :accessor connection-spec :initarg :connection-spec) - (database-type :accessor pool-database-type :initarg :pool-database-type) - (free-connections :accessor free-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)) - (all-connections :accessor all-connections - :initform (make-array 5 :fill-pointer 0 :adjustable t)) - (lock :accessor conn-pool-lock - :initform (make-process-lock "Connection pool")))) - -(defun acquire-from-conn-pool (pool) - (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool") - (and (plusp (length (free-connections pool))) - (vector-pop (free-connections pool)))) - (let ((conn (connect (connection-spec pool) - :database-type (pool-database-type pool) - :if-exists :new))) - (with-process-lock ((conn-pool-lock pool) "Acquire from pool") - (vector-push-extend conn (all-connections pool)) - (setf (conn-pool conn) pool)) - conn))) - -(defun release-to-conn-pool (conn) - (let ((pool (conn-pool conn))) - (with-process-lock ((conn-pool-lock pool) "Release to pool") - (vector-push-extend conn (free-connections pool))))) - -(defun clear-conn-pool (pool) - (with-process-lock ((conn-pool-lock pool) "Clear pool") - (loop for conn across (all-connections pool) - do (setf (conn-pool conn) nil) - (disconnect :database conn)) - (setf (fill-pointer (free-connections pool)) 0) - (setf (fill-pointer (all-connections pool)) 0)) - 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" - (with-process-lock (*db-pool-lock* "Find-or-create connection") - (let* ((key (list connection-spec database-type)) - (conn-pool (gethash key *db-pool*))) - (unless conn-pool - (setq conn-pool (make-instance 'conn-pool - :connection-spec connection-spec - :pool-database-type database-type)) - (setf (gethash key *db-pool*) conn-pool)) - conn-pool))) - -(defun acquire-from-pool (connection-spec database-type &optional pool) - (unless (typep pool 'conn-pool) - (setf pool (find-or-create-connection-pool connection-spec database-type))) - (acquire-from-conn-pool pool)) - -(defun release-to-pool (database) - (release-to-conn-pool database)) - -(defun disconnect-pooled (&optional clear) - "Disconnects all connections in the pool." - (with-process-lock (*db-pool-lock* "Disconnect pooled") - (maphash - #'(lambda (key conn-pool) - (declare (ignore key)) - (clear-conn-pool conn-pool)) - *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 deleted file mode 100644 index 85620f7..0000000 --- a/base/recording.lisp +++ /dev/null @@ -1,150 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; -;;;; $Id$ -;;;; -;;;; CLSQL broadcast streams which can be used to monitor the -;;;; flow of commands to, and results from, a database. -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - -(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 deleted file mode 100644 index 0b70f2c..0000000 --- a/base/time.lisp +++ /dev/null @@ -1,1122 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; -;;;; $Id$ -;;;; -;;;; A variety of structures and function for creating and -;;;; manipulating dates, times, durations and intervals for -;;;; CLSQL. -;;;; -;;;; This file was originally part of ODCL and is Copyright (c) 2002 - -;;;; 2003 onShore Development, Inc. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - -;; ------------------------------------------------------------ -;; 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 - -(defun duration-timestring (duration) - (let ((second (duration-second duration)) - (minute (duration-minute duration)) - (hour (duration-hour duration)) - (day (duration-day duration))) - (format nil "P~dD~dH~dM~dS" day hour minute second))) - - -;; ------------------------------------------------------------ -;; 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 utime->time (utime) - "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)" - (multiple-value-bind (second minute hour day mon year) - (decode-universal-time utime) - (make-time :year year :month mon :day day :hour hour :minute minute - :second second))) - -(defun get-time () - "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)" - (utime->time (get-universal-time))) - -(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 (month day year) - (mjd-to-gregorian (time-mjd time)) - (values year month 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 &optional round) - (ecase precision - (:second - (+ (duration-second duration) - (* (duration-reduce duration :minute) 60))) - (:minute - (+ (if round - (floor (duration-second duration) 30) - 0) - (duration-minute duration) - (* (duration-reduce duration :hour) 60))) - (:hour - (+ (if round - (floor (duration-minute duration) 30) - 0) - (duration-hour duration) - (* (duration-reduce duration :day) 24))) - (:day - (+ (if round - (floor (duration-hour duration) 12) - 0) - (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) (setf 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) (setf 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) - (name 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! - (let ((list (sort-interval-list list))) - (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)))))) - -(defun interval-clear (list time) - (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" - (let ((*print-circle* nil)) - (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-month () - (second (mjd-to-gregorian (time-mjd (get-time))))) - -(defun current-day () - (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")))) - -(defgeneric to-string (val &rest keys) - ) - -(defmethod to-string ((time wall-time) &rest keys) - (destructuring-bind (&key (style :daytime) &allow-other-keys) - keys - (print-date time style))) - -(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) - (setf doy (- doy (floor (+ 23 (* 4 month)) 10))) - (when (leap-year? year) - (incf doy))) - doy)) - -(defun parse-yearstring (string) - (let ((year (or (parse-integer-insensitively string) - (extract-roman string)))) - (when (and year (< 1500 year 2500)) - (make-time :year year)))) - -(defun parse-integer-insensitively (string) - (let ((start (position-if #'digit-char-p string)) - (end (position-if #'digit-char-p string :from-end t))) - (when (and start end) - (parse-integer (subseq string start (1+ end)) :junk-allowed t)))) - -(defvar *roman-digits* - '((#\M . 1000) - (#\D . 500) - (#\C . 100) - (#\L . 50) - (#\X . 10) - (#\V . 5) - (#\I . 1))) - -(defun extract-roman (string &aux parse) - (dotimes (x (length string)) - (let ((val (cdr (assoc (aref string x) *roman-digits*)))) - (when (and val parse (< (car parse) val)) - (push (- (pop parse)) parse)) - (push val parse))) - (apply #'+ parse)) - - -;; ------------------------------------------------------------ -;; 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)))) - (setf 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 deleted file mode 100644 index 61438ed..0000000 --- a/base/transaction.lisp +++ /dev/null @@ -1,102 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; -;;;; $Id$ -;;;; -;;;; Transaction support -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-base) - -(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) - (unless database (error 'clsql-no-database-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) - (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) - (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 deleted file mode 100644 index 8a96df6..0000000 --- a/base/utils.lisp +++ /dev/null @@ -1,343 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; 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-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 #:clsql-base) - -(defun number-to-sql-string (num) - (etypecase num - (integer - num) - (rational - (float-to-sql-string (coerce num 'double-float))) - (number - (float-to-sql-string num)))) - -(defun float-to-sql-string (num) - "Convert exponent character for SQL" - (let ((str (write-to-string num :readably t))) - (cond - ((find #\f str) - (substitute #\e #\f str)) - ((find #\d str) - (substitute #\e #\d str)) - ((find #\l str) - (substitute #\e #\l str)) - ((find #\s str) - (substitute #\e #\S str)) - ((find #\F str) - (substitute #\e #\F str)) - ((find #\D str) - (substitute #\e #\D str)) - ((find #\L str) - (substitute #\e #\L str)) - ((find #\S str) - (substitute #\e #\S str)) - (t - str)))) - -(defun sql-escape (identifier) - "Change hyphens to underscores, ensure string" - (let* ((unescaped (etypecase identifier - (symbol (symbol-name identifier)) - (string identifier))) - (escaped (make-string (length unescaped)))) - (dotimes (i (length unescaped)) - (setf (char escaped i) - (cond ((equal (char unescaped i) #\-) - #\_) - ;; ... - (t - (char unescaped i))))) - escaped)) - -(defmacro without-interrupts (&body body) - #+lispworks `(mp:without-preemption ,@body) - #+allegro `(mp:without-scheduling ,@body) - #+cmu `(system:without-interrupts ,@body) - #+sbcl `(sb-sys::without-interrupts ,@body) - #+openmcl `(ccl:without-interrupts ,@body)) - -(defun make-process-lock (name) - #+allegro (mp:make-process-lock :name name) - #+cmu (mp:make-lock name) - #+lispworks (mp:make-lock :name name) - #+openmcl (ccl:make-lock name) - #+sb-thread (sb-thread:make-mutex :name name) - #+scl (thread:make-lock name) - #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name)) - #-(or allegro cmu lispworks openmcl sb-thread scl) nil) - -(defmacro with-process-lock ((lock desc) &body body) - #+(or cmu allegro lispworks openmcl sb-thread) - (declare (ignore desc)) - #+(or allegro cmu lispworks openmcl sb-thread) - (let ((l (gensym))) - `(let ((,l ,lock)) - #+allegro (mp:with-process-lock (,l) ,@body) - #+cmu (mp:with-lock-held (,l) ,@body) - #+openmcl (ccl:with-lock-grabbed (,l) ,@body) - #+lispworks (mp:with-lock (,l) ,@body) - #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body) - )) - #+scl `(thread:with-lock-held (,lock ,desc) ,@body) - #-(or cmu allegro lispworks openmcl sb-thread scl) (declare - (ignore lock desc)) - #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body)) - -(defun sql-escape-quotes (s) - "Escape quotes for SQL string writing" - (substitute-string-for-char s #\' "''")) - -(defun substitute-string-for-char (procstr match-char subst-str) -"Substitutes a string for a single matching character of a string" - (let ((pos (position match-char procstr))) - (if pos - (concatenate 'string - (subseq procstr 0 pos) subst-str - (substitute-string-for-char - (subseq procstr (1+ pos)) match-char subst-str)) - procstr))) - - -(defun position-char (char string start max) - "From KMRCL." - (declare (optimize (speed 3) (safety 0) (space 0)) - (fixnum start max) (simple-string string)) - (do* ((i start (1+ i))) - ((= i max) nil) - (declare (fixnum i)) - (when (char= char (schar string i)) (return i)))) - -(defun delimited-string-to-list (string &optional (separator #\space) - skip-terminal) - "Split a string with delimiter, from KMRCL." - (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)) - (type string string) - (type character separator)) - (do* ((len (length string)) - (output '()) - (pos 0) - (end (position-char separator string pos len) - (position-char separator string pos len))) - ((null end) - (if (< pos len) - (push (subseq string pos) output) - (when (or (not skip-terminal) (zerop len)) - (push "" output))) - (nreverse output)) - (declare (type fixnum pos len) - (type (or null fixnum) end)) - (push (subseq string pos end) output) - (setq pos (1+ end)))) - -(defun string-to-list-connection-spec (str) - (let ((at-pos (position-char #\@ str 0 (length str)))) - (cond - ((and at-pos (> (length str) at-pos)) - ;; Connection spec is SQL*NET format - (cons (subseq str (1+ at-pos)) - (delimited-string-to-list (subseq str 0 at-pos) #\/))) - (t - (delimited-string-to-list str #\/))))) - -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (unless (find-package '#:excl.osi) - (require 'osi))) - -(defun command-output (control-string &rest args) - ;; Concatenates output and error since Lispworks combines - ;; these, thus CLSQL can't depend upon separate results - (multiple-value-bind (output error status) - (apply #'%command-output control-string args) - (values - (concatenate 'string (if output output "") - (if error error "")) - status))) - -(defun read-stream-to-string (in) - (with-output-to-string (out) - (let ((eof (gensym))) - (do ((line (read-line in nil eof) - (read-line in nil eof))) - ((eq line eof)) - (format out "~A~%" line))))) - -;; From KMRCL -(defun %command-output (control-string &rest args) - "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and -synchronously execute the result using a Bourne-compatible shell, -returns (VALUES string-output error-output exit-status)" - (let ((command (apply #'format nil control-string args))) - #+sbcl - (let* ((process (sb-ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output :stream :error :stream)) - (output (read-stream-to-string (sb-impl::process-output process))) - (error (read-stream-to-string (sb-impl::process-error process)))) - (close (sb-impl::process-output process)) - (close (sb-impl::process-error process)) - (values - output - error - (sb-impl::process-exit-code process))) - - - #+(or cmu scl) - (let* ((process (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output :stream :error :stream)) - (output (read-stream-to-string (ext::process-output process))) - (error (read-stream-to-string (ext::process-error process)))) - (close (ext::process-output process)) - (close (ext::process-error process)) - - (values - output - error - (ext::process-exit-code process))) - - #+allegro - (multiple-value-bind (output error status) - (excl.osi:command-output command :whole t) - (values output error status)) - - #+lispworks - ;; BUG: Lispworks combines output and error streams - (let ((output (make-string-output-stream))) - (unwind-protect - (let ((status - (system:call-system-showing-output - command - :shell-type "/bin/sh" - :output-stream output))) - (values (get-output-stream-string output) nil status)) - (close output))) - - #+clisp - ;; BUG: CLisp doesn't allow output to user-specified stream - (values - nil - nil - (ext:run-shell-command command :output :terminal :wait t)) - - #+openmcl - (let* ((process (ccl:run-program - "/bin/sh" - (list "-c" command) - :input nil :output :stream :error :stream - :wait t)) - (output (read-stream-to-string (ccl::external-process-output-stream process))) - (error (read-stream-to-string (ccl::external-process-error-stream process)))) - (close (ccl::external-process-output-stream process)) - (close (ccl::external-process-error-stream process)) - (values output - error - (nth-value 1 (ccl::external-process-status process)))) - - #-(or openmcl clisp lispworks allegro scl cmu sbcl) - (error "COMMAND-OUTPUT not implemented for this Lisp") - - )) - - -;; From KMRCL -(defmacro in (obj &rest choices) - (let ((insym (gensym))) - `(let ((,insym ,obj)) - (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c)) - choices))))) - -;; From KMRCL -(defun substitute-char-string (procstr match-char subst-str) - "Substitutes a string for a single matching character of a string" - (substitute-chars-strings procstr (list (cons match-char subst-str)))) - -(defun replaced-string-length (str repl-alist) - (declare (simple-string str) - (optimize (speed 3) (safety 0) (space 0))) - (do* ((i 0 (1+ i)) - (orig-len (length str)) - (new-len orig-len)) - ((= i orig-len) new-len) - (declare (fixnum i orig-len new-len)) - (let* ((c (char str i)) - (match (assoc c repl-alist :test #'char=))) - (declare (character c)) - (when match - (incf new-len (1- (length - (the simple-string (cdr match))))))))) - - -(defun substitute-chars-strings (str repl-alist) - "Replace all instances of a chars with a string. repl-alist is an assoc -list of characters and replacement strings." - (declare (simple-string str) - (optimize (speed 3) (safety 0) (space 0))) - (do* ((orig-len (length str)) - (new-string (make-string (replaced-string-length str repl-alist))) - (spos 0 (1+ spos)) - (dpos 0)) - ((>= spos orig-len) - new-string) - (declare (fixnum spos dpos) (simple-string new-string)) - (let* ((c (char str spos)) - (match (assoc c repl-alist :test #'char=))) - (declare (character c)) - (if match - (let* ((subst (cdr match)) - (len (length subst))) - (declare (fixnum len) - (simple-string subst)) - (dotimes (j len) - (declare (fixnum j)) - (setf (char new-string dpos) (char subst j)) - (incf dpos))) - (progn - (setf (char new-string dpos) c) - (incf dpos)))))) - - -(eval-when (:compile-toplevel :load-toplevel :execute) - (when (char= #\a (schar (symbol-name '#:a) 0)) - (pushnew :lowercase-reader *features*))) - -(defun symbol-name-default-case (str) - #-lowercase-reader - (string-upcase str) - #+lowercase-reader - (string-downcase str)) - -(defun convert-to-db-default-case (str database) - (if database - (case (db-type-default-case (database-underlying-type database)) - (:upper (string-upcase str)) - (:lower (string-downcase str)) - (t str)) - ;; Default CommonSQL behavior is to upcase strings - (string-upcase str))) - - -(defun ensure-keyword (name) - "Returns keyword for a name" - (etypecase name - (keyword name) - (string (nth-value 0 (intern (symbol-name-default-case name) :keyword))) - (symbol (nth-value 0 (intern (symbol-name name) :keyword))))) diff --git a/classic/.gitignore b/classic/.gitignore deleted file mode 100644 index 1d27afc..0000000 --- a/classic/.gitignore +++ /dev/null @@ -1,14 +0,0 @@ -clsql-uffi.so -clsql-uffi.dll -clsql-uffi.lib -clsql-uffi.dylib -.bin -*.fasl -*.pfsl -*.dfsl -*.cfsl -*.fasla16 -*.fasla8 -*.faslm16 -*.faslm8 -*.fsl diff --git a/classic/Makefile b/classic/Makefile deleted file mode 100644 index 31dc910..0000000 --- a/classic/Makefile +++ /dev/null @@ -1,6 +0,0 @@ -SUBDIRS := - -include ../Makefile.common - -.PHONY: distclean -distclean: clean diff --git a/classic/functional.lisp b/classic/functional.lisp deleted file mode 100644 index 565c40d..0000000 --- a/classic/functional.lisp +++ /dev/null @@ -1,77 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: functional.lisp -;;;; Purpose: Functional interface -;;;; -;;;; Copyright (c) 1999-2001 Pierre R. Mai -;;;; -;;;; $Id$ -;;;; -;;;; This file is part of CLSQL. -;;;; -;;;; CLSQL users are granted the rights to distribute and use this software -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-classic) - -;;; This file implements the more advanced functions of the -;;; functional SQL interface, which are just nicer layers above the -;;; basic SQL interface. - -;;; These functions are no longer exported since they conflict with names -;;; exported by CLSQL - -(defun insert-records - (&key into attributes values av-pairs query (database *default-database*)) - "Insert records into the given table according to the given options." - (cond - ((and av-pairs (or attributes values)) - (error "Supply either av-pairs or values (and possibly attributes) to call of insert-records.")) - ((and (or av-pairs values) query) - (error - "Supply either query or values/av-pairs to call of insert-records.")) - ((and attributes (not query) - (or (not (listp values)) (/= (length attributes) (length values)))) - (error "You must supply a matching values list when using attributes in call of insert-records.")) - (query - (execute-command - (format nil "insert into ~A ~@[(~{~A~^,~}) ~]~A" into attributes query) - :database database)) - (t - (execute-command - (multiple-value-bind (attributes values) - (if av-pairs - (values (mapcar #'first av-pairs) (mapcar #'second av-pairs)) - (values attributes values)) - (format nil "insert into ~A ~@[(~{~A~^,~}) ~]values (~{'~A'~^,~})" - into attributes values)) - :database database)))) - -(defun delete-records (&key from where (database *default-database*)) - "Delete the indicated records from the given database." - (execute-command (format nil "delete from ~A ~@[where ~A ~]" from where) - :database database)) - -(defun update-records (table &key attributes values av-pairs where (database *default-database*)) - "Update the specified records in the given database." - (cond - ((and av-pairs (or attributes values)) - (error "Supply either av-pairs or values (and possibly attributes) to call of update-records.")) - ((and attributes - (or (not (listp values)) (/= (length attributes) (length values)))) - (error "You must supply a matching values list when using attributes in call of update-records.")) - ((or (and attributes (not values)) (and values (not attributes))) - (error "You must supply both values and attributes in call of update-records.")) - (t - (execute-command - (format nil "update ~A set ~:{~A = '~A'~:^, ~}~@[ where ~A~]" - table - (or av-pairs - (mapcar #'list attributes values)) - where) - :database database)))) - diff --git a/classic/package.lisp b/classic/package.lisp deleted file mode 100644 index 004dd47..0000000 --- a/classic/package.lisp +++ /dev/null @@ -1,147 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: package.lisp -;;;; Purpose: Package definition for CLSQL-CLASSIC high-level interface -;;;; Programmers: Kevin M. Rosenberg based on -;;;; Original code by Pierre R. Mai -;;;; Date Started: Feb 2002 -;;;; -;;;; $Id$ -;;;; -;;;; 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 -;;;; 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) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage #:clsql-classic - (:use #:cl #:clsql-base) - (:import-from - #:clsql-base - . - #1=( - #: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-access-error - #:clsql-access-error-database-type - #:clsql-access-error-connection-spec - #:clsql-access-error-error - #:clsql-connect-error - #:clsql-connect-error-errno - #: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 - - #:*loaded-database-types* - #:reload-database-types - #:*default-database-type* - #:*initialized-database-types* - #:initialize-database-type - - #:database - #:database-name - #:database-type - #:is-database-open - #:database-name-from-spec - - ;; utils.lisp - #:number-to-sql-string - #:float-to-sql-string - #:sql-escape-quotes - - ;; 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 - #:create-database - #:destroy-database - #:probe-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 - #:disconnect-pooled - )) - (:export - ;; sql.cl - #:for-each-row - - ;; Large objects (Marc B) - #:create-large-object - #:write-large-object - #:read-large-object - #:delete-large-object - - ;; functional.lisp - ;; These are no longer export since different functions are - ;; exported by the CLSQL package - ;; #:insert-records - ;; #:delete-records - ;; #:update-records - - . - #1# - ) - (:documentation "This is the INTERNAL SQL-Interface package of CLSQL-CLASSIC.")) - - ) ;eval-when - -(defpackage #:clsql-classic-user - (:use #:common-lisp #:clsql-classic) - (:documentation "This is the user package for experimenting with CLSQL-CLASSIC.")) diff --git a/classic/sql.lisp b/classic/sql.lisp deleted file mode 100644 index 36a1196..0000000 --- a/classic/sql.lisp +++ /dev/null @@ -1,126 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; 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-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 -;;;; as governed by the terms of the Lisp Lesser GNU Public License -;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;;; ************************************************************************* - -(in-package #:clsql-classic) - - -;;; Row processing macro - -(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body) - (let ((d (gensym "DISTINCT-")) - (bind-fields (loop for f in fields collect (car f))) - (w (gensym "WHERE-")) - (o (gensym "ORDER-BY-")) - (frm (gensym "FROM-")) - (l (gensym "LIMIT-")) - (q (gensym "QUERY-"))) - `(let ((,frm ,from) - (,w ,where) - (,d ,distinct) - (,l ,limit) - (,o ,order-by)) - (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l))) - (loop for tuple in (query ,q) - collect (destructuring-bind ,bind-fields tuple - ,@body)))))) - -(defun query-string (fields from where distinct order-by limit) - (concatenate - 'string - (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}" - (if distinct "distinct " "") (field-names fields) - (from-names from)) - (if where (format nil " where ~{~A~^ ~}" - (where-strings where)) "") - (if order-by (format nil " order by ~{~A~^, ~}" - (order-by-strings order-by))) - (if limit (format nil " limit ~D" limit) ""))) - -(defun lisp->sql-name (field) - (typecase field - (string field) - (symbol (string-upcase (symbol-name field))) - (cons (cadr field)) - (t (format nil "~A" field)))) - -(defun field-names (field-forms) - "Return a list of field name strings from a fields form" - (loop for field-form in field-forms - collect - (lisp->sql-name - (if (cadr field-form) - (cadr field-form) - (car field-form))))) - -(defun from-names (from) - "Return a list of field name strings from a fields form" - (loop for table in (if (atom from) (list from) from) - collect (lisp->sql-name table))) - - -(defun where-strings (where) - (loop for w in (if (atom (car where)) (list where) where) - collect - (if (consp w) - (format nil "~A ~A ~A" (second w) (first w) (third w)) - (format nil "~A" w)))) - -(defun order-by-strings (order-by) - (loop for o in order-by - collect - (if (atom o) - (lisp->sql-name o) - (format nil "~A ~A" (lisp->sql-name (car o)) - (lisp->sql-name (cadr o)))))) - - - -;;; These functions are not exported. If you application depends on these -;;; functions consider using the clsql package using has further support. - -(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)) - - -(defun list-attributes (table &key (database *default-database*)) - "List the attributes of TABLE in *default-database, or if the -:database keyword is given, the specified database. Attributes are -returned as a list of strings." - (database-list-attributes table database)) - -(defun attribute-type (attribute table &key (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*." - (database-attribute-type attribute table database)) - -(defun create-sequence (name &key (database *default-database*)) - (database-create-sequence name database)) - -(defun drop-sequence (name &key (database *default-database*)) - (database-drop-sequence name database)) - -(defun sequence-next (name &key (database *default-database*)) - (database-sequence-next name database)) - - diff --git a/clsql-aodbc.asd b/clsql-aodbc.asd index 76c8bdd..84572be 100644 --- a/clsql-aodbc.asd +++ b/clsql-aodbc.asd @@ -28,7 +28,7 @@ :description "Common Lisp SQL AODBC Driver" :long-description "cl-sql-aodbc package provides a database driver to AllegroCL's AODBC database interface." - :depends-on (clsql-base) + :depends-on (clsql) :components ((:module :db-aodbc :components diff --git a/clsql-base.asd b/clsql-base.asd deleted file mode 100644 index 7484c4c..0000000 --- a/clsql-base.asd +++ /dev/null @@ -1,52 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-base.asd -;;;; Purpose: ASDF definition file for Base CLSQL -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 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. -;;;; ************************************************************************* - -(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) - -#+(or allegro lispworks cmu sbcl openmcl mcl scl) -(defsystem clsql-base - :name "cl-sql-base" - :author "Kevin Rosenberg " - :maintainer "Kevin M. Rosenberg " - :licence "Lessor Lisp General Public License" - :description "Common Lisp SQL Base Package" - :long-description "cl-sql-base package provides the low-level interface for the database drivers." - - :components - ((:module :base - :components - ((:file "cmucl-compat") - (:file "package") - (:file "utils" :depends-on ("package" "db-interface")) - (:file "classes" :depends-on ("package")) - (:file "conditions" :depends-on ("classes")) - (:file "db-interface" :depends-on ("conditions")) - (:file "initialize" :depends-on ("db-interface" "utils")) - (:file "loop-extension" :depends-on ("db-interface")) - (:file "time" :depends-on ("package")) - (:file "database" :depends-on ("initialize")) - (:file "recording" :depends-on ("time" "database")) - (:file "basic-sql" :depends-on ("database" "cmucl-compat")) - (:file "pool" :depends-on ("basic-sql")) - (:file "transaction" :depends-on ("basic-sql")) - )))) - diff --git a/clsql-classic.asd b/clsql-classic.asd deleted file mode 100644 index 73734df..0000000 --- a/clsql-classic.asd +++ /dev/null @@ -1,42 +0,0 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;;; ************************************************************************* -;;;; FILE IDENTIFICATION -;;;; -;;;; Name: clsql-classic.asd -;;;; Purpose: System definition for CLSQL-CLASSIC -;;;; Programmer: Kevin M. Rosenberg -;;;; Date Started: Feb 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. -;;;; ************************************************************************* - -(defpackage #:clsql-classic-system (:use #:asdf #:cl)) -(in-package #:clsql-classic-system) - -#+(or allegro lispworks cmu sbcl openmcl mcl scl) -(defsystem clsql-classic - :name "clsql-classic" - :author "Kevin Rosenberg " - :maintainer "Kevin M. Rosenberg " - :version "2.1.x" - :licence "Lessor Lisp General Public License" - :description "Common Lisp SQL Interface Library" - :long-description "cl-sql package provides the high-level interface for the CLSQL system." - - :depends-on (clsql-base) - :components - ((:module :classic - :components - ((:file "package") - (:file "sql" :depends-on ("package")) - (:file "functional" :depends-on ("sql")))))) - -#+(or allegro lispworks cmu sbcl openmcl mcl scl) -(defmethod perform ((o test-op) (c (eql (find-system 'clsql-classic)))) - (warn "Testing is provided by the CLSQL-TESTS system")) diff --git a/clsql-mysql.asd b/clsql-mysql.asd index a229791..b20b4a0 100644 --- a/clsql-mysql.asd +++ b/clsql-mysql.asd @@ -81,7 +81,7 @@ :description "Common Lisp SQL MySQL Driver" :long-description "cl-sql-mysql package provides a database driver to the MySQL database system." - :depends-on (uffi clsql-base clsql-uffi) + :depends-on (uffi clsql clsql-uffi) :components ((:module :db-mysql :components diff --git a/clsql-odbc.asd b/clsql-odbc.asd index 3d3b1bb..82b3fbd 100644 --- a/clsql-odbc.asd +++ b/clsql-odbc.asd @@ -28,7 +28,7 @@ :description "Common Lisp SQL ODBC Driver" :long-description "cl-sql-odbc package provides a database driver to the ODBC database system." - :depends-on (uffi clsql-base clsql-uffi) + :depends-on (uffi clsql clsql-uffi) :components ((:module :db-odbc :components diff --git a/clsql-oracle.asd b/clsql-oracle.asd index b03beb4..82099fe 100644 --- a/clsql-oracle.asd +++ b/clsql-oracle.asd @@ -17,7 +17,7 @@ :description "Common Lisp SQL Oracle Driver" :long-description "cl-sql-oracle package provides a database driver to the Oracle database system." - :depends-on (clsql-base) + :depends-on (clsql) :components ((:module :db-oracle :components diff --git a/clsql-postgresql-socket.asd b/clsql-postgresql-socket.asd index f06e1ab..3862a3a 100644 --- a/clsql-postgresql-socket.asd +++ b/clsql-postgresql-socket.asd @@ -30,7 +30,7 @@ :description "Common Lisp SQL PostgreSQL Socket Driver" :long-description "cl-sql-postgresql-socket package provides a database driver to the PostgreSQL database via a socket interface." - :depends-on (clsql-base uffi md5 #+sbcl sb-bsd-sockets) + :depends-on (clsql uffi md5 #+sbcl sb-bsd-sockets) :components ((:module :db-postgresql-socket :components diff --git a/clsql-postgresql.asd b/clsql-postgresql.asd index 459a04b..81c1712 100644 --- a/clsql-postgresql.asd +++ b/clsql-postgresql.asd @@ -30,7 +30,7 @@ :description "Common Lisp PostgreSQL API Driver" :long-description "cl-sql-postgresql package provides a the database driver for the PostgreSQL API." - :depends-on (uffi clsql-base clsql-uffi) + :depends-on (uffi clsql clsql-uffi) :components ((:module :db-postgresql :components diff --git a/clsql-sqlite.asd b/clsql-sqlite.asd index 6a82c6c..bae257e 100644 --- a/clsql-sqlite.asd +++ b/clsql-sqlite.asd @@ -28,7 +28,7 @@ :long-description "cl-sql-sqlite package provides a database driver to SQLite database library." - :depends-on (clsql-base #-clisp clsql-uffi) + :depends-on (clsql #-clisp clsql-uffi) :components ((:module :db-sqlite :components diff --git a/clsql-uffi.asd b/clsql-uffi.asd index 18fcf00..215e6bc 100644 --- a/clsql-uffi.asd +++ b/clsql-uffi.asd @@ -85,7 +85,7 @@ :description "Common UFFI Helper functions for Common Lisp SQL Interface Library" :long-description "cl-sql-uffi package provides common helper functions using the UFFI for the CLSQL package." - :depends-on (uffi clsql-base) + :depends-on (uffi clsql) :components ((:module :uffi diff --git a/clsql.asd b/clsql.asd index ebfefa2..e891452 100644 --- a/clsql.asd +++ b/clsql.asd @@ -20,30 +20,42 @@ (defsystem #:clsql :name "CLSQL" - :author "" - :maintainer "" - :version "" - :licence "" - :description "A high level Common Lisp interface to SQL RDBMS." - :long-description "A high level Common Lisp interface to SQL RDBMS -based on the Xanalys CommonSQL interface for Lispworks. It depends on -the low-level database interfaces provided by CLSQL and includes both -a functional and an object oriented interface." - :depends-on (clsql-base) + :author "Kevin Rosenberg " + :maintainer "Kevin M. Rosenberg " + :licence "Lessor Lisp General Public License" + :description "Common Lisp SQL Interface library" + :long-description "A Common Lisp interface to SQL RDBMS based on +the Xanalys CommonSQL interface for Lispworks. It depends on the +low-level database interfaces as well as a functional and an object +oriented interface." :components ((:module sql :components - ((:module :package + ((:module :base :pathname "" - :components ((:file "package") - (:file "kmr-mop" :depends-on ("package")))) + :components + ((:file "cmucl-compat") + (:file "package") + (:file "utils" :depends-on ("package" "db-interface")) + (:file "base-classes" :depends-on ("package")) + (:file "conditions" :depends-on ("base-classes")) + (:file "db-interface" :depends-on ("conditions")) + (:file "initialize" :depends-on ("db-interface" "utils")) + (:file "loop-extension" :depends-on ("db-interface")) + (:file "time" :depends-on ("package")) + (:file "database" :depends-on ("initialize")) + (:file "recording" :depends-on ("time" "database")) + (:file "basic-sql" :depends-on ("database" "cmucl-compat")) + (:file "pool" :depends-on ("basic-sql")) + (:file "transaction" :depends-on ("basic-sql")) + (:file "kmr-mop" :depends-on ("package")))) (:module :core :pathname "" :components ((:file "generics") (:file "classes" :depends-on ("generics")) (:file "operations" :depends-on ("classes")) (:file "syntax" :depends-on ("operations"))) - :depends-on (:package)) + :depends-on (:base)) (:module :functional :pathname "" :components ((:file "sql") diff --git a/db-aodbc/aodbc-package.lisp b/db-aodbc/aodbc-package.lisp index 18c336a..171f547 100644 --- a/db-aodbc/aodbc-package.lisp +++ b/db-aodbc/aodbc-package.lisp @@ -25,6 +25,6 @@ (defpackage #:clsql-aodbc (:nicknames #:aodbc) - (:use #:cl #:clsql-base) + (:use #:common-lisp #:clsql-sys) (:export #:aodbc-database) (:documentation "This is the CLSQL interface to Allegro's AODBC")) diff --git a/db-mysql/mysql-loader.lisp b/db-mysql/mysql-loader.lisp index 6424e7a..d93b783 100644 --- a/db-mysql/mysql-loader.lisp +++ b/db-mysql/mysql-loader.lisp @@ -59,10 +59,10 @@ set to the right path before compiling or loading the system.") (defvar *mysql-library-loaded* nil "T if foreign library was able to be loaded successfully") -(defmethod clsql-base:database-type-library-loaded ((database-type (eql :mysql))) +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :mysql))) *mysql-library-loaded*) -(defmethod clsql-base:database-type-load-foreign ((database-type (eql :mysql))) +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :mysql))) (let ((mysql-path (uffi:find-foreign-library *mysql-library-candidate-names* *mysql-library-candidate-directories* @@ -82,5 +82,5 @@ set to the right path before compiling or loading the system.") (setq *mysql-library-loaded* t)) -(clsql-base:database-type-load-foreign :mysql) +(clsql-sys:database-type-load-foreign :mysql) diff --git a/db-mysql/mysql-package.lisp b/db-mysql/mysql-package.lisp index b841443..4ecbabf 100644 --- a/db-mysql/mysql-package.lisp +++ b/db-mysql/mysql-package.lisp @@ -19,7 +19,7 @@ (in-package #:cl-user) (defpackage #:mysql - (:use #:cl #:clsql-uffi) + (:use #:common-lisp #:clsql-uffi) (:export #:database-library-loaded diff --git a/db-mysql/mysql-sql.lisp b/db-mysql/mysql-sql.lisp index dd62303..cf85c59 100644 --- a/db-mysql/mysql-sql.lisp +++ b/db-mysql/mysql-sql.lisp @@ -14,7 +14,7 @@ ;;;; ************************************************************************* (defpackage #:clsql-mysql - (:use #:common-lisp #:clsql-base #:mysql #:clsql-uffi) + (:use #:common-lisp #:clsql-sys #:mysql #:clsql-uffi) (:export #:mysql-database) (:documentation "This is the CLSQL interface to MySQL.")) @@ -392,7 +392,7 @@ (defmethod database-create (connection-spec (type (eql :mysql))) (destructuring-bind (host name user password) connection-spec (multiple-value-bind (output status) - (clsql-base:command-output "mysqladmin create -u~A -p~A -h~A ~A" + (clsql-sys:command-output "mysqladmin create -u~A -p~A -h~A ~A" user password (if host host "localhost") name) @@ -408,7 +408,7 @@ (defmethod database-destroy (connection-spec (type (eql :mysql))) (destructuring-bind (host name user password) connection-spec (multiple-value-bind (output status) - (clsql-base:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A" + (clsql-sys:command-output "mysqladmin drop -f -u~A -p~A -h~A ~A" user password (if host host "localhost") name) @@ -432,11 +432,11 @@ (let ((database (database-connect (list host "mysql" user password) type))) (unwind-protect (progn - (setf (slot-value database 'clsql-base::state) :open) + (setf (slot-value database 'clsql-sys::state) :open) (mapcar #'car (database-query "show databases" database :auto nil))) (progn (database-disconnect database) - (setf (slot-value database 'clsql-base::state) :closed)))))) + (setf (slot-value database 'clsql-sys::state) :closed)))))) ;;; Database capabilities @@ -458,6 +458,6 @@ (let ((tuple (car (database-query "SHOW VARIABLES LIKE 'HAVE_INNODB'" database :auto nil)))) (and tuple (string-equal "YES" (second tuple))))) -(when (clsql-base:database-type-library-loaded :mysql) - (clsql-base:initialize-database-type :database-type :mysql)) +(when (clsql-sys:database-type-library-loaded :mysql) + (clsql-sys:initialize-database-type :database-type :mysql)) diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index 66c9936..c5cca32 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -27,8 +27,8 @@ May be locally bound to something else if a certain type is necessary.") (defvar *time-conversion-function* (lambda (universal-time &optional fraction) (declare (ignore fraction)) - (clsql-base:format-time - nil (clsql-base:utime->time universal-time) + (clsql-sys:format-time + nil (clsql-sys:utime->time universal-time) :format :iso) #+ignore universal-time) @@ -113,11 +113,11 @@ as possible second argument) to the desired representation of date/time/timestam (progn ,result-code ,@body)) (#.$SQL_INVALID_HANDLE (error - 'clsql-base:clsql-odbc-error + 'clsql-sys:clsql-odbc-error :odbc-message "Invalid handle")) (#.$SQL_STILL_EXECUTING (error - 'clsql-base:clsql-odbc-error + 'clsql-sys:clsql-odbc-error :odbc-message "Still executing")) (#.$SQL_ERROR (multiple-value-bind (error-message sql-state) @@ -125,7 +125,7 @@ as possible second argument) to the desired representation of date/time/timestam (or ,hdbc +null-handle-ptr+) (or ,hstmt +null-handle-ptr+)) (error - 'clsql-base:clsql-odbc-error + 'clsql-sys:clsql-odbc-error :odbc-message error-message :sql-state sql-state))) (#.$SQL_NO_DATA_FOUND @@ -138,7 +138,7 @@ as possible second argument) to the desired representation of date/time/timestam (or ,hdbc +null-handle-ptr+) (or ,hstmt +null-handle-ptr+)) (error - 'clsql-base:clsql-odbc-error + 'clsql-sys:clsql-odbc-error :odbc-message error-message :sql-state sql-state)) #+ignore diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index 7b20556..29a44f0 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -357,7 +357,7 @@ the query against." )) "get-free-query finds or makes a nonactive query object, and then sets it to active. This makes the functions db-execute-command and db-query thread safe." (with-slots (queries hdbc) database - (or (clsql-base:without-interrupts + (or (clsql-sys:without-interrupts (let ((inactive-query (find-if (lambda (query) (not (query-active-p query))) queries))) diff --git a/db-odbc/odbc-loader.lisp b/db-odbc/odbc-loader.lisp index 94206d8..52dc8f7 100644 --- a/db-odbc/odbc-loader.lisp +++ b/db-odbc/odbc-loader.lisp @@ -39,15 +39,15 @@ set to the right path before compiling or loading the system.") (defvar *odbc-library-loaded* nil "T if foreign library was able to be loaded successfully") -(defmethod clsql-base:database-type-library-loaded ((database-type (eql :odbc))) +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :odbc))) *odbc-library-loaded*) -(defmethod clsql-base:database-type-load-foreign ((database-type (eql :odbc))) +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :odbc))) (uffi:load-foreign-library *odbc-library-path* :module "odbc") (setq *odbc-library-loaded* t)) -(clsql-base:database-type-load-foreign :odbc) +(clsql-sys:database-type-load-foreign :odbc) diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp index 70e1478..656e8f4 100644 --- a/db-odbc/odbc-sql.lisp +++ b/db-odbc/odbc-sql.lisp @@ -17,7 +17,7 @@ ;;;; ************************************************************************* (defpackage #:clsql-odbc - (:use #:common-lisp #:clsql-base) + (:use #:common-lisp #:clsql-sys) (:export #:odbc-database) (:documentation "This is the CLSQL interface to ODBC.")) @@ -359,5 +359,5 @@ ;; nothing to do t) -(when (clsql-base:database-type-library-loaded :odbc) - (clsql-base:initialize-database-type :database-type :odbc)) +(when (clsql-sys:database-type-library-loaded :odbc) + (clsql-sys:initialize-database-type :database-type :odbc)) diff --git a/db-oracle/oracle-package.lisp b/db-oracle/oracle-package.lisp index 22314a2..41f174b 100644 --- a/db-oracle/oracle-package.lisp +++ b/db-oracle/oracle-package.lisp @@ -17,7 +17,7 @@ (in-package #:cl-user) (defpackage #:clsql-oracle - (:use #:common-lisp #:clsql-base) + (:use #:common-lisp #:clsql-sys) (:export #:oracle-database #:*oracle-so-load-path* #:*oracle-so-libraries*) diff --git a/db-postgresql-socket/postgresql-socket-api.lisp b/db-postgresql-socket/postgresql-socket-api.lisp index 620140e..dabaad9 100644 --- a/db-postgresql-socket/postgresql-socket-api.lisp +++ b/db-postgresql-socket/postgresql-socket-api.lisp @@ -27,13 +27,13 @@ (:float4 700) (:float8 701))) -(defmethod clsql-base:database-type-library-loaded ((database-type +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :postgresql-socket))) "T if foreign library was able to be loaded successfully. Always true for socket interface" t) -(defmethod clsql-base:database-type-load-foreign ((database-type (eql :postgresql-socket))) +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql-socket))) t) @@ -601,7 +601,7 @@ connection, if it is still open." :connection connection :message message)))) (#.+notice-response-message+ (let ((message (read-socket-value-string socket))) - (unless (eq :ignore clsql-base:*backend-warning-behavior*) + (unless (eq :ignore clsql-sys:*backend-warning-behavior*) (warn 'postgresql-warning :connection connection :message message)))) (#.+notification-response-message+ diff --git a/db-postgresql-socket/postgresql-socket-sql.lisp b/db-postgresql-socket/postgresql-socket-sql.lisp index 24597c0..ebda22c 100644 --- a/db-postgresql-socket/postgresql-socket-sql.lisp +++ b/db-postgresql-socket/postgresql-socket-sql.lisp @@ -20,7 +20,7 @@ (in-package #:cl-user) (defpackage :clsql-postgresql-socket - (:use #:common-lisp #:clsql-base #:postgresql-socket) + (:use #:common-lisp #:clsql-sys #:postgresql-socket) (:export #:postgresql-socket-database) (:documentation "This is the CLSQL socket interface to PostgreSQL.")) @@ -29,7 +29,7 @@ ;; interface foreign library loading routines -(clsql-base:database-type-load-foreign :postgresql-socket) +(clsql-sys:database-type-load-foreign :postgresql-socket) ;; Field type conversion @@ -494,12 +494,12 @@ doesn't depend on UFFI." type))) (unwind-protect (progn - (setf (slot-value database 'clsql-base::state) :open) + (setf (slot-value database 'clsql-sys::state) :open) (mapcar #'car (database-query "select datname from pg_database" database :auto nil))) (progn (database-disconnect database) - (setf (slot-value database 'clsql-base::state) :closed)))))) + (setf (slot-value database 'clsql-sys::state) :closed)))))) (defmethod database-describe-table ((database postgresql-socket-database) table) @@ -525,5 +525,5 @@ doesn't depend on UFFI." (defmethod db-type-default-case ((db-type (eql :postgresql-socket))) :lower) -(when (clsql-base:database-type-library-loaded :postgresql-socket) - (clsql-base:initialize-database-type :database-type :postgresql-socket)) +(when (clsql-sys:database-type-library-loaded :postgresql-socket) + (clsql-sys:initialize-database-type :database-type :postgresql-socket)) diff --git a/db-postgresql/postgresql-loader.lisp b/db-postgresql/postgresql-loader.lisp index 169588f..e33f135 100644 --- a/db-postgresql/postgresql-loader.lisp +++ b/db-postgresql/postgresql-loader.lisp @@ -27,11 +27,11 @@ set to the right path before compiling or loading the system.") (defvar *postgresql-library-loaded* nil "T if foreign library was able to be loaded successfully") -(defmethod clsql-base:database-type-library-loaded ((database-type +(defmethod clsql-sys:database-type-library-loaded ((database-type (eql :postgresql))) *postgresql-library-loaded*) -(defmethod clsql-base:database-type-load-foreign ((database-type +(defmethod clsql-sys:database-type-load-foreign ((database-type (eql :postgresql))) (let ((libpath (uffi:find-foreign-library "libpq" @@ -51,5 +51,5 @@ set to the right path before compiling or loading the system.") (setq *postgresql-library-loaded* t) (warn "Can't load PostgreSQL client library ~A" libpath)))) -(clsql-base:database-type-load-foreign :postgresql) +(clsql-sys:database-type-load-foreign :postgresql) diff --git a/db-postgresql/postgresql-sql.lisp b/db-postgresql/postgresql-sql.lisp index a556831..2bb7fb1 100644 --- a/db-postgresql/postgresql-sql.lisp +++ b/db-postgresql/postgresql-sql.lisp @@ -16,7 +16,7 @@ (in-package #:cl-user) (defpackage #:clsql-postgresql - (:use #:common-lisp #:clsql-base #:postgresql #:clsql-uffi) + (:use #:common-lisp #:clsql-sys #:postgresql #:clsql-uffi) (:export #:postgresql-database) (:documentation "This is the CLSQL interface to PostgreSQL.")) @@ -520,7 +520,7 @@ (destructuring-bind (host name user password) connection-spec (declare (ignore user password)) (multiple-value-bind (output status) - (clsql-base:command-output "createdb -h~A ~A" + (clsql-sys:command-output "createdb -h~A ~A" (if host host "localhost") name) (if (or (not (zerop status)) @@ -537,7 +537,7 @@ (destructuring-bind (host name user password) connection-spec (declare (ignore user password)) (multiple-value-bind (output status) - (clsql-base:command-output "dropdb -h~A ~A" + (clsql-sys:command-output "dropdb -h~A ~A" (if host host "localhost") name) (if (or (not (zerop status)) @@ -563,12 +563,12 @@ type))) (unwind-protect (progn - (setf (slot-value database 'clsql-base::state) :open) + (setf (slot-value database 'clsql-sys::state) :open) (mapcar #'car (database-query "select datname from pg_database" database nil nil))) (progn (database-disconnect database) - (setf (slot-value database 'clsql-base::state) :closed)))))) + (setf (slot-value database 'clsql-sys::state) :closed)))))) (defmethod database-describe-table ((database postgresql-database) table) (database-query @@ -618,5 +618,5 @@ (defmethod db-type-default-case ((db-type (eql :postgresql))) :lower) -(when (clsql-base:database-type-library-loaded :postgresql) - (clsql-base:initialize-database-type :database-type :postgresql)) +(when (clsql-sys:database-type-library-loaded :postgresql) + (clsql-sys:initialize-database-type :database-type :postgresql)) diff --git a/db-sqlite/sqlite-loader.lisp b/db-sqlite/sqlite-loader.lisp index 71e3385..d625473 100644 --- a/db-sqlite/sqlite-loader.lisp +++ b/db-sqlite/sqlite-loader.lisp @@ -47,7 +47,7 @@ set to the right path before compiling or loading the system.") (setq *sqlite-library-loaded* t) (warn "Can't load SQLite library ~A" libpath)))) -(clsql-base:database-type-load-foreign :sqlite) +(clsql-sys:database-type-load-foreign :sqlite) diff --git a/db-sqlite/sqlite-package.lisp b/db-sqlite/sqlite-package.lisp index 2f8e13e..c50107a 100644 --- a/db-sqlite/sqlite-package.lisp +++ b/db-sqlite/sqlite-package.lisp @@ -19,5 +19,5 @@ (in-package #:cl-user) (defpackage #:clsql-sqlite - (:use #:common-lisp #:clsql-base) + (:use #:common-lisp #:clsql-sys) (:export #:sqlite-database)) diff --git a/debian/control b/debian/control index f90a53b..1abcd05 100644 --- a/debian/control +++ b/debian/control @@ -8,25 +8,16 @@ Standards-Version: 3.6.1.0 Package: cl-sql Architecture: all -Depends: cl-sql-base +Depends: common-lisp-controller (>= 3.37) +Recommends: cl-sql-backend Description: SQL Interface for Common Lisp CLSQL is a Common Lisp interface for multiple SQL databases on multiple Common Lisp implementations. It uses the UFFI foreign language interface. -Package: cl-sql-base -Architecture: all -Depends: common-lisp-controller (>= 3.37) -Recommends: cl-sql-backend -Description: SQL Interface for Common Lisp - CLSQL uses the UFFI library to provide SQL to multiple SQL databases - on multiple Common Lisp implementations. - . - This package provides the base framework for database backends. - Package: cl-sql-uffi Architecture: any -Depends: common-lisp-controller (>= 3.37), cl-uffi, cl-sql-base +Depends: cl-uffi, cl-sql (>= ${Source-Version}) Recommends: cl-sql-backend Description: Common UFFI functions for CLSQL database backends This package provides an interface to several UFFI functions used by multiple @@ -35,7 +26,7 @@ Description: Common UFFI functions for CLSQL database backends Package: cl-sql-mysql Architecture: any -Depends: cl-sql-base (>= ${Source-Version}), libmysqlclient-dev, cl-sql-uffi (>= ${Source-Version}) +Depends: cl-sql (>= ${Source-Version}), libmysqlclient-dev, cl-sql-uffi (>= ${Source-Version}) Provides: cl-sql-backend Description: CLSQL database backend, MySQL This package enables you to use the CLSQL data access package @@ -44,7 +35,7 @@ Description: CLSQL database backend, MySQL Package: cl-sql-aodbc Architecture: all -Depends: cl-sql-base (>= ${Source-Version}), cl-sql-mysql, cl-sql-postgresql +Depends: cl-sql (>= ${Source-Version}), cl-sql-mysql, cl-sql-postgresql Provides: cl-sql-backend Suggests: acl-pro-installer Description: CLSQL database backend, AODBC @@ -54,7 +45,7 @@ Description: CLSQL database backend, AODBC Package: cl-sql-odbc Architecture: all -Depends: cl-sql-base (>= ${Source-Version}), unixodbc-dev, cl-sql-mysql, cl-sql-postgresql +Depends: cl-sql (>= ${Source-Version}), unixodbc-dev, cl-sql-mysql, cl-sql-postgresql Provides: cl-sql-backend Suggests: acl-pro-installer Description: CLSQL database backend, ODBC @@ -64,7 +55,7 @@ Description: CLSQL database backend, ODBC Package: cl-sql-postgresql Architecture: all -Depends: cl-sql-base (>= ${Source-Version}), postgresql-dev, cl-sql-uffi (>= ${Source-Version}) +Depends: cl-sql (>= ${Source-Version}), postgresql-dev, cl-sql-uffi (>= ${Source-Version}) Provides: cl-sql-backend Description: CLSQL database backend, PostgreSQL This package enables you to use the CLSQL data access package @@ -73,7 +64,7 @@ Description: CLSQL database backend, PostgreSQL Package: cl-sql-postgresql-socket Architecture: all -Depends: cl-sql-base (>= ${Source-Version}), cl-md5, cl-sql-uffi (>= ${Source-Version}), libc6-dev +Depends: cl-sql (>= ${Source-Version}), cl-md5, cl-sql-uffi (>= ${Source-Version}), libc6-dev Provides: cl-sql-backend Description: CLSQL database backend, PostgreSQL This package enables you to use the CLSQL data access package @@ -82,23 +73,16 @@ Description: CLSQL database backend, PostgreSQL Package: cl-sql-sqlite Architecture: all -Depends: cl-sql-base (>= ${Source-Version}), libsqlite0-dev, cl-sql-uffi (>= ${Source-Version}) +Depends: cl-sql (>= ${Source-Version}), libsqlite0-dev, cl-sql-uffi (>= ${Source-Version}) Provides: cl-sql-backend Description: CLSQL database backend, SQLite This package enables you to use the CLSQL data access package with SQLite databases. CLSQL is a Common Lisp interface to SQL databases. -Package: cl-sql-classic -Architecture: all -Depends: cl-sql-base (>= ${Source-Version}) -Description: Classic CLSQL high-level interface - This package provides the Classic, original high-level interface for CLSQL. - CLSQL is a Common Lisp interface to SQL databases. - Package: cl-sql-tests Architecture: all -Depends: cl-sql-base, cl-sql-postgresql, cl-sql-postgresql-socket, cl-sql-mysql, cl-rt +Depends: cl-sql, cl-sql-postgresql, cl-sql-postgresql-socket, cl-sql-mysql, cl-sqlite, cl-sql-odbc, rt Suggests: acl-installer, libmyodbc, unixodbc,cl-sql-aodbc Description: Testing suite for CLSQL This package contains a test suite for CLSQL. It requires manual diff --git a/debian/rules b/debian/rules index 6c03eae..29881dd 100755 --- a/debian/rules +++ b/debian/rules @@ -3,9 +3,7 @@ plain-pkg := clsql pkg := cl-sql -pkg-base := cl-sql-base pkg-uffi := cl-sql-uffi -pkg-classic := cl-sql-classic pkg-mysql := cl-sql-mysql pkg-pg := cl-sql-postgresql pkg-pg-socket := cl-sql-postgresql-socket @@ -13,15 +11,13 @@ pkg-aodbc := cl-sql-aodbc pkg-odbc := cl-sql-odbc pkg-sqlite := cl-sql-sqlite pkg-tests := cl-sql-tests -all-pkgs := $(pkg) $(pkg-base) $(pkg-uffi) $(pkg-mysql) $(pkg-pg) $(pkg-pg-socket) $(pkg-aodbc) $(pkg-odbc) $(pkg-sqlite) $(pkg-tests) +all-pkgs := $(pkg) $(pkg-uffi) $(pkg-mysql) $(pkg-pg) $(pkg-pg-socket) $(pkg-aodbc) $(pkg-odbc) $(pkg-sqlite) $(pkg-tests) UPSTREAM_VER := $(shell sed -n -e "s/${pkg} (\(.*\)-[0-9A-Za-z\.]).*/\1/p" < debian/changelog |head -1) ## Lisp sources srcs := $(wildcard sql/*.lisp) clsql.asd -srcs-base := $(wildcard base/*.lisp) -srcs-classic := $(wildcard classic/*.lisp) srcs-uffi := $(wildcard uffi/*.lisp) $(wildcard uffi/*.c) srcs-uffi-so := $(wildcard uffi/*.so) srcs-mysql := $(wildcard db-mysql/*.lisp) $(wildcard db-mysql/*.c) @@ -42,10 +38,6 @@ clc-clsql := $(clc-source)/$(plain-pkg) clc-sql := $(clc-source)/clsql lispdir-sql := $(clc-sql)/sql -clc-base := $(clc-source)/clsql-base -lispdir-base := $(clc-base)/base -clc-classic := $(clc-source)/clsql-classic -lispdir-classic := $(clc-classic)/classic clc-uffi := $(clc-source)/clsql-uffi lispdir-uffi := $(clc-uffi)/uffi sodir-uffi := usr/lib/clsql @@ -109,7 +101,6 @@ install: build # Add here commands to install the package into debian/uffi. dh_installdirs --all $(clc-systems) $(clc-source) dh_installdirs -p $(pkg) $(lispdir-sql) - dh_installdirs -p $(pkg-base) $(lispdir-base) dh_installdirs -p $(pkg-uffi) $(lispdir-uffi) $(sodir-uffi) dh_installdirs -p $(pkg-pg) $(lispdir-pg) dh_installdirs -p $(pkg-pg-socket) $(lispdir-pg-socket) @@ -123,14 +114,6 @@ install: build dh_install -p $(pkg) $(srcs) $(lispdir-sql) dh_install -p $(pkg) clsql.asd $(clc-clsql) - # Base - dh_install -p $(pkg-base) $(srcs-base) $(lispdir-base) - dh_install -p $(pkg-base) clsql-base.asd $(clc-base) - - # Classic - dh_install -p $(pkg-classic) $(srcs-classic) $(lispdir-classic) - dh_install -p $(pkg-classic) clsql-classic.asd $(clc-classic) - # UFFI dh_install -p $(pkg-uffi) $(srcs-uffi) $(lispdir-uffi) dh_install -p $(pkg-uffi) $(srcs-uffi-so) $(sodir-uffi) @@ -156,8 +139,6 @@ install: build # CLC Systems dh_link -p $(pkg) $(clc-clsql)/clsql.asd $(clc-systems)/clsql.asd - dh_link -p $(pkg-base) $(clc-base)/clsql-base.asd $(clc-systems)/clsql-base.asd - dh_link -p $(pkg-classic) $(clc-classic)/clsql-classic.asd $(clc-systems)/clsql-classic.asd dh_link -p $(pkg-uffi) $(clc-uffi)/clsql-uffi.asd $(clc-systems)/clsql-uffi.asd dh_link -p $(pkg-mysql) $(clc-mysql)/clsql-mysql.asd $(clc-systems)/clsql-mysql.asd dh_link -p $(pkg-pg) $(clc-pg)/clsql-postgresql.asd $(clc-systems)/clsql-postgresql.asd diff --git a/sql/base-classes.lisp b/sql/base-classes.lisp new file mode 100644 index 0000000..98980d4 --- /dev/null +++ b/sql/base-classes.lisp @@ -0,0 +1,55 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: classes.lisp +;;;; Purpose: Classes for High-level SQL interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; 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 +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + + +(defclass database () + ((name :initform nil :initarg :name :reader database-name) + (connection-spec :initform nil :initarg :connection-spec + :reader connection-spec + :documentation "Require to use connection pool") + (database-type :initarg :database-type :initform :unknown + :reader database-type) + (state :initform :closed :reader database-state) + (command-recording-stream :accessor command-recording-stream :initform nil) + (result-recording-stream :accessor result-recording-stream :initform nil) + (record-caches :accessor record-caches :initform nil) + (view-classes :accessor database-view-classes :initform nil) + (schema :accessor database-schema :initform nil) + (transaction-level :initform 0 :accessor transaction-level) + (transaction :initform nil :accessor transaction) + (conn-pool :initform nil :initarg :conn-pool :accessor conn-pool) + (attribute-cache :initform (make-hash-table :size 100 :test 'equal) + :accessor attribute-cache + :documentation "Internal cache of table attributes. It is keyed by table-name. Values +are a list of ACTION specified for table and any cached value of list-attributes-types.")) + (:documentation + "This class is the supertype of all databases handled by CLSQL.")) + +(defmethod print-object ((object database) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~A ~A" + (if (slot-boundp object 'name) + (database-name object) + "") + (database-state object)))) + + diff --git a/sql/basic-sql.lisp b/sql/basic-sql.lisp new file mode 100644 index 0000000..2c61f25 --- /dev/null +++ b/sql/basic-sql.lisp @@ -0,0 +1,80 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id$ +;;;; +;;;; Base SQL functions +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +;;; Query + +(defgeneric query (query-expression &key database result-types flatp) + (: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 :auto) (flatp nil) (field-names t)) + (record-sql-command query-expression database) + (multiple-value-bind (rows names) (database-query query-expression database result-types + field-names) + (let ((result (if (and flatp (= 1 (length (car rows)))) + (mapcar #'car rows) + rows))) + (record-sql-result result database) + (if field-names + (values result names) + result)))) + +;;; Execute + +(defgeneric execute-command (expression &key database) + (:documentation + "Executes the SQL command 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)) + +;;; 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/classes.lisp b/sql/classes.lisp index 24bd71a..f33a236 100644 --- a/sql/classes.lisp +++ b/sql/classes.lisp @@ -13,7 +13,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) (defvar +empty-string+ "''") diff --git a/sql/cmucl-compat.lisp b/sql/cmucl-compat.lisp new file mode 100644 index 0000000..d285788 --- /dev/null +++ b/sql/cmucl-compat.lisp @@ -0,0 +1,103 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; 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-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) + +(defpackage #:cmucl-compat + (:use #:common-lisp) + (:export + #:shrink-vector + #:make-sequence-of-type + #:result-type-or-lose + #:required-argument + )) +(in-package #:cmucl-compat) + +#+(or cmu scl) +(defmacro required-argument () + `(ext:required-argument)) + +#-(or cmu scl) +(defun required-argument () + (error "~&A required keyword argument was not supplied")) + +#+(or cmu scl) +(defmacro shrink-vector (vec len) + `(lisp::shrink-vector ,vec ,len)) + +#+sbcl +(defmacro shrink-vector (vec len) + `(sb-kernel::shrink-vector ,vec ,len)) + +#-(or cmu sbcl scl) +(defmacro shrink-vector (vec len) + "Shrinks a vector. Optimized if vector has a fill pointer. +Needs to be a macro to overwrite value of VEC." + (let ((new-vec (gensym))) + `(cond + ((adjustable-array-p ,vec) + (adjust-array ,vec ,len)) + ((typep ,vec 'simple-array) + (let ((,new-vec (make-array ,len :element-type + (array-element-type ,vec)))) + (check-type ,len fixnum) + (locally (declare (optimize (speed 3) (safety 0) (space 0)) ) + (dotimes (i ,len) + (declare (fixnum i)) + (setf (aref ,new-vec i) (aref ,vec i)))) + (setq ,vec ,new-vec))) + ((typep ,vec 'vector) + (setf (fill-pointer ,vec) ,len) + ,vec) + (t + (error "Unable to shrink vector ~S which is type-of ~S" ,vec (type-of ,vec))) + ))) + + +#-(or cmu scl) +(defun make-sequence-of-type (type length) + "Returns a sequence of the given TYPE and LENGTH." + (make-sequence type length)) + +#+(or cmu scl) +(if (fboundp 'lisp::make-sequence-of-type) + (defun make-sequence-of-type (type len) + (lisp::make-sequence-of-type type len)) + (defun 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) + (unless (or type nil-ok) + (error "NIL output type invalid for this sequence function")) + (case type + ((list cons) + 'list) + ((string simple-string base-string simple-base-string) + 'string) + (simple-vector + 'simple-vector) + (vector + 'vector) + (t + (error "~S is a bad type specifier for sequence functions." type)) + )) + +#+(or cmu scl) +(defun result-type-or-lose (type nil-ok) + (lisp::result-type-or-lose type nil-ok)) diff --git a/sql/conditions.lisp b/sql/conditions.lisp new file mode 100644 index 0000000..571054d --- /dev/null +++ b/sql/conditions.lisp @@ -0,0 +1,210 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: conditions.lisp +;;;; Purpose: Error conditions for high-level SQL interface +;;;; Programmers: Kevin M. Rosenberg based on +;;;; Original code by Pierre R. Mai +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; 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 +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(defvar *backend-warning-behavior* :warn + "Action to perform on warning messages from backend. Default is to :warn. May also be +set to :error to signal an error or :ignore/nil to silently ignore the warning.") + +;;; Conditions +(define-condition clsql-condition () + ()) + +(define-condition clsql-error (error clsql-condition) + ()) + +(define-condition clsql-simple-error (simple-condition clsql-error) + ()) + +(define-condition clsql-warning (warning clsql-condition) + ()) + +(define-condition clsql-simple-warning (simple-condition clsql-warning) + ()) + +(define-condition clsql-generic-error (clsql-error) + ((message :initarg :message + :reader clsql-generic-error-message)) + (:report (lambda (c stream) + (format stream (clsql-generic-error-message c))))) + +(define-condition clsql-invalid-spec-error (clsql-error) + ((connection-spec :initarg :connection-spec + :reader clsql-invalid-spec-error-connection-spec) + (database-type :initarg :database-type + :reader clsql-invalid-spec-error-database-type) + (template :initarg :template + :reader clsql-invalid-spec-error-template)) + (:report (lambda (c stream) + (format stream "The connection specification ~A~%is invalid for database type ~A.~%The connection specification must conform to ~A" + (clsql-invalid-spec-error-connection-spec c) + (clsql-invalid-spec-error-database-type c) + (clsql-invalid-spec-error-template c))))) + +(defmacro check-connection-spec (connection-spec database-type template) + "Check the connection specification against the provided template, +and signal an clsql-invalid-spec-error if they don't match." + `(handler-case + (destructuring-bind ,template ,connection-spec + (declare (ignore ,@(remove '&optional template))) + t) + (error () (error 'clsql-invalid-spec-error + :connection-spec ,connection-spec + :database-type ,database-type + :template (quote ,template))))) + +(define-condition clsql-access-error (clsql-error) + ((database-type :initarg :database-type + :reader clsql-access-error-database-type) + (connection-spec :initarg :connection-spec + :reader clsql-access-error-connection-spec) + (error :initarg :error :reader clsql-access-error-error)) + (:report (lambda (c stream) + (format stream "While trying to access database ~A~% using database-type ~A:~% Error ~A~% has occurred." + (database-name-from-spec + (clsql-access-error-connection-spec c) + (clsql-access-error-database-type c)) + (clsql-access-error-database-type c) + (clsql-access-error-error c))))) + +(define-condition clsql-connect-error (clsql-access-error) + ((errno :initarg :errno :reader clsql-connect-error-errno)) + (:report (lambda (c stream) + (format stream "While trying to connect to database ~A~% using database-type ~A:~% Error ~D / ~A~% has occurred." + (database-name-from-spec + (clsql-access-error-connection-spec c) + (clsql-access-error-database-type c)) + (clsql-access-error-database-type c) + (clsql-connect-error-errno c) + (clsql-access-error-error c))))) + +(define-condition clsql-sql-error (clsql-error) + ((database :initarg :database :reader clsql-sql-error-database) + (message :initarg :message :initform nil :reader clsql-sql-error-message) + (expression :initarg :expression :initarg nil :reader clsql-sql-error-expression) + (errno :initarg :errno :initarg nil :reader clsql-sql-error-errno) + (error :initarg :error :initarg nil :reader clsql-sql-error-error)) + (:report (lambda (c stream) + (if (clsql-sql-error-message c) + (format stream "While accessing database ~A~%, Error~% ~A~% has occurred." + (clsql-sql-error-database c) + (clsql-sql-error-message c)) + (format stream "While accessing database ~A~% with expression ~S:~% Error ~D / ~A~% has occurred." + (clsql-sql-error-database c) + (clsql-sql-error-expression c) + (clsql-sql-error-errno c) + (clsql-sql-error-error c)))))) + +(define-condition clsql-database-warning (clsql-warning) + ((database :initarg :database :reader clsql-database-warning-database) + (message :initarg :message :reader clsql-database-warning-message)) + (:report (lambda (c stream) + (format stream "While accessing database ~A~% Warning: ~A~% has occurred." + (clsql-database-warning-database c) + (clsql-database-warning-message c))))) + +(define-condition clsql-exists-condition (clsql-condition) + ((old-db :initarg :old-db :reader clsql-exists-condition-old-db) + (new-db :initarg :new-db :reader clsql-exists-condition-new-db + :initform nil)) + (:report (lambda (c stream) + (format stream "In call to ~S:~%" 'connect) + (cond + ((null (clsql-exists-condition-new-db c)) + (format stream + " There is an existing connection ~A to database ~A." + (clsql-exists-condition-old-db c) + (database-name (clsql-exists-condition-old-db c)))) + ((eq (clsql-exists-condition-new-db c) + (clsql-exists-condition-old-db c)) + (format stream + " Using existing connection ~A to database ~A." + (clsql-exists-condition-old-db c) + (database-name (clsql-exists-condition-old-db c)))) + (t + (format stream + " Created new connection ~A to database ~A~%, although there is an existing connection (~A)." + (clsql-exists-condition-new-db c) + (database-name (clsql-exists-condition-new-db c)) + (clsql-exists-condition-old-db c))))))) + +(define-condition clsql-exists-warning (clsql-exists-condition + clsql-warning) + ()) + +(define-condition clsql-exists-error (clsql-exists-condition + clsql-error) + ()) + +(define-condition clsql-closed-error (clsql-error) + ((database :initarg :database :reader clsql-closed-error-database)) + (:report (lambda (c stream) + (format stream "The database ~A has already been closed." + (clsql-closed-error-database c))))) + +(define-condition clsql-no-database-error (clsql-error) + ((database :initarg :database :reader clsql-no-database-error-database)) + (:report (lambda (c stream) + (format stream "~S is not a CLSQL database." + (clsql-no-database-error-database c))))) + +(define-condition clsql-odbc-error (clsql-error) + ((odbc-message :initarg :odbc-message + :reader clsql-odbc-error-message) + (sql-state :initarg :sql-state :initform nil + :reader clsql-odbc-error-sql-state)) + (:report (lambda (c stream) + (format stream "[ODBC error] ~A; state: ~A" + (clsql-odbc-error-message c) + (clsql-odbc-error-sql-state c))))) + +;; Signal conditions + + +(defun signal-closed-database-error (database) + (cerror "Ignore this error and return nil." + 'clsql-closed-error + :database database)) + +(defun signal-no-database-error (database) + (error 'clsql-no-database-error :database database)) + +(define-condition clsql-type-error (clsql-error clsql-condition) + ((slotname :initarg :slotname + :reader clsql-type-error-slotname) + (typespec :initarg :typespec + :reader clsql-type-error-typespec) + (value :initarg :value + :reader clsql-type-error-value)) + (:report (lambda (c stream) + (format stream + "Invalid value ~A in slot ~A, not of type ~A." + (clsql-type-error-value c) + (clsql-type-error-slotname c) + (clsql-type-error-typespec c))))) + +(define-condition clsql-sql-syntax-error (clsql-error) + ((reason :initarg :reason + :reader clsql-sql-syntax-error-reason)) + (:report (lambda (c stream) + (format stream "Invalid SQL syntax: ~A" + (clsql-sql-syntax-error-reason c))))) + diff --git a/sql/database.lisp b/sql/database.lisp new file mode 100644 index 0000000..b02a75a --- /dev/null +++ b/sql/database.lisp @@ -0,0 +1,289 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id$ +;;;; +;;;; Base database functions +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(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.") + +(defun is-database-open (database) + (eql (database-state database) :open)) + +(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." + + (unless database-type + (error "Must specify a database-type.")) + + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + + (unless (member database-type *loaded-database-types*) + (asdf:operate 'asdf:load-op (ensure-keyword + (concatenate 'string + (symbol-name '#:clsql-) + (symbol-name database-type))))) + + (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 + (setf (slot-value result 'state) :open) + (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*))) + (setf (slot-value database 'state) :closed) + 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." + (let ((db (etypecase database + (database database) + ((or string list) + (let ((db (find-database database :errorp nil))) + (when (null db) + (if (and database error) + (error 'clsql-generic-error + :message + (format nil "Unable to find database with connection-spec ~A." database)) + (return-from reconnect nil))) + db))))) + + (when (is-database-open db) + (if force + (ignore-errors (disconnect :database db)) + (disconnect :database db :error nil))) + + (connect (connection-spec db)))) + + +(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." + (flet ((get-data () + (let ((data '())) + (dolist (db (connected-databases) data) + (push + (append + (list (if (equal db *default-database*) "*" "") + (database-name db) + (string-downcase (string (database-type db))) + (cond ((and (command-recording-stream db) + (result-recording-stream db)) + "Both") + ((command-recording-stream db) "Commands") + ((result-recording-stream db) "Results") + (t "nil"))) + (when full + (list + (if (conn-pool db) "t" "nil") + (format nil "~A" (length (database-list-tables db))) + (format nil "~A" (length (database-list-views db)))))) + 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 #\-)))) + (format t "~&CLSQL STATUS: ~A~%" (iso-timestring (get-time))) + (let ((data (get-data))) + (when data + (let* ((titles (if full + (list "" "DATABASE" "TYPE" "RECORDING" "POOLED" + "TABLES" "VIEWS") + (list "" "DATABASE" "TYPE" "RECORDING"))) + (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))) + +(defun create-database (connection-spec &key database-type) + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + (database-create connection-spec database-type)) + +(defun probe-database (connection-spec &key database-type) + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + (database-probe connection-spec database-type)) + +(defun destroy-database (connection-spec &key database-type) + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + (database-destroy connection-spec database-type)) + +(defun list-databases (connection-spec &key database-type) + (when (stringp connection-spec) + (setq connection-spec (string-to-list-connection-spec connection-spec))) + (database-list connection-spec database-type)) + +(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/sql/db-interface.lisp b/sql/db-interface.lisp new file mode 100644 index 0000000..84702b9 --- /dev/null +++ b/sql/db-interface.lisp @@ -0,0 +1,321 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; 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 +;;;; onShoreD to support UncommonSQL front-end +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id$ +;;;; +;;;; 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 +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(defgeneric database-type-load-foreign (database-type) + (:documentation + "The internal generic implementation of reload-database-types.")) + +(defgeneric database-type-library-loaded (database-type) + (:documentation + "The internal generic implementation for checking if +database type library loaded successfully.")) + +(defgeneric database-initialize-database-type (database-type) + (:documentation + "The internal generic implementation of initialize-database-type.")) + +(defgeneric database-name-from-spec (connection-spec database-type) + (:documentation + "Returns the name of the database that would be created if connect +was called with the connection-spec.")) + +(defgeneric database-connect (connection-spec database-type) + (:documentation "Internal generic implementation of connect.")) + +(defgeneric database-reconnect (database) + (:method ((database t)) + (signal-no-database-error database)) + (:documentation "Internal generic implementation of reconnect.")) + +(defgeneric database-disconnect (database) + (:method ((database t)) + (signal-no-database-error database)) + (:documentation "Internal generic implementation of disconnect.")) + +(defgeneric database-query (query-expression database result-types field-names) + (:method (query-expression (database t) result-types field-names) + (declare (ignore query-expression result-types field-names)) + (signal-no-database-error database)) + (:documentation "Internal generic implementation of query.")) + + +(defgeneric database-execute-command (sql-expression database) + (:method (sql-expression (database t)) + (declare (ignore sql-expression)) + (signal-no-database-error database)) + (:documentation "Internal generic implementation of execute-command.")) + +;;; Mapping and iteration +(defgeneric database-query-result-set + (query-expression database &key full-set result-types) + (:method (query-expression (database t) &key full-set result-types) + (declare (ignore query-expression full-set result-types)) + (signal-no-database-error database) + (values nil nil nil)) + (:documentation + "Internal generic implementation of query mapping. Starts the +query specified by query-expression on the given database and returns +a result-set to be used with database-store-next-row and +database-dump-result-set to access the returned data. The second +value is the number of columns in the result-set, if there are any. +If full-set is true, the number of rows in the result-set is returned +as a third value, if this is possible (otherwise nil is returned for +the third value). This might have memory and resource usage +implications, since many databases will require the query to be +executed in full to answer this question. If the query produced no +results then nil is returned for all values that would have been +returned otherwise. If an error occurs during query execution, the +function should signal a clsql-sql-error.")) + +(defgeneric database-dump-result-set (result-set database) + (:method (result-set (database t)) + (declare (ignore result-set)) + (signal-no-database-error database)) + (:documentation "Dumps the received result-set.")) + +(defgeneric database-store-next-row (result-set database list) + (:method (result-set (database t) list) + (declare (ignore result-set list)) + (signal-no-database-error database)) + (:documentation + "Returns t and stores the next row in the result set in list or +returns nil when result-set is finished.")) + +(defgeneric database-create (connection-spec type) + (:documentation + "Creates a database, returns T if successfull or signals an error.")) + +(defgeneric database-probe (connection-spec type) + (:method (spec type) + (declare (ignore spec)) + (warn "database-proe not support for database-type ~A." type)) + (:documentation + "Probes for the existence of a database, returns T if database found or NIL +if not found. May signal an error if unable to communicate with database server.")) + +(defgeneric database-list (connection-spec type) + (:method (spec type) + (declare (ignore spec)) + (warn "database-list not support for database-type ~A." type)) + (:documentation + "Lists all databases found for TYPE. May signal an error if unable to communicate with database server.")) + +(defgeneric database-destroy (connection-spec database) + (:documentation "Destroys (drops) a database.")) + +(defgeneric database-truncate (database) + (:method ((database t)) + (signal-no-database-error database)) + (:documentation "Remove all data from database.")) + +(defgeneric database-describe-table (database table) + (:method ((database t) table) + (declare (ignore table)) + (signal-no-database-error database)) + (:documentation "Return a list of name/type for columns in table")) + +(defgeneric database-destory (connection-spec type) + (:documentation + "Destroys a database, returns T if successfull or signals an error +if unable to destory.")) + +(defgeneric database-create-sequence (name database) + (:documentation "Create a sequence in DATABASE.")) + +(defgeneric database-drop-sequence (name database) + (:documentation "Drop a sequence from DATABASE.")) + +(defgeneric database-sequence-next (name database) + (:documentation "Increment a sequence in DATABASE.")) + +(defgeneric database-list-sequences (database &key owner) + (:documentation "List all sequences in DATABASE.")) + +(defgeneric database-set-sequence-position (name position database) + (:documentation "Set the position of the sequence called NAME in DATABASE.")) + +(defgeneric database-sequence-last (name database) + (:documentation "Select the last value in sequence NAME in DATABASE.")) + +(defgeneric database-start-transaction (database) + (:documentation "Start a transaction in DATABASE.")) + +(defgeneric database-commit-transaction (database) + (:documentation "Commit current transaction in DATABASE.")) + +(defgeneric database-abort-transaction (database) + (:documentation "Abort current transaction in DATABASE.")) + +(defgeneric database-get-type-specifier (type args database) + (:documentation "Return the type SQL type specifier as a string, for +the given lisp type and parameters.")) + +(defgeneric database-list-tables (database &key owner) + (:documentation "List all tables in the given database")) + +(defgeneric database-list-views (database &key owner) + (:documentation "List all views in the DATABASE.")) + +(defgeneric database-list-indexes (database &key owner) + (:documentation "List all indexes in the DATABASE.")) + +(defgeneric database-list-table-indexes (table database &key owner) + (:documentation "List all indexes for a table in the DATABASE.")) + +(defgeneric database-list-attributes (table database &key owner) + (:documentation "List all attributes in TABLE.")) + +(defgeneric database-attribute-type (attribute table database &key owner) + (:documentation "Return the type of ATTRIBUTE in TABLE. Returns multiple values +of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.")) + +(defgeneric database-add-attribute (table attribute database) + (:documentation "Add the attribute to the table.")) + +(defgeneric database-rename-attribute (table oldatt newname database) + (:documentation "Rename the attribute in the table to NEWNAME.")) + +(defgeneric oid (object) + (:documentation "Return the unique ID of a database object.")) + +;;; Database backend capabilities + +(defgeneric database-underlying-type (database) + (:method (database) + (database-type database)) + (:documentation "Returns the type of the underlying database. For ODBC, needs to query ODBC driver.")) + +(defgeneric db-type-use-column-on-drop-index? (db-type) + (:method (db-type) + (declare (ignore db-type)) + nil) + (:documentation "NIL [default] if database-type does not use column name on DROP INDEX.")) + +(defgeneric db-type-has-views? (db-type) + (:method (db-type) + (declare (ignore db-type)) + ;; SQL92 has views + t) + (:documentation "T [default] if database-type supports views.")) + +(defgeneric db-type-default-case (db-type) + (:method (db-type) + (declare (ignore db-type)) + ;; By default, CommonSQL converts identifiers to UPPER case. + :upper) + (:documentation ":upper [default] if means identifiers mapped to UPPER case SQL like CommonSQL API. However, Postgresql maps identifiers to lower case, so PostgreSQL uses a value of :lower for this result.")) + +(defgeneric db-type-has-fancy-math? (db-type) + (:method (db-type) + (declare (ignore db-type)) + nil) + (:documentation "NIL [default] if database-type does not have fancy math.")) + +(defgeneric db-type-has-subqueries? (db-type) + (:method (db-type) + (declare (ignore db-type)) + t) + (:documentation "T [default] if database-type supports views.")) + +(defgeneric db-type-has-boolean-where? (db-type) + (:method (db-type) + (declare (ignore db-type)) + ;; SQL99 has boolean where + t) + (:documentation "T [default] if database-type supports boolean WHERE clause, such as 'WHERE MARRIED'.")) + +(defgeneric db-backend-has-create/destroy-db? (db-type) + (:method (db-type) + (declare (ignore db-type)) + t) + (:documentation "T [default] if backend can destroy and create databases.")) + +(defgeneric db-type-transaction-capable? (db database) + (:method (db database) + (declare (ignore db database)) + t) + (:documentation "T [default] if database can supports transactions.")) + +;;; Large objects support (Marc Battyani) + +(defgeneric database-create-large-object (database) + (:documentation "Creates a new large object in the database and returns the object identifier")) + +(defgeneric database-write-large-object (object-id data database) + (:documentation "Writes data to the large object")) + +(defgeneric database-read-large-object (object-id database) + (:documentation "Reads the large object content")) + +(defgeneric database-delete-large-object (object-id database) + (:documentation "Deletes the large object in the database")) + + +;; Checks for closed database + +(defmethod database-disconnect :before ((database database)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defmethod database-query :before (query-expression (database database) + result-set field-names) + (declare (ignore query-expression result-set field-names)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defmethod database-execute-command :before (sql-expression (database database)) + (declare (ignore sql-expression)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defmethod database-query-result-set :before (expr (database database) + &key full-set result-types) + (declare (ignore expr full-set result-types)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defmethod database-dump-result-set :before (result-set (database database)) + (declare (ignore result-set)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defmethod database-store-next-row :before (result-set (database database) list) + (declare (ignore result-set list)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defmethod database-commit-transaction :before ((database database)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defmethod database-start-transaction :before ((database database)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defmethod database-abort-transaction :before ((database database)) + (unless (is-database-open database) + (signal-closed-database-error database))) + +(defgeneric describe-table (table &key database) + (:documentation "Describes a table, returns a list of name/type for columns in table")) + diff --git a/sql/generics.lisp b/sql/generics.lisp index cbf2d7e..a7c8be1 100644 --- a/sql/generics.lisp +++ b/sql/generics.lisp @@ -16,7 +16,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) (defgeneric update-record-from-slot (object slot &key database) (:documentation diff --git a/sql/initialize.lisp b/sql/initialize.lisp new file mode 100644 index 0000000..9fad818 --- /dev/null +++ b/sql/initialize.lisp @@ -0,0 +1,58 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; 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-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 +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(defvar *loaded-database-types* nil + "Contains a list of database types which have been defined/loaded.") + +(defmethod database-type-load-foreign (x) + (error "No generic function defined for database-type-load-foreign with parameters of ~S" x)) + +(defmethod database-type-load-foreign :after (database-type) + (when (database-type-library-loaded database-type) + (pushnew database-type *loaded-database-types*))) + +(defun reload-database-types () + "Reloads any foreign code for the loaded database types after a dump." + (mapc #'database-type-load-foreign *loaded-database-types*)) + +(defvar *default-database-type* nil + "Specifies the default type of database.") + +(defvar *initialized-database-types* nil + "Contains a list of database types which have been initialized by calls +to initialize-database-type.") + +(defun initialize-database-type (&key (database-type *default-database-type*)) + "Initialize the given database-type, if it is not already +initialized, as indicated by `*initialized-database-types*'." + (when (member database-type *initialized-database-types*) + (return-from initialize-database-type database-type)) + + (let ((system (intern (concatenate 'string + (symbol-name '#:clsql-) + (symbol-name database-type))))) + (when (not (find-package system)) + (asdf:operate 'asdf:load-op system))) + + (when (database-initialize-database-type database-type) + (push database-type *initialized-database-types*) + database-type)) + diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp index e82ac66..530bee4 100644 --- a/sql/kmr-mop.lisp +++ b/sql/kmr-mop.lisp @@ -16,7 +16,7 @@ ;;;; This file was extracted from the KMRCL utilities ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) #+lispworks (defun intern-eql-specializer (slot) diff --git a/sql/loop-extension.lisp b/sql/loop-extension.lisp new file mode 100644 index 0000000..701e77f --- /dev/null +++ b/sql/loop-extension.lisp @@ -0,0 +1,229 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: loop-extension.lisp +;;;; Purpose: Extensions to the Loop macro for CLSQL +;;;; +;;;; Copyright (c) 2001-2004 Kevin Rosenberg and (c) 1999-2001 Pierre R. Mai +;;;; +;;;; $Id$ +;;;; ************************************************************************* + +(in-package #:cl-user) + +#+(or allegro sbcl) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defpackage #:ansi-loop + (:import-from #+sbcl #:sb-loop #+allegro #:excl + #:loop-error + #:*loop-epilogue* + #:*loop-ansi-universe* + #:add-loop-path))) + +#+(or allegro sbcl) +(defun ansi-loop::loop-gentemp (&optional (pref 'loopva-)) + (gensym (string pref))) + +#+(or cmu scl sbcl openmcl allegro) +(defun loop-record-iteration-path (variable data-type prep-phrases) + (let ((in-phrase nil) + (from-phrase nil)) + (loop for (prep . rest) in prep-phrases + do + (case prep + ((:in :of) + (when in-phrase + (ansi-loop::loop-error + "Duplicate OF or IN iteration path: ~S." (cons prep rest))) + (setq in-phrase rest)) + ((:from) + (when from-phrase + (ansi-loop::loop-error + "Duplicate FROM iteration path: ~S." (cons prep rest))) + (setq from-phrase rest)) + (t + (ansi-loop::loop-error + "Unknown preposition: ~S." prep)))) + (unless in-phrase + (ansi-loop::loop-error "Missing OF or IN iteration path.")) + (unless from-phrase + (setq from-phrase '(clsql-sys:*default-database*))) + + (unless (consp variable) + (setq variable (list variable))) + + (cond + ;; object query + ((and (consp (first in-phrase)) + (string-equal "sql-query" (symbol-name (caar in-phrase))) + (consp (second (first in-phrase))) + (eq 'quote (first (second (first in-phrase)))) + (symbolp (second (second (first in-phrase))))) + + (let ((result-var (ansi-loop::loop-gentemp + 'loop-record-result-)) + (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) + `(((,variable nil ,@(and data-type (list data-type))) + (,result-var (clsql-sys:query ,(first in-phrase))) + (,step-var nil)) + () + () + () + (if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil)) + (,variable ,step-var) + (null ,result-var) + () + (if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil)) + (,variable ,step-var)))) + + ((consp variable) + (let ((query-var (ansi-loop::loop-gentemp 'loop-record-)) + (db-var (ansi-loop::loop-gentemp 'loop-record-database-)) + (result-set-var (ansi-loop::loop-gentemp + 'loop-record-result-set-)) + (step-var (ansi-loop::loop-gentemp 'loop-record-step-))) + (push `(when ,result-set-var + (clsql-sys:database-dump-result-set ,result-set-var ,db-var)) + ansi-loop::*loop-epilogue*) + `(((,variable nil ,@(and data-type (list data-type))) + (,query-var ,(first in-phrase)) + (,db-var ,(first from-phrase)) + (,result-set-var nil) + (,step-var nil)) + ((multiple-value-bind (%rs %cols) + (clsql-sys:database-query-result-set ,query-var ,db-var :result-types :auto) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + (not (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var) + (not ,result-set-var) + () + (not (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var)) + (,variable ,step-var))))))) + +#+(or cmu scl sbcl openmcl allegro) +(ansi-loop::add-loop-path '(record records tuple tuples) + 'loop-record-iteration-path + ansi-loop::*loop-ansi-universe* + :preposition-groups '((:of :in) (:from)) + :inclusive-permitted nil) + +#+lispworks +(eval-when (:compile-toplevel :load-toplevel :execute) + (in-package loop)) + +#+lispworks +(cl-user::define-loop-method (record records tuple tuples) clsql-loop-method + (in of from)) + +#+lispworks +(defun clsql-loop-method (method-name iter-var iter-var-data-type + prep-phrases inclusive? allowed-preps + method-specific-data) + (declare (ignore method-name inclusive? allowed-preps method-specific-data)) + (let ((in-phrase nil) + (from-phrase nil)) + (loop for (prep . rest) in prep-phrases + do + (cond + ((or (eq prep 'in) (eq prep 'of)) + (when in-phrase + (error + "Duplicate OF or IN iteration path: ~S." (cons prep rest))) + (setq in-phrase rest)) + ((eq prep 'from) + (when from-phrase + (error + "Duplicate FROM iteration path: ~S." (cons prep rest))) + (setq from-phrase rest)) + (t + (error + "Unknown preposition: ~S." prep)))) + (unless in-phrase + (error "Missing OF or IN iteration path.")) + (unless from-phrase + (setq from-phrase '(clsql:*default-database*))) + + (unless (consp iter-var) + (setq iter-var (list iter-var))) + + (cond + ;; object query + ((and (consp in-phrase) + (string-equal "sql-query" (symbol-name (car in-phrase))) + (consp (second in-phrase)) + (eq 'quote (first (second in-phrase))) + (symbolp (second (second in-phrase)))) + + (let ((result-var (gensym "LOOP-RECORD-RESULT-")) + (step-var (gensym "LOOP-RECORD-STEP-"))) + (values + t + nil + `(,@(mapcar (lambda (v) `(,v nil)) iter-var) + (,result-var (clsql:query ,in-phrase)) + (,step-var nil)) + () + () + () + `((if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil))) + `(,iter-var ,step-var) + `((if (null ,result-var) + t + (progn + (setq ,step-var (first ,result-var)) + (setq ,result-var (rest ,result-var)) + nil))) + `(,iter-var ,step-var) + () + () + ))) + + ((consp iter-var) + (let ((query-var (gensym "LOOP-RECORD-")) + (db-var (gensym "LOOP-RECORD-DATABASE-")) + (result-set-var (gensym "LOOP-RECORD-RESULT-SET-")) + (step-var (gensym "LOOP-RECORD-STEP-"))) + (values + t + nil + `(,@(mapcar (lambda (v) `(,v nil)) iter-var) + (,query-var ,in-phrase) + (,db-var ,(first from-phrase)) + (,result-set-var nil) + (,step-var nil)) + `((multiple-value-bind (%rs %cols) + (clsql-sys:database-query-result-set ,query-var ,db-var :result-types :auto) + (setq ,result-set-var %rs ,step-var (make-list %cols)))) + () + () + `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var) + (when ,result-set-var + (clsql-sys:database-dump-result-set ,result-set-var ,db-var)) + t)) + `(,iter-var ,step-var) + `((unless (clsql-sys:database-store-next-row ,result-set-var ,db-var ,step-var) + (when ,result-set-var + (clsql-sys:database-dump-result-set ,result-set-var ,db-var)) + t)) + `(,iter-var ,step-var) + () + ())))))) + diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 1ab11f4..5d47ce9 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -12,7 +12,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list diff --git a/sql/objects.lisp b/sql/objects.lisp index 04951f9..ce6022c 100644 --- a/sql/objects.lisp +++ b/sql/objects.lisp @@ -13,7 +13,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) (defclass standard-db-object () ((view-database :initform nil :initarg :view-database :reader view-database @@ -182,7 +182,7 @@ superclass of the newly-defined View Class." (defclass ,class ,supers ,slots ,@(if (find :metaclass `,cl-options :key #'car) `,cl-options - (cons '(:metaclass clsql::standard-db-class) `,cl-options))) + (cons '(:metaclass clsql-sys::standard-db-class) `,cl-options))) (finalize-inheritance (find-class ',class)) (find-class ',class))) @@ -423,7 +423,7 @@ superclass of the newly-defined View Class." (let ((qualifier (key-qualifier-for-instance instance :database vd))) (delete-records :from vt :where qualifier :database vd) (setf (slot-value instance 'view-database) nil)) - (error 'clsql-base::clsql-no-database-error :database nil)))) + (error 'clsql-no-database-error :database nil)))) (defmethod update-instance-from-records ((instance standard-db-object) &key (database *default-database*)) @@ -482,7 +482,7 @@ superclass of the newly-defined View Class." (defmethod database-get-type-specifier (type args database) (declare (ignore type args)) - (if (clsql-base::in (database-underlying-type database) + (if (in (database-underlying-type database) :postgresql :postgresql-socket) "VARCHAR" "VARCHAR(255)")) @@ -506,7 +506,7 @@ superclass of the newly-defined View Class." database) (if args (format nil "VARCHAR(~A)" (car args)) - (if (clsql-base::in (database-underlying-type database) + (if (in (database-underlying-type database) :postgresql :postgresql-socket) "VARCHAR" "VARCHAR(255)"))) @@ -515,7 +515,7 @@ superclass of the newly-defined View Class." database) (if args (format nil "VARCHAR(~A)" (car args)) - (if (clsql-base::in (database-underlying-type database) + (if (in (database-underlying-type database) :postgresql :postgresql-socket) "VARCHAR" "VARCHAR(255)"))) @@ -523,7 +523,7 @@ superclass of the newly-defined View Class." (defmethod database-get-type-specifier ((type (eql 'string)) args database) (if args (format nil "VARCHAR(~A)" (car args)) - (if (clsql-base::in (database-underlying-type database) + (if (in (database-underlying-type database) :postgresql :postgresql-socket) "VARCHAR" "VARCHAR(255)"))) @@ -587,7 +587,7 @@ superclass of the newly-defined View Class." (declare (ignore database)) (progv '(*print-circle* *print-array*) '(t t) (let ((escaped (prin1-to-string val))) - (clsql-base::substitute-char-string + (substitute-char-string escaped #\Null " ")))) (defmethod database-output-sql-as-type ((type (eql 'symbol)) val database) @@ -667,8 +667,8 @@ superclass of the newly-defined View Class." (defmethod read-sql-value (val (type (eql 'symbol)) database) (declare (ignore database)) (when (< 0 (length val)) - (unless (string= val (clsql-base:symbol-name-default-case "NIL")) - (intern (clsql-base:symbol-name-default-case val) + (unless (string= val (symbol-name-default-case "NIL")) + (intern (symbol-name-default-case val) (symbol-package *update-context*))))) (defmethod read-sql-value (val (type (eql 'integer)) database) diff --git a/sql/operations.lisp b/sql/operations.lisp index f05df97..9d8ef8d 100644 --- a/sql/operations.lisp +++ b/sql/operations.lisp @@ -12,7 +12,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) ;; Keep a hashtable for mapping symbols to sql generator functions, ;; for use by the bracketed reader syntax. diff --git a/sql/package.lisp b/sql/package.lisp index 1b887ed..5893046 100644 --- a/sql/package.lisp +++ b/sql/package.lisp @@ -1,9 +1,9 @@ ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* +;;;; FILE IDENTIFICATION ;;;; -;;;; $Id$ -;;;; -;;;; Package definitions for CLSQL. +;;;; Name: package.lisp +;;;; Purpose: Package definition for SQL interface ;;;; ;;;; This file is part of CLSQL. ;;;; @@ -14,13 +14,15 @@ (in-package #:cl-user) -(eval-when (:compile-toplevel :load-toplevel :execute) +;;;; This file makes the required package definitions for CLSQL's +;;;; core packages. -#+sbcl +(eval-when (:compile-toplevel :load-toplevel :execute) + #+sbcl (if (find-package 'sb-mop) (pushnew :clsql-sbcl-mop cl:*features*) (pushnew :clsql-sbcl-pcl cl:*features*)) - + #+cmu (if (eq (symbol-package 'pcl:find-class) (find-package 'common-lisp)) @@ -29,8 +31,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) - (defpackage #:clsql - (:use #:common-lisp #:clsql-base + (defpackage #:clsql-sys + (:use #:common-lisp #+clsql-sbcl-mop #:sb-mop #+clsql-cmucl-mop #:mop #+allegro #:mop @@ -41,341 +43,194 @@ #+allegro (:shadowing-import-from #:excl) - #+lispworks - (:shadowing-import-from - #:clos) - #+clsql-sbcl-mop - (:shadowing-import-from - #:sb-pcl - #:generic-function-lambda-list) - #+clsql-sbcl-pcl - (:shadowing-import-from - #:sb-pcl - #:name - #:class-direct-slots - #:class-of #:class-name #:class-slots #:find-class - #:slot-boundp - #:standard-class - #:slot-definition-name #:finalize-inheritance - #:standard-direct-slot-definition - #:standard-effective-slot-definition #:validate-superclass - #:direct-slot-definition-class #:compute-effective-slot-definition - #:effective-slot-definition-class - #:slot-value-using-class - #:class-prototype #:generic-function-method-class #:intern-eql-specializer - #:make-method-lambda #:generic-function-lambda-list - #:class-precedence-list #:slot-definition-type - #:class-direct-superclasses - #:compute-class-precedence-list) - #+clsql-cmucl-mop - (:shadowing-import-from - #:pcl - #:generic-function-lambda-list) - #+clsql-cmucl-pcl - (:shadowing-import-from - #:pcl - #:class-direct-slots - #:name - #:class-of #:class-name #:class-slots #:find-class #:standard-class - #:slot-boundp - #:slot-definition-name #:finalize-inheritance - #:standard-direct-slot-definition #:standard-effective-slot-definition - #:validate-superclass #:direct-slot-definition-class - #:effective-slot-definition-class - #:compute-effective-slot-definition - #:slot-value-using-class - #:class-prototype #:generic-function-method-class #:intern-eql-specializer - #:make-method-lambda #:generic-function-lambda-list - #:class-precedence-list #:slot-definition-type - #:class-direct-superclasses - #:compute-class-precedence-list) - #+scl - (:shadowing-import-from - #:clos - #:class-prototype ;; note: make-method-lambda is not fbound - ) - - (:import-from - #:clsql-base - . - #1=( - ;; conditions - #:clsql-condition - #:clsql-error - #:clsql-simple-error - #:clsql-warning - #:clsql-simple-warning - #:clsql-invalid-spec-error - #:clsql-invalid-spec-error-connection-spec - #:clsql-invalid-spec-error-database-type - #:clsql-invalid-spec-error-template - #:clsql-access-error - #:clsql-access-error-database-type - #:clsql-access-error-connection-spec - #:clsql-access-error-error - #:clsql-connect-error - #:clsql-connect-error-errno - #: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 - #:*backend-warning-behavior* - - ;; 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-table-indexes - #:database-list-sequences - #:database-list-attributes - #:database-attribute-type - #:database-add-attribute - #:database-type - - ;; initialize - #:*loaded-database-types* - #:reload-database-types - #:*initialized-database-types* - #:initialize-database-type - ;; classes - #:database - #:database-name - #:command-recording-stream - #:result-recording-stream - #:database-view-classes - #:conn-pool - #:print-object - - ;; utils - #:sql-escape + #+lispworks + (:shadowing-import-from + #:clos) + #+clsql-sbcl-mop + (:shadowing-import-from + #:sb-pcl + #:generic-function-lambda-list) + #+clsql-sbcl-pcl + (:shadowing-import-from + #:sb-pcl + #:name + #:class-direct-slots + #:class-of #:class-name #:class-slots #:find-class + #:slot-boundp + #:standard-class + #:slot-definition-name #:finalize-inheritance + #:standard-direct-slot-definition + #:standard-effective-slot-definition #:validate-superclass + #:direct-slot-definition-class #:compute-effective-slot-definition + #:effective-slot-definition-class + #:slot-value-using-class + #:class-prototype #:generic-function-method-class #:intern-eql-specializer + #:make-method-lambda #:generic-function-lambda-list + #:class-precedence-list #:slot-definition-type + #:class-direct-superclasses + #:compute-class-precedence-list) + #+clsql-cmucl-mop + (:shadowing-import-from + #:pcl + #:generic-function-lambda-list) + #+clsql-cmucl-pcl + (:shadowing-import-from + #:pcl + #:class-direct-slots + #:name + #:class-of #:class-name #:class-slots #:find-class #:standard-class + #:slot-boundp + #:slot-definition-name #:finalize-inheritance + #:standard-direct-slot-definition #:standard-effective-slot-definition + #:validate-superclass #:direct-slot-definition-class + #:effective-slot-definition-class + #:compute-effective-slot-definition + #:slot-value-using-class + #:class-prototype #:generic-function-method-class #:intern-eql-specializer + #:make-method-lambda #:generic-function-lambda-list + #:class-precedence-list #:slot-definition-type + #:class-direct-superclasses + #:compute-class-precedence-list) + #+scl + (:shadowing-import-from + #:clos + #:class-prototype ;; note: make-method-lambda is not fbound + ) + + (: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-disconnect + #: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-list-table-indexes + #:database-index-exists-p + #:database-list-sequences + #:database-sequence-exists-p + #:database-list-attributes + #:database-attribute-type + #:database-describe-table + #:database-type-library-loaded + + #:db-backend-has-create/destroy-db? + #:db-type-has-views? + #:db-type-has-subqueries? + #:db-type-has-boolean-where? + #:db-type-transaction-capable? + #:db-type-has-fancy-math? + #:db-type-default-case + #:db-type-use-column-on-drop-index? + #:database-underlying-type - ;; database.lisp -- Connection - #:*default-database-type* ; database xx - #:*default-database* ; database 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 xx - #:find-database ; database xx - #:status ; database xx - #:with-database - #:with-default-database - #:create-database - #:destroy-database - #:probe-database - - ;; pool.lisp - #:disconnect-pooled + ;; Large objects + #:database-create-large-object + #:database-write-large-object + #:database-read-large-object + #:database-delete-large-object + #:create-large-object + #:write-large-object + #:read-large-object + #:delete-large-object - ;; basic-sql.lisp - #:query - #:execute-command - #:write-large-object - #:read-large-object - #:delete-large-object - #:describe-table - #:create-large-object - #:write-large-object - #:read-large-object - #:delete-large-object + ;; accessors for database class + #:name + #:connection-spec + #:transaction + #:transaction-level + #:conn-pool + #:command-recording-stream + #:result-recording-stream + #:record-caches + #:view-classes + #:database-type + #:database-state + #:attribute-cache + - - ;; recording.lisp -- SQL I/O Recording - #:record-sql-command - #:record-sql-result - #:add-sql-stream ; recording xx - #:delete-sql-stream ; recording xx - #:list-sql-streams ; recording xx - #:sql-recording-p ; recording xx - #:sql-stream ; recording xx - #:start-sql-recording ; recording xx - #:stop-sql-recording ; recording xx - - ;; 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 - - ;; Database capabilities - #:db-type-use-column-on-drop-index? - #:db-backend-has-create/destroy-db? - #:db-type-has-views? - #:db-type-has-subqueries? - #:db-type-has-boolean-where? - #:db-type-transaction-capable? - #:db-type-has-fancy-math? - #:db-type-default-case - #:convert-to-db-default-case - #:database-underlying-type + ;; utils.lisp + #:without-interrupts + #:make-process-lock + #:with-process-lock + #:command-output + #:symbol-name-default-case + #:convert-to-db-default-case + #:ensure-keyword - ;; time.lisp - #:bad-component - #:current-day - #:current-month - #:current-year - #:day-duration - #:db-timestring - #:decode-duration - #:decode-time - #:duration - #:duration+ - #:duration< - #:duration<= - #:duration= - #:duration> - #:duration>= - #:duration-day - #:duration-hour - #:duration-minute - #:duration-month - #:duration-second - #:duration-year - #:duration-reduce - #:duration-timestring - #:extract-roman - #:format-duration - #:format-time - #:get-time - #:utime->time - #:interval-clear - #:interval-contained - #:interval-data - #:interval-edit - #:interval-end - #:interval-match - #:interval-push - #:interval-relation - #:interval-start - #:interval-type - #:make-duration - #:make-interval - #:make-time - #:merged-time - #:midnight - #:month-name - #:parse-date-time - #:parse-timestring - #:parse-yearstring - #:print-date - #:roll - #:roll-to - #:time - #:time+ - #:time- - #:time-by-adding-duration - #:time-compare - #:time-difference - #:time-dow - #:time-element - #:time-max - #:time-min - #:time-mjd - #:time-msec - #:time-p - #:time-sec - #:time-well-formed - #:time-ymd - #:time< - #:time<= - #:time= - #:time> - #:time>= - #:timezone - #:universal-time - #:wall-time - #:wall-timestring - #:week-containing - #:gregorian-to-mjd - #:mjd-to-gregorian - )) - (: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-list-table-indexes - #:database-index-exists-p - #:database-list-sequences - #:database-sequence-exists-p - #:database-list-attributes - #:database-attribute-type - #:database-describe-table + + #:clsql-invalid-spec-error + #:clsql-invalid-spec-error-connection-spec + #:clsql-invalid-spec-error-database-type + #:clsql-invalid-spec-error-template + #:clsql-access-error + #:clsql-access-error-database-type + #:clsql-access-error-connection-spec + #:clsql-access-error-error + #:clsql-connect-error + #:clsql-connect-error-errno + #: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-sql-syntax-error + #:clsql-type-error + #:clsql-odbc-error + #:clsql-odbc-error-message + + #:*loaded-database-types* + #:reload-database-types + #:*initialized-database-types* + #:initialize-database-type + #:*connect-if-exists* + #:*default-database* + #:connected-databases + #:database + #:find-database + #:is-database-open + #:database-type ; database x - #:db-backend-has-create/destroy-db? - #:db-type-has-views? - #:db-type-has-subqueries? - #:db-type-has-boolean-where? - #:db-type-transaction-capable? - #:db-type-has-fancy-math? - #:db-type-default-case - #:database-underlying-type - - . - ;; Shared exports for re-export by CLSQL-USER. - ;; I = Implemented, D = Documented - ;; name file ID - ;;==================================================== - #2=(;;------------------------------------------------ - ;; CommonSQL API - ;;------------------------------------------------ - ;;FDML + ;; utils.lisp + #:number-to-sql-string + #:float-to-sql-string + #:sql-escape-quotes + #:in + + . + ;; Shared exports for re-export by CLSQL package. + ;; I = Implemented, D = Documented + ;; name file ID + ;;==================================================== + #1=(;;------------------------------------------------ + ;; CommonSQL API + ;;------------------------------------------------ + ;;FDML #:select ; objects xx #:cache-table-queries ; #:*cache-table-queries-default* ; @@ -387,7 +242,9 @@ #:print-query ; sql xx #:do-query ; sql xx #:map-query ; sql xx - #:loop ; loop-ext x + #:for-each-row + #:loop + ;;FDDL #:create-table ; table xx #:drop-table ; table xx @@ -429,14 +286,6 @@ #: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 - #:database-type ; database x - #:is-database-open ;;FDDL #:list-views ; table xx #:view-exists-p ; table xx @@ -463,6 +312,13 @@ #:database-get-type-specifier ; objects x #:database-output-sql ; sql/class xx + ;; conditions + #:clsql-condition + #:clsql-error + #:clsql-simple-error + #:clsql-warning + #:clsql-simple-warning + ;;----------------------------------------------- ;; Symbolic Sql Syntax ;;----------------------------------------------- @@ -505,24 +361,152 @@ #:sql-view-class #:sql_slot-value - #:do-query - #:map-query - . - #1# + + ;; time.lisp + #:bad-component + #:current-day + #:current-month + #:current-year + #:day-duration + #:db-timestring + #:decode-duration + #:decode-time + #:duration + #:duration+ + #:duration< + #:duration<= + #:duration= + #:duration> + #:duration>= + #:duration-day + #:duration-hour + #:duration-minute + #:duration-month + #:duration-second + #:duration-year + #:duration-reduce + #:duration-timestring + #:extract-roman + #:format-duration + #:format-time + #:get-time + #:utime->time + #:interval-clear + #:interval-contained + #:interval-data + #:interval-edit + #:interval-end + #:interval-match + #:interval-push + #:interval-relation + #:interval-start + #:interval-type + #:make-duration + #:make-interval + #:make-time + #:merged-time + #:midnight + #:month-name + #:parse-date-time + #:parse-timestring + #:parse-yearstring + #:print-date + #:roll + #:roll-to + #:time + #:time+ + #:time- + #:time-by-adding-duration + #:time-compare + #:time-difference + #:time-dow + #:time-element + #:time-max + #:time-min + #:time-mjd + #:time-msec + #:time-p + #:time-sec + #:time-well-formed + #:time-ymd + #:time< + #:time<= + #:time= + #:time> + #:time>= + #:timezone + #:universal-time + #:wall-time + #:wall-timestring + #:week-containing + #:gregorian-to-mjd + #:mjd-to-gregorian + + ;; recording.lisp -- SQL I/O Recording + #:record-sql-command + #:record-sql-result + #:add-sql-stream ; recording xx + #:delete-sql-stream ; recording xx + #:list-sql-streams ; recording xx + #:sql-recording-p ; recording xx + #:sql-stream ; recording xx + #:start-sql-recording ; recording xx + #:stop-sql-recording ; recording xx + + ;; 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 + #:disconnect-pooled + #:create-database + #:destroy-database + #:probe-database + #:list-databases + + #:describe-table + #:*backend-warning-behavior* + + ;; Transactions + #:with-transaction + #:commit-transaction + #:rollback-transaction + #:add-transaction-commit-hook + #:add-transaction-rollback-hook + #:commit ; transact xx + #:rollback ; transact xx + #:with-transaction ; transact xx . + #:start-transaction ; transact xx + #:in-transaction-p ; transact xx + #:database-start-transaction + #:database-abort-transaction + #:database-commit-transaction + #:transaction-level + #:transaction )) (:documentation "This is the INTERNAL SQL-Interface package of CLSQL.")) -;; 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 + (:use #:common-lisp) + (:import-from #:clsql-sys . #1#) + (:export . #1#) + (:documentation "This is the user package with CLSQL symbols.")) (defpackage #:clsql-user (:use #:common-lisp) - (:import-from #:clsql . #2#) - (:export . #2#) + (:import-from #:clsql-sys . #1#) + (:export . #1#) (:documentation "This is the user package with CLSQL symbols.")) ;; This is from USQL's pcl-patch @@ -537,8 +521,12 @@ slot-vars pv-parameters)) ,@(mapcar #'(lambda (slot-var) `(declare (ignorable ,slot-var))) slot-vars) ,@body)))) - - + +;; 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=)) + #+sbcl (if (find-package 'sb-mop) (setq cl:*features* (delete :clsql-sbcl-mop cl:*features*)) @@ -548,7 +536,6 @@ (if (find-package 'mop) (setq cl:*features* (delete :clsql-cmucl-mop cl:*features*)) (setq cl:*features* (delete :clsql-cmucl-pcl cl:*features*))) - -);eval-when +) ;eval-when diff --git a/sql/pool.lisp b/sql/pool.lisp new file mode 100644 index 0000000..b0e228f --- /dev/null +++ b/sql/pool.lisp @@ -0,0 +1,111 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: pool.lisp +;;;; Purpose: Support function for connection pool +;;;; Programmers: Kevin M. Rosenberg, Marc Battyani +;;;; Date Started: Apr 2002 +;;;; +;;;; $Id$ +;;;; +;;;; This file, part of CLSQL, is Copyright (c) 2002-2003 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 #:clsql-sys) + +(defvar *db-pool* (make-hash-table :test #'equal)) +(defvar *db-pool-lock* (make-process-lock "DB Pool lock")) + +(defclass conn-pool () + ((connection-spec :accessor connection-spec :initarg :connection-spec) + (database-type :accessor pool-database-type :initarg :pool-database-type) + (free-connections :accessor free-connections + :initform (make-array 5 :fill-pointer 0 :adjustable t)) + (all-connections :accessor all-connections + :initform (make-array 5 :fill-pointer 0 :adjustable t)) + (lock :accessor conn-pool-lock + :initform (make-process-lock "Connection pool")))) + +(defun acquire-from-conn-pool (pool) + (or (with-process-lock ((conn-pool-lock pool) "Acquire from pool") + (and (plusp (length (free-connections pool))) + (vector-pop (free-connections pool)))) + (let ((conn (connect (connection-spec pool) + :database-type (pool-database-type pool) + :if-exists :new))) + (with-process-lock ((conn-pool-lock pool) "Acquire from pool") + (vector-push-extend conn (all-connections pool)) + (setf (conn-pool conn) pool)) + conn))) + +(defun release-to-conn-pool (conn) + (let ((pool (conn-pool conn))) + (with-process-lock ((conn-pool-lock pool) "Release to pool") + (vector-push-extend conn (free-connections pool))))) + +(defun clear-conn-pool (pool) + (with-process-lock ((conn-pool-lock pool) "Clear pool") + (loop for conn across (all-connections pool) + do (setf (conn-pool conn) nil) + (disconnect :database conn)) + (setf (fill-pointer (free-connections pool)) 0) + (setf (fill-pointer (all-connections pool)) 0)) + 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" + (with-process-lock (*db-pool-lock* "Find-or-create connection") + (let* ((key (list connection-spec database-type)) + (conn-pool (gethash key *db-pool*))) + (unless conn-pool + (setq conn-pool (make-instance 'conn-pool + :connection-spec connection-spec + :pool-database-type database-type)) + (setf (gethash key *db-pool*) conn-pool)) + conn-pool))) + +(defun acquire-from-pool (connection-spec database-type &optional pool) + (unless (typep pool 'conn-pool) + (setf pool (find-or-create-connection-pool connection-spec database-type))) + (acquire-from-conn-pool pool)) + +(defun release-to-pool (database) + (release-to-conn-pool database)) + +(defun disconnect-pooled (&optional clear) + "Disconnects all connections in the pool." + (with-process-lock (*db-pool-lock* "Disconnect pooled") + (maphash + #'(lambda (key conn-pool) + (declare (ignore key)) + (clear-conn-pool conn-pool)) + *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/sql/recording.lisp b/sql/recording.lisp new file mode 100644 index 0000000..7df9a8b --- /dev/null +++ b/sql/recording.lisp @@ -0,0 +1,150 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id$ +;;;; +;;;; CLSQL broadcast streams which can be used to monitor the +;;;; flow of commands to, and results from, a database. +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(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/sql/sql.lisp b/sql/sql.lisp index 0397bd0..ae4da83 100644 --- a/sql/sql.lisp +++ b/sql/sql.lisp @@ -12,7 +12,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) ;;; Basic operations on databases @@ -45,7 +45,7 @@ (defun truncate-database (&key (database *default-database*)) (unless (typep database 'database) - (clsql-base::signal-no-database-error database)) + (signal-no-database-error database)) (unless (is-database-open database) (database-reconnect database)) (when (db-type-has-views? (database-underlying-type database)) @@ -413,3 +413,75 @@ MAP." (setf (aref result index) (apply function row)))) (database-dump-result-set result-set database))))) + +;;; Row processing macro from CLSQL + +(defmacro for-each-row (((&rest fields) &key from order-by where distinct limit) &body body) + (let ((d (gensym "DISTINCT-")) + (bind-fields (loop for f in fields collect (car f))) + (w (gensym "WHERE-")) + (o (gensym "ORDER-BY-")) + (frm (gensym "FROM-")) + (l (gensym "LIMIT-")) + (q (gensym "QUERY-"))) + `(let ((,frm ,from) + (,w ,where) + (,d ,distinct) + (,l ,limit) + (,o ,order-by)) + (let ((,q (query-string ',fields ,frm ,w ,d ,o ,l))) + (loop for tuple in (query ,q) + collect (destructuring-bind ,bind-fields tuple + ,@body)))))) + +(defun query-string (fields from where distinct order-by limit) + (concatenate + 'string + (format nil "select ~A~{~A~^,~} from ~{~A~^ and ~}" + (if distinct "distinct " "") (field-names fields) + (from-names from)) + (if where (format nil " where ~{~A~^ ~}" + (where-strings where)) "") + (if order-by (format nil " order by ~{~A~^, ~}" + (order-by-strings order-by))) + (if limit (format nil " limit ~D" limit) ""))) + +(defun lisp->sql-name (field) + (typecase field + (string field) + (symbol (string-upcase (symbol-name field))) + (cons (cadr field)) + (t (format nil "~A" field)))) + +(defun field-names (field-forms) + "Return a list of field name strings from a fields form" + (loop for field-form in field-forms + collect + (lisp->sql-name + (if (cadr field-form) + (cadr field-form) + (car field-form))))) + +(defun from-names (from) + "Return a list of field name strings from a fields form" + (loop for table in (if (atom from) (list from) from) + collect (lisp->sql-name table))) + + +(defun where-strings (where) + (loop for w in (if (atom (car where)) (list where) where) + collect + (if (consp w) + (format nil "~A ~A ~A" (second w) (first w) (third w)) + (format nil "~A" w)))) + +(defun order-by-strings (order-by) + (loop for o in order-by + collect + (if (atom o) + (lisp->sql-name o) + (format nil "~A ~A" (lisp->sql-name (car o)) + (lisp->sql-name (cadr o)))))) + + + diff --git a/sql/syntax.lisp b/sql/syntax.lisp index 9fca445..5a713d0 100644 --- a/sql/syntax.lisp +++ b/sql/syntax.lisp @@ -14,7 +14,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) (defvar *original-reader-enter* nil) diff --git a/sql/table.lisp b/sql/table.lisp index ad8c55a..3820c19 100644 --- a/sql/table.lisp +++ b/sql/table.lisp @@ -15,7 +15,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) ;; Utilities diff --git a/sql/time.lisp b/sql/time.lisp new file mode 100644 index 0000000..8d06846 --- /dev/null +++ b/sql/time.lisp @@ -0,0 +1,1122 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id$ +;;;; +;;;; A variety of structures and function for creating and +;;;; manipulating dates, times, durations and intervals for +;;;; CLSQL. +;;;; +;;;; This file was originally part of ODCL and is Copyright (c) 2002 - +;;;; 2003 onShore Development, Inc. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +;; ------------------------------------------------------------ +;; 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 + +(defun duration-timestring (duration) + (let ((second (duration-second duration)) + (minute (duration-minute duration)) + (hour (duration-hour duration)) + (day (duration-day duration))) + (format nil "P~dD~dH~dM~dS" day hour minute second))) + + +;; ------------------------------------------------------------ +;; 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 utime->time (utime) + "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)" + (multiple-value-bind (second minute hour day mon year) + (decode-universal-time utime) + (make-time :year year :month mon :day day :hour hour :minute minute + :second second))) + +(defun get-time () + "Return a pair: (GREGORIAN DAY . TIME-OF-DAY)" + (utime->time (get-universal-time))) + +(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 (month day year) + (mjd-to-gregorian (time-mjd time)) + (values year month 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 &optional round) + (ecase precision + (:second + (+ (duration-second duration) + (* (duration-reduce duration :minute) 60))) + (:minute + (+ (if round + (floor (duration-second duration) 30) + 0) + (duration-minute duration) + (* (duration-reduce duration :hour) 60))) + (:hour + (+ (if round + (floor (duration-minute duration) 30) + 0) + (duration-hour duration) + (* (duration-reduce duration :day) 24))) + (:day + (+ (if round + (floor (duration-hour duration) 12) + 0) + (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) (setf 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) (setf 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) + (name 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! + (let ((list (sort-interval-list list))) + (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)))))) + +(defun interval-clear (list time) + (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" + (let ((*print-circle* nil)) + (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-month () + (second (mjd-to-gregorian (time-mjd (get-time))))) + +(defun current-day () + (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")))) + +(defgeneric to-string (val &rest keys) + ) + +(defmethod to-string ((time wall-time) &rest keys) + (destructuring-bind (&key (style :daytime) &allow-other-keys) + keys + (print-date time style))) + +(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) + (setf doy (- doy (floor (+ 23 (* 4 month)) 10))) + (when (leap-year? year) + (incf doy))) + doy)) + +(defun parse-yearstring (string) + (let ((year (or (parse-integer-insensitively string) + (extract-roman string)))) + (when (and year (< 1500 year 2500)) + (make-time :year year)))) + +(defun parse-integer-insensitively (string) + (let ((start (position-if #'digit-char-p string)) + (end (position-if #'digit-char-p string :from-end t))) + (when (and start end) + (parse-integer (subseq string start (1+ end)) :junk-allowed t)))) + +(defvar *roman-digits* + '((#\M . 1000) + (#\D . 500) + (#\C . 100) + (#\L . 50) + (#\X . 10) + (#\V . 5) + (#\I . 1))) + +(defun extract-roman (string &aux parse) + (dotimes (x (length string)) + (let ((val (cdr (assoc (aref string x) *roman-digits*)))) + (when (and val parse (< (car parse) val)) + (push (- (pop parse)) parse)) + (push val parse))) + (apply #'+ parse)) + + +;; ------------------------------------------------------------ +;; 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)))) + (setf 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/sql/transaction.lisp b/sql/transaction.lisp new file mode 100644 index 0000000..0b2b63d --- /dev/null +++ b/sql/transaction.lisp @@ -0,0 +1,102 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; +;;;; $Id$ +;;;; +;;;; Transaction support +;;;; +;;;; This file is part of CLSQL. +;;;; +;;;; CLSQL users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. +;;;; ************************************************************************* + +(in-package #:clsql-sys) + +(defclass 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) + (unless database (error 'clsql-no-database-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) + (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) + (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/sql/utils.lisp b/sql/utils.lisp new file mode 100644 index 0000000..e1de857 --- /dev/null +++ b/sql/utils.lisp @@ -0,0 +1,343 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; 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-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 #:clsql-sys) + +(defun number-to-sql-string (num) + (etypecase num + (integer + num) + (rational + (float-to-sql-string (coerce num 'double-float))) + (number + (float-to-sql-string num)))) + +(defun float-to-sql-string (num) + "Convert exponent character for SQL" + (let ((str (write-to-string num :readably t))) + (cond + ((find #\f str) + (substitute #\e #\f str)) + ((find #\d str) + (substitute #\e #\d str)) + ((find #\l str) + (substitute #\e #\l str)) + ((find #\s str) + (substitute #\e #\S str)) + ((find #\F str) + (substitute #\e #\F str)) + ((find #\D str) + (substitute #\e #\D str)) + ((find #\L str) + (substitute #\e #\L str)) + ((find #\S str) + (substitute #\e #\S str)) + (t + str)))) + +(defun sql-escape (identifier) + "Change hyphens to underscores, ensure string" + (let* ((unescaped (etypecase identifier + (symbol (symbol-name identifier)) + (string identifier))) + (escaped (make-string (length unescaped)))) + (dotimes (i (length unescaped)) + (setf (char escaped i) + (cond ((equal (char unescaped i) #\-) + #\_) + ;; ... + (t + (char unescaped i))))) + escaped)) + +(defmacro without-interrupts (&body body) + #+lispworks `(mp:without-preemption ,@body) + #+allegro `(mp:without-scheduling ,@body) + #+cmu `(system:without-interrupts ,@body) + #+sbcl `(sb-sys::without-interrupts ,@body) + #+openmcl `(ccl:without-interrupts ,@body)) + +(defun make-process-lock (name) + #+allegro (mp:make-process-lock :name name) + #+cmu (mp:make-lock name) + #+lispworks (mp:make-lock :name name) + #+openmcl (ccl:make-lock name) + #+sb-thread (sb-thread:make-mutex :name name) + #+scl (thread:make-lock name) + #-(or allegro cmu lispworks openmcl sb-thread scl) (declare (ignore name)) + #-(or allegro cmu lispworks openmcl sb-thread scl) nil) + +(defmacro with-process-lock ((lock desc) &body body) + #+(or cmu allegro lispworks openmcl sb-thread) + (declare (ignore desc)) + #+(or allegro cmu lispworks openmcl sb-thread) + (let ((l (gensym))) + `(let ((,l ,lock)) + #+allegro (mp:with-process-lock (,l) ,@body) + #+cmu (mp:with-lock-held (,l) ,@body) + #+openmcl (ccl:with-lock-grabbed (,l) ,@body) + #+lispworks (mp:with-lock (,l) ,@body) + #+sb-thread (sb-thread:with-recursive-lock (,l) ,@body) + )) + #+scl `(thread:with-lock-held (,lock ,desc) ,@body) + #-(or cmu allegro lispworks openmcl sb-thread scl) (declare + (ignore lock desc)) + #-(or cmu allegro lispworks openmcl sb-thread scl) `(progn ,@body)) + +(defun sql-escape-quotes (s) + "Escape quotes for SQL string writing" + (substitute-string-for-char s #\' "''")) + +(defun substitute-string-for-char (procstr match-char subst-str) +"Substitutes a string for a single matching character of a string" + (let ((pos (position match-char procstr))) + (if pos + (concatenate 'string + (subseq procstr 0 pos) subst-str + (substitute-string-for-char + (subseq procstr (1+ pos)) match-char subst-str)) + procstr))) + + +(defun position-char (char string start max) + "From KMRCL." + (declare (optimize (speed 3) (safety 0) (space 0)) + (fixnum start max) (simple-string string)) + (do* ((i start (1+ i))) + ((= i max) nil) + (declare (fixnum i)) + (when (char= char (schar string i)) (return i)))) + +(defun delimited-string-to-list (string &optional (separator #\space) + skip-terminal) + "Split a string with delimiter, from KMRCL." + (declare (optimize (speed 3) (safety 0) (space 0) (compilation-speed 0)) + (type string string) + (type character separator)) + (do* ((len (length string)) + (output '()) + (pos 0) + (end (position-char separator string pos len) + (position-char separator string pos len))) + ((null end) + (if (< pos len) + (push (subseq string pos) output) + (when (or (not skip-terminal) (zerop len)) + (push "" output))) + (nreverse output)) + (declare (type fixnum pos len) + (type (or null fixnum) end)) + (push (subseq string pos end) output) + (setq pos (1+ end)))) + +(defun string-to-list-connection-spec (str) + (let ((at-pos (position-char #\@ str 0 (length str)))) + (cond + ((and at-pos (> (length str) at-pos)) + ;; Connection spec is SQL*NET format + (cons (subseq str (1+ at-pos)) + (delimited-string-to-list (subseq str 0 at-pos) #\/))) + (t + (delimited-string-to-list str #\/))))) + +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (unless (find-package '#:excl.osi) + (require 'osi))) + +(defun command-output (control-string &rest args) + ;; Concatenates output and error since Lispworks combines + ;; these, thus CLSQL can't depend upon separate results + (multiple-value-bind (output error status) + (apply #'%command-output control-string args) + (values + (concatenate 'string (if output output "") + (if error error "")) + status))) + +(defun read-stream-to-string (in) + (with-output-to-string (out) + (let ((eof (gensym))) + (do ((line (read-line in nil eof) + (read-line in nil eof))) + ((eq line eof)) + (format out "~A~%" line))))) + +;; From KMRCL +(defun %command-output (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, +returns (VALUES string-output error-output exit-status)" + (let ((command (apply #'format nil control-string args))) + #+sbcl + (let* ((process (sb-ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (sb-impl::process-output process))) + (error (read-stream-to-string (sb-impl::process-error process)))) + (close (sb-impl::process-output process)) + (close (sb-impl::process-error process)) + (values + output + error + (sb-impl::process-exit-code process))) + + + #+(or cmu scl) + (let* ((process (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream)) + (output (read-stream-to-string (ext::process-output process))) + (error (read-stream-to-string (ext::process-error process)))) + (close (ext::process-output process)) + (close (ext::process-error process)) + + (values + output + error + (ext::process-exit-code process))) + + #+allegro + (multiple-value-bind (output error status) + (excl.osi:command-output command :whole t) + (values output error status)) + + #+lispworks + ;; BUG: Lispworks combines output and error streams + (let ((output (make-string-output-stream))) + (unwind-protect + (let ((status + (system:call-system-showing-output + command + :shell-type "/bin/sh" + :output-stream output))) + (values (get-output-stream-string output) nil status)) + (close output))) + + #+clisp + ;; BUG: CLisp doesn't allow output to user-specified stream + (values + nil + nil + (ext:run-shell-command command :output :terminal :wait t)) + + #+openmcl + (let* ((process (ccl:run-program + "/bin/sh" + (list "-c" command) + :input nil :output :stream :error :stream + :wait t)) + (output (read-stream-to-string (ccl::external-process-output-stream process))) + (error (read-stream-to-string (ccl::external-process-error-stream process)))) + (close (ccl::external-process-output-stream process)) + (close (ccl::external-process-error-stream process)) + (values output + error + (nth-value 1 (ccl::external-process-status process)))) + + #-(or openmcl clisp lispworks allegro scl cmu sbcl) + (error "COMMAND-OUTPUT not implemented for this Lisp") + + )) + + +;; From KMRCL +(defmacro in (obj &rest choices) + (let ((insym (gensym))) + `(let ((,insym ,obj)) + (or ,@(mapcar #'(lambda (c) `(eql ,insym ,c)) + choices))))) + +;; From KMRCL +(defun substitute-char-string (procstr match-char subst-str) + "Substitutes a string for a single matching character of a string" + (substitute-chars-strings procstr (list (cons match-char subst-str)))) + +(defun replaced-string-length (str repl-alist) + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((i 0 (1+ i)) + (orig-len (length str)) + (new-len orig-len)) + ((= i orig-len) new-len) + (declare (fixnum i orig-len new-len)) + (let* ((c (char str i)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (when match + (incf new-len (1- (length + (the simple-string (cdr match))))))))) + + +(defun substitute-chars-strings (str repl-alist) + "Replace all instances of a chars with a string. repl-alist is an assoc +list of characters and replacement strings." + (declare (simple-string str) + (optimize (speed 3) (safety 0) (space 0))) + (do* ((orig-len (length str)) + (new-string (make-string (replaced-string-length str repl-alist))) + (spos 0 (1+ spos)) + (dpos 0)) + ((>= spos orig-len) + new-string) + (declare (fixnum spos dpos) (simple-string new-string)) + (let* ((c (char str spos)) + (match (assoc c repl-alist :test #'char=))) + (declare (character c)) + (if match + (let* ((subst (cdr match)) + (len (length subst))) + (declare (fixnum len) + (simple-string subst)) + (dotimes (j len) + (declare (fixnum j)) + (setf (char new-string dpos) (char subst j)) + (incf dpos))) + (progn + (setf (char new-string dpos) c) + (incf dpos)))))) + + +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (char= #\a (schar (symbol-name '#:a) 0)) + (pushnew :lowercase-reader *features*))) + +(defun symbol-name-default-case (str) + #-lowercase-reader + (string-upcase str) + #+lowercase-reader + (string-downcase str)) + +(defun convert-to-db-default-case (str database) + (if database + (case (db-type-default-case (database-underlying-type database)) + (:upper (string-upcase str)) + (:lower (string-downcase str)) + (t str)) + ;; Default CommonSQL behavior is to upcase strings + (string-upcase str))) + + +(defun ensure-keyword (name) + "Returns keyword for a name" + (etypecase name + (keyword name) + (string (nth-value 0 (intern (symbol-name-default-case name) :keyword))) + (symbol (nth-value 0 (intern (symbol-name name) :keyword))))) diff --git a/tests/benchmarks.lisp b/tests/benchmarks.lisp index c6b0be0..ec281d4 100644 --- a/tests/benchmarks.lisp +++ b/tests/benchmarks.lisp @@ -74,9 +74,9 @@ (mapcar #'(lambda (ea) (slot-value ea 'address)) (select 'employee-address :flatp t)))) (format *report-stream* "~&~%*** JOINED OBJECT QUERY RETRIEVAL DEFERRED ***~%") - (let* ((slotdef (find 'address (clsql::class-slots (find-class 'employee-address)) - :key #'clsql::slot-definition-name)) - (dbi (when slotdef (clsql::view-class-slot-db-info slotdef)))) + (let* ((slotdef (find 'address (clsql-sys::class-slots (find-class 'employee-address)) + :key #'clsql-sys::slot-definition-name)) + (dbi (when slotdef (clsql-sys::view-class-slot-db-info slotdef)))) (setf (gethash :retrieval dbi) :deferred) (time (dotimes (i (truncate n 10)) diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp index 35b3921..6a27fdd 100644 --- a/tests/test-basic.lisp +++ b/tests/test-basic.lisp @@ -3,7 +3,7 @@ ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: test-basic.lisp -;;;; Purpose: Tests for clsql-base and result types +;;;; Purpose: Tests for clsql string-based queries and result types ;;;; Author: Kevin M. Rosenberg ;;;; Created: Mar 2002 ;;;; @@ -29,9 +29,9 @@ (clsql:execute-command (format nil "INSERT INTO TYPE_TABLE VALUES (~a,~a,~a,'~a')" test-int - (clsql-base:number-to-sql-string test-flt) + (clsql-sys:number-to-sql-string test-flt) (transform-bigint-1 test-int) - (clsql-base:number-to-sql-string test-flt) + (clsql-sys:number-to-sql-string test-flt) ))))) (defun test-basic-forms () diff --git a/tests/test-connection.lisp b/tests/test-connection.lisp index 11d3cc4..7f5a786 100644 --- a/tests/test-connection.lisp +++ b/tests/test-connection.lisp @@ -22,17 +22,17 @@ (deftest :connection/1 (let ((database (clsql:find-database (clsql:database-name clsql:*default-database*) - :db-type (clsql:database-type clsql:*default-database*)))) - (eql (clsql:database-type database) *test-database-type*)) + :db-type (clsql-sys:database-type clsql:*default-database*)))) + (eql (clsql-sys:database-type database) *test-database-type*)) t) (deftest :connection/2 - (clsql-base::string-to-list-connection-spec + (clsql-sys::string-to-list-connection-spec "localhost/dbname/user/passwd") ("localhost" "dbname" "user" "passwd")) (deftest :connection/3 - (clsql-base::string-to-list-connection-spec + (clsql-sys::string-to-list-connection-spec "dbname/user@hostname") ("hostname" "dbname" "user")) diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp index 2db453f..32e645b 100644 --- a/tests/test-fddl.lisp +++ b/tests/test-fddl.lisp @@ -112,7 +112,7 @@ t nil) ;; create a view, list its attributes and drop it -(when (clsql-base:db-type-has-views? *test-database-underlying-type*) +(when (clsql-sys:db-type-has-views? *test-database-underlying-type*) (deftest :fddl/view/2 (progn (clsql:create-view [lenins-group] :as [select [first-name] [last-name] [email] diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp index 5c95fcd..0286b2d 100644 --- a/tests/test-fdml.lisp +++ b/tests/test-fdml.lisp @@ -248,7 +248,7 @@ ("lenin@soviet.org")) (deftest :fdml/select/6 - (if (db-type-has-fancy-math? *test-database-underlying-type*) + (if (clsql-sys:db-type-has-fancy-math? *test-database-underlying-type*) (mapcar #'(lambda (s) (parse-integer s :junk-allowed t)) (clsql:select [function "trunc" [height]] :from [employee] :result-types nil diff --git a/tests/test-init.lisp b/tests/test-init.lisp index f0ff688..10caf4c 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -164,7 +164,7 @@ (:base-table "ea_join")) (defun test-connect-to-database (db-type spec) - (when (db-backend-has-create/destroy-db? db-type) + (when (clsql-sys:db-backend-has-create/destroy-db? db-type) (ignore-errors (destroy-database spec :database-type db-type)) (ignore-errors (create-database spec :database-type db-type))) @@ -182,7 +182,7 @@ (truncate-database :database *default-database*) (setf *test-database-underlying-type* - (clsql:database-underlying-type *default-database*)) + (clsql-sys:database-underlying-type *default-database*)) *default-database*) @@ -447,7 +447,7 @@ (defun load-necessary-systems (specs) (dolist (db-type +all-db-types+) (when (db-type-spec db-type specs) - (clsql:initialize-database-type :database-type db-type)))) + (clsql-sys:initialize-database-type :database-type db-type)))) (defun write-report-banner (report-type db-type stream) (format stream @@ -522,28 +522,28 @@ *rt-ooddl* *rt-oodml* *rt-syntax*)) (let ((test (second test-form))) (cond - ((and (null (db-type-has-views? db-underlying-type)) - (clsql-base::in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4)) + ((and (null (clsql-sys:db-type-has-views? db-underlying-type)) + (clsql-sys:in test :fddl/view/1 :fddl/view/2 :fddl/view/3 :fddl/view/4)) (push (cons test "views not supported") skip-tests)) - ((and (null (db-type-has-boolean-where? db-underlying-type)) - (clsql-base::in test :fdml/select/11 :oodml/select/5)) + ((and (null (clsql-sys:db-type-has-boolean-where? db-underlying-type)) + (clsql-sys:in test :fdml/select/11 :oodml/select/5)) (push (cons test "boolean where not supported") skip-tests)) - ((and (null (db-type-has-subqueries? db-underlying-type)) - (clsql-base::in test :fdml/select/5 :fdml/select/10)) + ((and (null (clsql-sys:db-type-has-subqueries? db-underlying-type)) + (clsql-sys:in test :fdml/select/5 :fdml/select/10)) (push (cons test "subqueries not supported") skip-tests)) - ((and (null (db-type-transaction-capable? db-underlying-type + ((and (null (clsql-sys:db-type-transaction-capable? db-underlying-type *default-database*)) - (clsql-base::in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4)) + (clsql-sys:in test :fdml/transaction/1 :fdml/transaction/2 :fdml/transaction/3 :fdml/transaction/4)) (push (cons test "transactions not supported") skip-tests)) - ((and (null (db-type-has-fancy-math? db-underlying-type)) - (clsql-base::in test :fdml/select/1)) + ((and (null (clsql-sys:db-type-has-fancy-math? db-underlying-type)) + (clsql-sys:in test :fdml/select/1)) (push (cons test "fancy math not supported") skip-tests)) ((and (eql *test-database-type* :sqlite) - (clsql-base::in test :fddl/view/4 :fdml/select/10 + (clsql-sys:in test :fddl/view/4 :fdml/select/10 :fdml/select/21)) (push (cons test "not supported by sqlite") skip-tests)) ((and (eql *test-database-underlying-type* :mysql) - (clsql-base::in test :fdml/select/22 :fdml/query/5 + (clsql-sys:in test :fdml/select/22 :fdml/query/5 :fdml/query/7 :fdml/query/8)) (push (cons test "not supported by mysql") skip-tests)) (t diff --git a/tests/test-ooddl.lisp b/tests/test-ooddl.lisp index 48d1630..0339179 100644 --- a/tests/test-ooddl.lisp +++ b/tests/test-ooddl.lisp @@ -26,25 +26,25 @@ ;; Ensure slots inherited from standard-classes are :virtual (deftest :ooddl/metaclass/1 (values - (clsql::view-class-slot-db-kind - (clsql::slotdef-for-slot-with-class 'extraterrestrial + (clsql-sys::view-class-slot-db-kind + (clsql-sys::slotdef-for-slot-with-class 'extraterrestrial (find-class 'person))) - (clsql::view-class-slot-db-kind - (clsql::slotdef-for-slot-with-class 'hobby (find-class 'person)))) + (clsql-sys::view-class-slot-db-kind + (clsql-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 'clsql::view-class-effective-slot-definition)) - (clsql::class-slots (find-class 'person))) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'person))) (every #'(lambda (slotd) - (typep slotd 'clsql::view-class-effective-slot-definition)) - (clsql::class-slots (find-class 'employee))) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'employee))) (every #'(lambda (slotd) - (typep slotd 'clsql::view-class-effective-slot-definition)) - (clsql::class-slots (find-class 'company)))) + (typep slotd 'clsql-sys::view-class-effective-slot-definition)) + (clsql-sys::class-slots (find-class 'company)))) t t t) (deftest :ooddl/join/1